[project @ 1998-02-06 15:04:59 by simonm]

Add a few module from the old HBC lib: they're needed by a couple of things
in nofib.

These can disappear once the dependencies are removed.

ghc/lib/misc/ByteOps.lhs

+{-
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
+%
+\section[ByteOps]{Convert to/from ``bytes''; to support @Native@ class}
+
+This mimics some code that comes with HBC.
+-}
+
+\begin{code}
+module ByteOps (
+	longToBytes,
+	intToBytes,
+	shortToBytes,
+	floatToBytes,
+	doubleToBytes,
+
+	bytesToLong,
+	bytesToInt,
+	bytesToShort,
+	bytesToFloat,
+	bytesToDouble
+    ) where
+
+import GlaExts
+import PrelBase
+
+-- \tr{xxxToBytes} prepends an \tr{xxx} to a byte stream.
+-- \tr{bytesToXxx} snaffles an \tr{xxx} from a byte stream,
+-- also returning the rest of the stream.
+
+type Bytes = [Char]
+
+longToBytes    :: Int    -> Bytes -> Bytes
+intToBytes     :: Int    -> Bytes -> Bytes
+shortToBytes   :: Int    -> Bytes -> Bytes
+floatToBytes   :: Float  -> Bytes -> Bytes
+doubleToBytes  :: Double -> Bytes -> Bytes
+
+bytesToLong    :: Bytes -> (Int,    Bytes)
+bytesToInt     :: Bytes -> (Int,    Bytes)
+bytesToShort   :: Bytes -> (Int,    Bytes)
+bytesToFloat   :: Bytes -> (Float,  Bytes)
+bytesToDouble  :: Bytes -> (Double, Bytes)
+
+--Here we go.
+
+#define XXXXToBytes(type,xxxx,xxxx__) \
+xxxx i stream \
+  = let \
+	long_bytes	{- DANGEROUS! -} \
+	  = unsafePerformIO ( \
+		{- Allocate a wad of memory to put the "long"'s bytes. \
+		   Let's hope 32 bytes will be big enough. -} \
+		stToIO (newCharArray (0::Int, 31)) >>= \ arr# -> \
+ \
+		{- Call out to C to do the dirty deed: -} \
+		_casm_ ``%r = xxxx__ ((type)%0, (unsigned char *)%1);'' i arr# \
+			>>= \ num_bytes -> \
+ \
+		unpack arr# 0 (num_bytes - 1) \
+	    ) \
+    in \
+    long_bytes ++ stream
+
+XXXXToBytes(long,longToBytes,long2bytes__)
+XXXXToBytes(int,intToBytes,int2bytes__)
+XXXXToBytes(short,shortToBytes,short2bytes__)
+XXXXToBytes(float,floatToBytes,float2bytes__)
+XXXXToBytes(double,doubleToBytes,double2bytes__)
+
+--------------
+unpack :: MutableByteArray RealWorld Int -> Int -> Int -> IO [Char]
+
+unpack arr# curr last
+  = if curr > last then
+	return []
+    else
+	stToIO (readCharArray arr# curr) >>= \ ch ->
+	unpack arr# (curr + 1) last	 >>= \ rest ->
+	return (ch : rest)
+
+-------------
+--Now we go the other way.  The paranoia checking (absent) leaves
+--something to be desired.  Really have to be careful on
+--funny-sized things like \tr{shorts}...
+
+#define bytesToXXXX(htype,xxxx,alloc,read,xxxx__) \
+xxxx stream \
+  = unsafePerformIO ( \
+	{- slam (up to) 32 bytes [random] from the stream into an array -} \
+	stToIO (newCharArray (0::Int, 31)) >>= \ arr# -> \
+	pack arr# 0 31 stream		   >> \
+ \
+	{- make a one-element array to hold the result: -} \
+	stToIO (alloc (0::Int, 0))	    >>= \ res# -> \
+ \
+	{- call the C to do the business: -} \
+	_casm_ ``%r = xxxx__ ((P_)%0, (htype *) %1);'' arr# res# \
+		>>= \ num_bytes -> \
+ \
+	{- read the result out of "res#": -} \
+	stToIO (read res# (0::Int))  >>= \ i -> \
+ \
+	{- box the result and drop the number of bytes taken: -} \
+	return (i, my_drop num_bytes stream) \
+    )
+
+bytesToXXXX(I_,bytesToLong,newIntArray,readIntArray,bytes2long__)
+bytesToXXXX(I_,bytesToInt,newIntArray,readIntArray,bytes2int__)
+bytesToXXXX(I_,bytesToShort,newIntArray,readIntArray,bytes2short__)
+bytesToXXXX(StgFloat,bytesToFloat,newFloatArray,readFloatArray,bytes2float__)
+bytesToXXXX(StgDouble,bytesToDouble,newDoubleArray,readDoubleArray,bytes2double__)
+
+----------------------
+pack :: MutableByteArray RealWorld Int -> Int -> Int -> [Char] -> IO ()
+
+pack arr# curr last from_bytes
+  = if curr > last then
+       return ()
+    else
+       case from_bytes of
+	 [] -> stToIO (writeCharArray arr# curr (chr 0))
+
+	 (from_byte : xs) ->
+	   stToIO (writeCharArray arr# curr from_byte) >>
+	   pack arr# (curr + 1) last xs
+
+-- more cavalier than usual; we know there will be enough bytes:
+
+my_drop :: Int -> [a] -> [a]
+
+my_drop 0 xs     = xs
+--my_drop _  []	  = []
+my_drop m (_:xs) = my_drop (m - 1) xs
+
+\end{code}

ghc/lib/misc/Native.lhs

+\begin{code}
+#if defined(__YALE_HASKELL__)
+-- Native.hs -- native data conversions and I/O
+--
+-- author :  Sandra Loosemore
+-- date   :  07 Jun 1994
+--
+--
+-- Unlike in the original hbc version of this library, a Byte is a completely
+-- abstract data type and not a character.  You can't read and write Bytes
+-- to ordinary text files; you must use the operations defined here on
+-- Native files.
+-- It's guaranteed to be more efficient to read and write objects directly
+-- to a file than to do the conversion to a Byte stream and read/write
+-- the Byte stream.
+#endif
+
+module Native(
+       Native(..), Bytes,
+       shortIntToBytes, bytesToShortInt,
+       longIntToBytes, bytesToLongInt, 
+       showB, readB
+#if defined(__YALE_HASKELL__)
+       , openInputByteFile, openOutputByteFile, closeByteFile
+       , readBFile, readBytesFromByteFile
+       , shortIntToByteFile, bytesToShortIntIO
+       , ByteFile
+       , Byte
+#endif       
+    ) where
+
+import Ix -- 1.3
+import Array -- 1.3
+
+#if defined(__YALE_HASKELL__)
+import NativePrims
+
+-- these data types are completely opaque on the Haskell side.
+
+data Byte = Byte
+data ByteFile = ByteFile
+type Bytes = [Byte]
+
+instance Show(Byte) where
+ showsPrec _ _ = showString "Byte"
+
+instance Show(ByteFile) where
+ showsPrec _ _ = showString "ByteFile"
+
+-- Byte file primitives
+
+openInputByteFile	:: String -> IO (ByteFile)
+openOutputByteFile	:: String -> IO (ByteFile)
+closeByteFile		:: ByteFile -> IO ()
+
+openInputByteFile	= primOpenInputByteFile
+openOutputByteFile	= primOpenOutputByteFile
+closeByteFile		= primCloseByteFile
+#endif {- YALE-}
+
+#if defined(__GLASGOW_HASKELL__)
+import ByteOps -- partain
+type Bytes = [Char]
+#endif
+
+#if defined(__HBC__)
+import LMLbyteops
+type Bytes = [Char]
+#endif
+
+-- Here are the basic operations defined on the class.
+
+class Native a where
+
+    -- these are primitives
+    showBytes     :: a -> Bytes -> Bytes	        -- convert to bytes
+    readBytes     :: Bytes -> Maybe (a, Bytes)	        -- get an item and the rest
+#if defined(__YALE_HASKELL__)
+    showByteFile  :: a -> ByteFile -> IO ()
+    readByteFile  :: ByteFile -> IO a
+#endif
+
+    -- these are derived
+    listShowBytes :: [a] -> Bytes -> Bytes	        -- convert a list to bytes
+    listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes) -- get n items and the rest
+#if defined(__YALE_HASKELL__)
+    listShowByteFile :: [a] -> ByteFile -> IO ()
+    listReadByteFile :: Int -> ByteFile -> IO [a]
+#endif
+
+    -- here are defaults for the derived methods.
+  
+    listShowBytes []     bs = bs
+    listShowBytes (x:xs) bs = showBytes x (listShowBytes xs bs)
+
+    listReadBytes 0 bs = Just ([], bs)
+    listReadBytes n bs = 
+	case readBytes bs of
+	Nothing -> Nothing
+	Just (x,bs') ->
+		case listReadBytes (n-1) bs' of
+		Nothing -> Nothing
+		Just (xs,bs'') -> Just (x:xs, bs'')
+
+#if defined(__YALE_HASKELL__)
+    listShowByteFile l f =
+      foldr (\ head tail -> (showByteFile head f) >> tail)
+	    (return ())
+	    l
+
+    listReadByteFile 0 f =
+      return []
+    listReadByteFile n f =
+      readByteFile f     	    	>>= \ h ->
+      listReadByteFile (n - 1) f	>>= \ t ->
+      return (h:t)
+#endif
+
+#if ! defined(__YALE_HASKELL__)
+-- Some utilities that Yale doesn't use
+hasNElems :: Int -> [a] -> Bool
+hasNElems 0 _      = True
+hasNElems 1 (_:_)  = True		-- speedup
+hasNElems 2 (_:_:_)  = True		-- speedup
+hasNElems 3 (_:_:_:_)  = True		-- speedup
+hasNElems 4 (_:_:_:_:_)  = True		-- speedup
+hasNElems _ []     = False
+hasNElems n (_:xs) = hasNElems (n-1) xs
+
+lenLong   = length (longToBytes   0 [])
+lenInt    = length (intToBytes    0 [])
+lenShort  = length (shortToBytes  0 [])
+lenFloat  = length (floatToBytes  0 [])
+lenDouble = length (doubleToBytes 0 [])
+#endif
+
+-- Basic instances, defined as primitives
+
+instance Native Char where
+#if defined(__YALE_HASKELL__)
+    showBytes		= primCharShowBytes
+    readBytes		= primCharReadBytes
+    showByteFile	= primCharShowByteFile
+    readByteFile	= primCharReadByteFile
+#else
+    showBytes	c bs = c:bs
+    readBytes [] = Nothing
+    readBytes (c:cs) = Just (c,cs)
+    listReadBytes n bs = f n bs []
+	where f 0 bs cs = Just (reverse cs, bs)
+	      f _ [] _  = Nothing
+	      f n (b:bs) cs = f (n-1::Int) bs (b:cs)
+#endif
+
+instance Native Int where
+#if defined(__YALE_HASKELL__)
+    showBytes		= primIntShowBytes
+    readBytes		= primIntReadBytes
+    showByteFile	= primIntShowByteFile
+    readByteFile	= primIntReadByteFile
+#else
+    showBytes i bs = intToBytes i bs
+    readBytes bs = if hasNElems lenInt bs then Just (bytesToInt bs) else Nothing
+#endif
+
+instance Native Float where
+#if defined(__YALE_HASKELL__)
+    showBytes		= primFloatShowBytes
+    readBytes		= primFloatReadBytes
+    showByteFile	= primFloatShowByteFile
+    readByteFile	= primFloatReadByteFile
+#else
+    showBytes i bs = floatToBytes i bs
+    readBytes bs = if hasNElems lenFloat bs then Just (bytesToFloat bs) else Nothing
+#endif
+
+instance Native Double where
+#if defined(__YALE_HASKELL__)
+    showBytes		= primDoubleShowBytes
+    readBytes		= primDoubleReadBytes
+    showByteFile	= primDoubleShowByteFile
+    readByteFile	= primDoubleReadByteFile
+#else
+    showBytes i bs = doubleToBytes i bs
+    readBytes bs = if hasNElems lenDouble bs then Just (bytesToDouble bs) else Nothing
+#endif
+
+instance Native Bool where
+#if defined(__YALE_HASKELL__)
+    showBytes		= primBoolShowBytes
+    readBytes		= primBoolReadBytes
+    showByteFile	= primBoolShowByteFile
+    readByteFile	= primBoolReadByteFile
+#else
+    showBytes b bs = if b then '\x01':bs else '\x00':bs
+    readBytes [] = Nothing
+    readBytes (c:cs) = Just(c/='\x00', cs)
+#endif
+
+#if defined(__YALE_HASKELL__)
+-- Byte instances, so you can write Bytes to a ByteFile
+
+instance Native Byte where
+    showBytes		= (:)
+    readBytes l =
+      case l of
+	[]  -> Nothing
+	h:t -> Just(h,t)
+    showByteFile		= primByteShowByteFile
+    readByteFile		= primByteReadByteFile
+#endif
+
+-- A pair is stored as two consecutive items.
+instance (Native a, Native b) => Native (a,b) where
+    showBytes (a,b) = showBytes a . showBytes b
+    readBytes bs = readBytes bs  >>= \(a,bs') -> 
+                   readBytes bs' >>= \(b,bs'') ->
+                   return ((a,b), bs'')
+#if defined(__YALE_HASKELL__)
+    showByteFile (a,b) f = (showByteFile a f) >> (showByteFile b f)
+
+    readByteFile f =
+      readByteFile f	    >>= \ a ->
+      readByteFile f	    >>= \ b ->
+      return (a,b)
+#endif
+
+-- A triple is stored as three consectutive items.
+instance (Native a, Native b, Native c) => Native (a,b,c) where
+    showBytes (a,b,c) = showBytes a . showBytes b . showBytes c
+    readBytes bs = readBytes bs   >>= \(a,bs') -> 
+                   readBytes bs'  >>= \(b,bs'') ->
+                   readBytes bs'' >>= \(c,bs''') ->
+                   return ((a,b,c), bs''')
+#if defined(__YALE_HASKELL__)
+    showByteFile (a,b,c) f =
+      (showByteFile a f) >>
+      (showByteFile b f) >>
+      (showByteFile c f)
+
+    readByteFile f =
+      readByteFile f	>>= \ a ->
+      readByteFile f	>>= \ b ->
+      readByteFile f	>>= \ c ->
+      return (a,b,c)
+#endif
+
+-- A list is stored with an Int with the number of items followed by the items.
+instance (Native a) => Native [a] where
+    showBytes xs bs = showBytes (length xs) (f xs) where f [] = bs
+                                                         f (x:xs) = showBytes x (f xs)
+    readBytes bs = readBytes bs		>>= \(n,bs') ->
+                   listReadBytes n bs'	>>= \(xs, bs'') ->
+                   return (xs, bs'')
+#if defined(__YALE_HASKELL__)
+    showByteFile l f = (showByteFile (length l) f) >> (listShowByteFile l f)
+    readByteFile f = readByteFile f >>= \ n -> listReadByteFile n f
+#endif
+
+-- A Maybe is stored as a Boolean possibly followed by a value
+instance (Native a) => Native (Maybe a) where
+#if !defined(__YALE_HASKELL__)
+    showBytes Nothing = ('\x00' :)
+    showBytes (Just x) = ('\x01' :) . showBytes x
+    readBytes ('\x00':bs) = Just (Nothing, bs)
+    readBytes ('\x01':bs) = readBytes bs >>= \(a,bs') ->
+                            return (Just a, bs')
+    readBytes _ = Nothing
+#else
+    showBytes (Just a) = showBytes True . showBytes a
+    showBytes Nothing  = showBytes False
+    readBytes bs =
+	readBytes bs		>>= \ (isJust, bs') ->
+	if isJust then
+		readBytes bs'	>>= \ (a, bs'') ->
+		return (Just a, bs'')
+	else
+		return (Nothing, bs')
+
+    showByteFile (Just a) f = showByteFile True f >> showByteFile a f
+    showByteFile Nothing  f = showByteFile False f
+    readByteFile f = 
+	readByteFile f		>>= \ isJust ->
+	if isJust then
+		readByteFile f	>>= \ a ->
+		return (Just a)
+	else
+		return Nothing
+#endif
+
+instance (Native a, Ix a, Native b) => Native (Array a b) where
+    showBytes a = showBytes (bounds a) . showBytes (elems a)
+    readBytes bs = readBytes bs  >>= \(b, bs')->
+                   readBytes bs' >>= \(xs, bs'')->
+		   return (listArray b xs, bs'')
+
+shortIntToBytes :: Int   -> Bytes -> Bytes
+bytesToShortInt :: Bytes -> Maybe (Int, Bytes)
+longIntToBytes  :: Int   -> Bytes -> Bytes
+bytesToLongInt  :: Bytes -> Maybe (Int, Bytes)
+#if defined(__YALE_HASKELL__)
+shortIntToByteFile	:: Int -> ByteFile -> IO ()
+bytesToShortIntIO       :: ByteFile -> IO Int
+#endif
+
+#if defined(__YALE_HASKELL__)
+-- These functions are like the primIntxx but use a "short" rather than
+-- "int" representation.
+shortIntToBytes		= primShortShowBytes
+bytesToShortInt 	= primShortReadBytes
+shortIntToByteFile	= primShortShowByteFile
+bytesToShortIntIO 	= primShortReadByteFile
+
+#else {-! YALE-}
+
+shortIntToBytes s bs = shortToBytes s bs
+
+bytesToShortInt bs = if hasNElems lenShort bs then Just (bytesToShort bs) else Nothing
+
+longIntToBytes s bs = longToBytes s bs
+
+bytesToLongInt bs = if hasNElems lenLong bs then Just (bytesToLong bs) else Nothing
+
+#endif {-! YALE-}
+
+showB :: (Native a) => a -> Bytes
+showB x = showBytes x []
+
+readB :: (Native a) => Bytes -> a
+readB bs = 
+	case readBytes bs of
+	Just (x,[]) -> x
+	Just (_,_)  -> error "Native.readB data too long"
+        Nothing     -> error "Native.readB data too short"
+
+#if defined(__YALE_HASKELL__)
+readBFile :: String -> IO(Bytes)
+readBFile name =
+  openInputByteFile name >>= \ f ->
+  readBytesFromByteFile f
+
+readBytesFromByteFile :: ByteFile -> IO(Bytes)
+readBytesFromByteFile f =
+  try
+    (primByteReadByteFile f  >>= \ h -> 
+     readBytesFromByteFile f >>= \ t ->
+     return (h:t))
+    onEOF
+ where
+   onEOF EOF = closeByteFile f >> return []
+   onEOF err = closeByteFile f >> failwith err
+#endif
+\end{code}

ghc/lib/misc/Printf.lhs

+
+ A C printf like formatter.
+ Conversion specs:
+	-	left adjust
+	num	field width
+      *       as num, but taken from argument list
+	.	separates width from precision
+ Formatting characters:
+ 	c	Char, Int, Integer
+	d	Char, Int, Integer
+	o	Char, Int, Integer
+	x	Char, Int, Integer
+	u	Char, Int, Integer
+	f	Float, Double
+	g	Float, Double
+	e	Float, Double
+	s	String
+
+\begin{code}
+module Printf(UPrintf(..), printf) where
+
+import Char	( isDigit )    -- 1.3
+import Array	( array, (!) ) -- 1.3
+
+
+#if defined(__HBC__)
+import LMLfmtf
+#endif
+
+#if defined(__YALE_HASKELL__)
+import PrintfPrims
+#endif
+
+#if defined(__GLASGOW_HASKELL__)
+import GlaExts
+import PrelArr (Array(..), ByteArray(..))
+import PrelBase hiding (itos)
+#endif
+
+data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
+
+printf :: String -> [UPrintf] -> String
+printf ""       []       = ""
+printf ""       (_:_)    = fmterr
+printf ('%':'%':cs) us   = '%':printf cs us
+printf ('%':_)  []       = argerr
+printf ('%':cs) us@(_:_) = fmt cs us
+printf (c:cs)   us       = c:printf cs us
+
+fmt :: String -> [UPrintf] -> String
+fmt cs us =
+	let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
+	    adjust (pre, str) = 
+		let lstr = length str
+		    lpre = length pre
+		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
+		in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
+        in
+	case cs' of
+	[]     -> fmterr
+	c:cs'' ->
+	    case us' of
+	    []     -> argerr
+	    u:us'' ->
+		(case c of
+		'c' -> adjust ("", [chr (toint u)])
+		'd' -> adjust (fmti u)
+		'x' -> adjust ("", fmtu 16 u)
+		'o' -> adjust ("", fmtu 8  u)
+		'u' -> adjust ("", fmtu 10 u)
+#if defined __YALE_HASKELL__
+		'e' -> adjust (fmte prec (todbl u))
+		'f' -> adjust (fmtf prec (todbl u))
+		'g' -> adjust (fmtg prec (todbl u))
+#else
+		'e' -> adjust (dfmt c prec (todbl u))
+		'f' -> adjust (dfmt c prec (todbl u))
+		'g' -> adjust (dfmt c prec (todbl u))
+#endif
+		's' -> adjust ("", tostr u)
+		c   -> perror ("bad formatting char " ++ [c])
+		) ++ printf cs'' us''
+
+fmti (UInt i)     = if i < 0 then
+			if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
+		    else
+			("", itos i)
+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
+fmti (UChar c)    = fmti (UInt (ord c))
+fmti u		  = baderr
+
+fmtu b (UInt i)     = if i < 0 then
+			  if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
+		      else
+			  itosb b (toInteger i)
+fmtu b (UInteger i) = itosb b i
+fmtu b (UChar c)    = itosb b (toInteger (ord c))
+fmtu b u            = baderr
+
+maxi :: Integer
+maxi = (toInteger (maxBound::Int) + 1) * 2
+
+toint (UInt i)     = i
+toint (UInteger i) = toInt i
+toint (UChar c)    = ord c
+toint u		   = baderr
+
+tostr (UString s) = s
+tostr u		  = baderr
+
+todbl (UDouble d)     = d
+#if defined(__GLASGOW_HASKELL__)
+todbl (UFloat (F# f)) = D# (float2Double# f) -- What a great system(TM) !
+#else
+todbl (UFloat f)      = fromRational (toRational f)
+#endif
+todbl u		      = baderr
+
+itos n = 
+	if n < 10 then 
+	    [chr (ord '0' + toInt n)]
+	else
+	    let (q, r) = quotRem n 10 in
+	    itos q ++ [chr (ord '0' + toInt r)]
+
+chars :: Array Int Char
+chars = array (0,15) (zipWith (\x y -> (x,y)) [0..] "0123456789abcdef")
+
+itosb :: Integer -> Integer -> String
+itosb b n = 
+	if n < b then 
+	    [chars ! fromInteger n]
+	else
+	    let (q, r) = quotRem n b in
+	    itosb b q ++ [chars ! fromInteger r]
+
+stoi :: Int -> String -> (Int, String)
+stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
+stoi a cs                 = (a, cs)
+
+getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
+getSpecs l z ('-':cs) us = getSpecs True z cs us
+getSpecs l z ('0':cs) us = getSpecs l True cs us
+getSpecs l z ('*':cs) us = 
+        case us of
+        [] -> argerr
+        nu : us' ->
+	    let n = toint nu
+		(p, cs'', us'') =
+		    case cs of
+                    '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
+		    '.':r     -> let (n, cs') = stoi 0 r in (n, cs', us')
+		    _         -> (-1, cs, us')
+	    in  (n, p, l, z, cs'', us'')
+getSpecs l z cs@(c:_) us | isDigit c =
+	let (n, cs') = stoi 0 cs
+	    (p, cs'') = case cs' of
+			'.':r -> stoi 0 r
+			_     -> (-1, cs')
+	in  (n, p, l, z, cs'', us)
+getSpecs l z cs       us = (0, -1, l, z, cs, us)
+
+#if !defined(__YALE_HASKELL__)
+dfmt :: Char -> Int -> Double -> (String, String)
+#endif
+
+#if defined(__GLASGOW_HASKELL__)
+dfmt c{-e,f, or g-} prec d
+  = unsafePerformIO (
+	stToIO (newCharArray (0 :: Int, 511)){-pathetic malloc-} 
+						   >>= \ sprintf_here ->
+	let
+	    sprintf_fmt  = "%1" ++ (if prec < 0 then "" else '.':itos prec) ++ [c]
+	in
+	_ccall_ sprintf sprintf_here sprintf_fmt d >>
+	stToIO (freezeCharArray sprintf_here)	   >>= \ (ByteArray _ arr#) ->
+	let
+            unpack :: Int# -> [Char]
+            unpack nh = case (ord# (indexCharArray# arr# nh)) of
+		        0# -> []
+		        ch -> case (nh +# 1#) of
+			      mh -> C# (chr# ch) : unpack mh
+        in
+	return (
+	case (indexCharArray# arr# 0#) of
+	  '-'# -> ("-", unpack 1#)
+	  _    -> ("" , unpack 0#)
+  	)
+    )
+#endif
+
+#if defined(__HBC__)
+dfmt c p d = 
+	case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
+	'-':cs -> ("-", cs)
+	cs     -> ("" , cs)
+#endif
+
+#if defined(__YALE_HASKELL__)
+fmte p d =
+  case (primFmte p d) of
+    '-':cs -> ("-",cs)
+    cs     -> ("",cs)
+fmtf p d =
+  case (primFmtf p d) of
+    '-':cs -> ("-",cs)
+    cs     -> ("",cs)
+fmtg p d =
+  case (primFmtg p d) of
+    '-':cs -> ("-",cs)
+    cs     -> ("",cs)
+#endif
+
+perror s = error ("Printf.printf: "++s)
+fmterr = perror "formatting string ended prematurely"
+argerr = perror "argument list ended prematurely"
+baderr = perror "bad argument"
+
+#if defined(__YALE_HASKELL__)
+-- This is needed because standard Haskell does not have toInt
+
+toInt :: Integral a => a -> Int
+toInt x = fromIntegral x
+#endif
+\end{code}