From 3a2b8c962894fcfb8828eaaaa07f644c528eed7c Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Fri, 6 Feb 1998 15:05:02 +0000
Subject: [PATCH] [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 | 137 +++++++++++++++
ghc/lib/misc/Native.lhs | 353 +++++++++++++++++++++++++++++++++++++++
ghc/lib/misc/Printf.lhs | 225 +++++++++++++++++++++++++
3 files changed, 715 insertions(+)
create mode 100644 ghc/lib/misc/ByteOps.lhs
create mode 100644 ghc/lib/misc/Native.lhs
create mode 100644 ghc/lib/misc/Printf.lhs
diff --git a/ghc/lib/misc/ByteOps.lhs b/ghc/lib/misc/ByteOps.lhs
new file mode 100644
index 000000000000..3eb0334e76d4
--- /dev/null
+++ b/ghc/lib/misc/ByteOps.lhs
@@ -0,0 +1,137 @@
+{-
+%
+% (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}
diff --git a/ghc/lib/misc/Native.lhs b/ghc/lib/misc/Native.lhs
new file mode 100644
index 000000000000..4ca85a160324
--- /dev/null
+++ b/ghc/lib/misc/Native.lhs
@@ -0,0 +1,353 @@
+\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}
diff --git a/ghc/lib/misc/Printf.lhs b/ghc/lib/misc/Printf.lhs
new file mode 100644
index 000000000000..d11a5396816f
--- /dev/null
+++ b/ghc/lib/misc/Printf.lhs
@@ -0,0 +1,225 @@
+
+ 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}
--
GitLab