From f608faec774d5d2cd895240c1e0e66a48aa6cbe3 Mon Sep 17 00:00:00 2001 From: andy Date: Fri, 29 Oct 1999 01:16:50 +0000 Subject: [PATCH] [project @ 1999-10-29 01:16:48 by andy] Adding in the modified versions of the Standard Haskell 98 libraries. These should compile under both Hugs and GHC. use the flags -D__HUGS__ -DUSE_REPORT_PRELUDE to extract the Hugs src. --- ghc/lib/std/Array.lhs | 80 +++++++++++++++ ghc/lib/std/CPUTime.lhs | 21 ++-- ghc/lib/std/Char.lhs | 4 + ghc/lib/std/Directory.lhs | 2 +- ghc/lib/std/IO.lhs | 237 ++++++++++++++++++++++++++++++++++++++++---- ghc/lib/std/Ix.lhs | 8 ++ ghc/lib/std/List.lhs | 22 +++-- ghc/lib/std/Maybe.lhs | 2 + ghc/lib/std/Monad.lhs | 15 +++ ghc/lib/std/Numeric.lhs | 238 ++++++++++++++++++++++++++++++++++++++++++++- ghc/lib/std/Random.lhs | 56 ++++++++++- ghc/lib/std/Ratio.lhs | 2 + ghc/lib/std/System.lhs | 59 +++++++++-- 13 files changed, 702 insertions(+), 44 deletions(-) diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs index 715dc73..e703494 100644 --- a/ghc/lib/std/Array.lhs +++ b/ghc/lib/std/Array.lhs @@ -38,15 +38,21 @@ module Array ) where +#ifndef __HUGS__ import Ix import PrelList import PrelShow import PrelArr -- Most of the hard work is done here import PrelBase +#else +import Ix +import List( (\\) ) +#endif infixl 9 !, // \end{code} +#ifndef __HUGS__ %********************************************************* @@ -122,3 +128,77 @@ instance (Ix a, Read a, Read b) => Read (Array a b) where readList = readList__ (readsPrec 0) -} \end{code} + + +#else +\begin{code} +data Array ix elt = Array (ix,ix) (PrimArray elt) + +array :: Ix a => (a,a) -> [(a,b)] -> Array a b +array ixs@(ix_start, ix_end) ivs = primRunST (do + { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom + ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs + ; arr <- primUnsafeFreezeArray mut_arr + ; return (Array ixs arr) + } + ) + where + arrEleBottom = error "(Array.!): undefined array element" + +listArray :: Ix a => (a,a) -> [b] -> Array a b +listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs) + +(!) :: Ix a => Array a b -> a -> b +(Array bounds arr) ! i = primIndexArray arr (index bounds i) + +bounds :: Ix a => Array a b -> (a,a) +bounds (Array b _) = b + +indices :: Ix a => Array a b -> [a] +indices = range . bounds + +elems :: Ix a => Array a b -> [b] +elems a = [a!i | i <- indices a] + +assocs :: Ix a => Array a b -> [(a,b)] +assocs a = [(i, a!i) | i <- indices a] + +(//) :: Ix a => Array a b -> [(a,b)] -> Array a b +a // us = array (bounds a) + ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]] + ++ us) + +accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b +accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)]) + +accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +accumArray f z b = accum f (array b [(i,z) | i <- range b]) + +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c +ixmap b f a = array b [(i, a ! f i) | i <- range b] + + +instance (Ix a) => Functor (Array a) where + fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a] + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) + +\end{code} +#endif diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index 27d540f..037460b 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -11,10 +11,11 @@ module CPUTime getCPUTime, -- :: IO Integer cpuTimePrecision -- :: Integer ) where +\end{code} -#ifdef __HUGS__ -import PreludeBuiltin -#else + +#ifndef __HUGS__ +\begin{code} import PrelBase import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray ) import PrelMaybe @@ -22,11 +23,9 @@ import PrelNum import PrelNumExtra import PrelIOBase import PrelST -#endif import IO ( ioError ) import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt import Ratio - \end{code} Computation @getCPUTime@ returns the number of picoseconds CPU time @@ -91,5 +90,15 @@ foreign import "libHS_cbits" "clockTicks" clockTicks :: IO Int \end{code} +#else + +\begin{code} +-- TODO: Hugs/getCPUTime +getCPUTime :: IO Integer +getCPUTime = return 0 - +-- TODO: Hugs/cpuTimePrecision +cpuTimePrecision :: Integer +cpuTimePrecision = 1 +\end{code} +#endif diff --git a/ghc/lib/std/Char.lhs b/ghc/lib/std/Char.lhs index 213d8f7..442b84e 100644 --- a/ghc/lib/std/Char.lhs +++ b/ghc/lib/std/Char.lhs @@ -32,10 +32,14 @@ module Char -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where +#ifndef __HUGS__ import PrelBase import PrelShow import PrelEnum import PrelNum import PrelRead (readLitChar, lexLitChar, digitToInt) import PrelErr ( error ) +#else +isLatin1 c = True +#endif \end{code} diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index a516800..8133119 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -51,7 +51,7 @@ module Directory ) where #ifdef __HUGS__ -import PreludeBuiltin +--import PreludeBuiltin #else import PrelBase import PrelIOBase diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index b4df950..ad656a5 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -10,7 +10,6 @@ definition. \begin{code} {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} -#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */ module IO ( Handle, -- abstract, instance of: Eq, Show. HandlePosn(..), -- abstract, instance of: Eq, Show. @@ -84,9 +83,9 @@ module IO ( readIO, -- :: Read a => String -> IO a readLn, -- :: Read a => IO a +#ifndef __HUGS__ -- extensions hPutBuf, -#ifndef __HUGS__ hPutBufBA, #endif slurpFile @@ -94,11 +93,8 @@ module IO ( ) where #ifdef __HUGS__ - -import PreludeBuiltin - +import Ix(Ix) #else - --import PrelST import PrelBase @@ -122,18 +118,10 @@ import PrelForeign ( ForeignObj ) import Char ( ord, chr ) #endif /* ndef __HUGS__ */ -#endif /* ndef BODY */ - -#ifndef HEAD - -#ifdef __HUGS__ -#define __CONCURRENT_HASKELL__ -#define stToIO id -#define unpackNBytesAccST primUnpackCStringAcc -#endif - \end{code} +#ifndef __HUGS__ + Standard instances for @Handle@: \begin{code} @@ -745,6 +733,221 @@ readLn = do l <- getLine r <- readIO l return r -#endif /* ndef HEAD */ \end{code} + +#else +\begin{code} +unimp :: String -> a +unimp s = error ("function not implemented: " ++ s) + +type FILE_STAR = Int +type Ptr = Int +nULL = 0 :: Int + +data Handle + = Handle { name :: FilePath, + file :: FILE_STAR, -- C handle + state :: HState, -- open/closed/semiclosed + mode :: IOMode, + --seekable :: Bool, + bmode :: BufferMode, + buff :: Ptr, + buffSize :: Int + } + +instance Eq Handle where + h1 == h2 = file h1 == file h2 + +instance Show Handle where + showsPrec _ h = showString ("<>") + +data HandlePosn + = HandlePosn + deriving (Eq, Show) + + +data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data BufferMode = NoBuffering | LineBuffering + | BlockBuffering + deriving (Eq, Ord, Read, Show) + +data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd + deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show) + +data HState = HOpen | HSemiClosed | HClosed + deriving Eq + +stdin = Handle "stdin" (primRunST nh_stdin) HOpen ReadMode NoBuffering nULL 0 +stdout = Handle "stdout" (primRunST nh_stdout) HOpen WriteMode LineBuffering nULL 0 +stderr = Handle "stderr" (primRunST nh_stderr) HOpen WriteMode NoBuffering nULL 0 + +openFile :: FilePath -> IOMode -> IO Handle +openFile f mode + = copy_String_to_cstring f >>= \nameptr -> + nh_open nameptr (mode2num mode) >>= \fh -> + nh_free nameptr >> + if fh == nULL + then (ioError.IOError) ("openFile: can't open " ++ f ++ " in " ++ show mode) + else return (Handle f fh HOpen mode BlockBuffering nULL 0) + where + mode2num :: IOMode -> Int + mode2num ReadMode = 0 + mode2num WriteMode = 1 + mode2num AppendMode = 2 + +hClose :: Handle -> IO () +hClose h + | not (state h == HOpen) + = (ioError.IOError) ("hClose on non-open handle " ++ show h) + | otherwise + = nh_close (file h) >> + nh_errno >>= \err -> + if err == 0 + then return () + else (ioError.IOError) ("hClose: error closing " ++ name h) + +hFileSize :: Handle -> IO Integer +hFileSize = unimp "IO.hFileSize" +hIsEOF :: Handle -> IO Bool +hIsEOF = unimp "IO.hIsEOF" +isEOF :: IO Bool +isEOF = hIsEOF stdin + +hSetBuffering :: Handle -> BufferMode -> IO () +hSetBuffering = unimp "IO.hSetBuffering" +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering = unimp "IO.hGetBuffering" + +hFlush :: Handle -> IO () +hFlush h + = if state h /= HOpen + then (ioError.IOError) ("hFlush on closed/semiclosed file " ++ name h) + else nh_flush (file h) + +hGetPosn :: Handle -> IO HandlePosn +hGetPosn = unimp "IO.hGetPosn" +hSetPosn :: HandlePosn -> IO () +hSetPosn = unimp "IO.hSetPosn" +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek = unimp "IO.hSeek" +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput = unimp "hWaitForInput" +hReady :: Handle -> IO Bool +hReady h = hWaitForInput h 0 + +hGetChar :: Handle -> IO Char +hGetChar h + = nh_read (file h) >>= \ci -> + return (primIntToChar ci) + +hGetLine :: Handle -> IO String +hGetLine h = do c <- hGetChar h + if c=='\n' then return "" + else do cs <- hGetLine h + return (c:cs) + +hLookAhead :: Handle -> IO Char +hLookAhead = unimp "IO.hLookAhead" + +hGetContents :: Handle -> IO String +hGetContents h + | not (state h == HOpen && mode h == ReadMode) + = (ioError.IOError) ("hGetContents on invalid handle " ++ show h) + | otherwise + = read_all (file h) + where + read_all f + = unsafeInterleaveIO ( + nh_read f >>= \ci -> + if ci == -1 + then hClose h >> return [] + else read_all f >>= \rest -> + return ((primIntToChar ci):rest) + ) + +hPutStr :: Handle -> String -> IO () +hPutStr h s + | not (state h == HOpen && mode h /= ReadMode) + = (ioError.IOError) ("hPutStr on invalid handle " ++ show h) + | otherwise + = write_all (file h) s + where + write_all f [] + = return () + write_all f (c:cs) + = nh_write f (primCharToInt c) >> + write_all f cs + +hPutChar :: Handle -> Char -> IO () +hPutChar h c = hPutStr h [c] + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h s = do { hPutStr h s; hPutChar h '\n' } + +hPrint :: Show a => Handle -> a -> IO () +hPrint h = hPutStrLn h . show + +hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool +hIsOpen h = return (state h == HOpen) +hIsClosed h = return (state h == HClosed) +hIsReadable h = return (mode h == ReadMode) +hIsWritable h = return (mode h == WriteMode) + +hIsSeekable :: Handle -> IO Bool +hIsSeekable = unimp "IO.hIsSeekable" + +isIllegalOperation, + isAlreadyExistsError, + isDoesNotExistError, + isAlreadyInUseError, + isFullError, + isEOFError, + isPermissionError, + isUserError :: IOError -> Bool + +isIllegalOperation = unimp "IO.isIllegalOperation" +isAlreadyExistsError = unimp "IO.isAlreadyExistsError" +isDoesNotExistError = unimp "IO.isDoesNotExistError" +isAlreadyInUseError = unimp "IO.isAlreadyInUseError" +isFullError = unimp "IO.isFullError" +isEOFError = unimp "IO.isEOFError" +isPermissionError = unimp "IO.isPermissionError" +isUserError = unimp "IO.isUserError" + + +ioeGetErrorString :: IOError -> String +ioeGetErrorString = unimp "ioeGetErrorString" +ioeGetHandle :: IOError -> Maybe Handle +ioeGetHandle = unimp "ioeGetHandle" +ioeGetFileName :: IOError -> Maybe FilePath +ioeGetFileName = unimp "ioeGetFileName" + +try :: IO a -> IO (Either IOError a) +try p = catch (p >>= (return . Right)) (return . Left) + +bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +bracket before after m = do + x <- before + rs <- try (m x) + after x + case rs of + Right r -> return r + Left e -> ioError e + +-- variant of the above where middle computation doesn't want x +bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c +bracket_ before after m = do + x <- before + rs <- try m + after x + case rs of + Right r -> return r + Left e -> ioError e + +-- TODO: Hugs/slurbFile +slurpFile = unimp "slurpFile" +\end{code} +#endif diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs index 1715448..da7a5e4 100644 --- a/ghc/lib/std/Ix.lhs +++ b/ghc/lib/std/Ix.lhs @@ -29,6 +29,7 @@ module Ix -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where +#ifndef __HUGS__ import {-# SOURCE #-} PrelErr ( error ) import PrelTup import PrelBase @@ -267,3 +268,10 @@ rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 -- Here l a -> [a] -> Maybe Int + elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int , elemIndices -- :: (Eq a) => a -> [a] -> [Int] , find -- :: (a -> Bool) -> [a] -> Maybe a @@ -127,12 +130,15 @@ module List ) where import Prelude -import PrelShow ( lines, words, unlines, unwords ) import Maybe ( listToMaybe ) + +#ifndef __HUGS__ +import PrelShow ( lines, words, unlines, unwords ) import PrelBase ( Int(..), map, (++) ) import PrelGHC ( (+#) ) +#endif -infix 5 \\ +infix 5 \\ \end{code} %********************************************************* @@ -181,12 +187,12 @@ nub :: (Eq a) => [a] -> [a] nub = nubBy (==) #else -- stolen from HBC -nub l = nub' l [] +nub l = nub' l [] -- ' where - nub' [] _ = [] - nub' (x:xs) ls - | x `elem` ls = nub' xs ls - | otherwise = x : nub' xs (x:ls) + nub' [] _ = [] -- ' + nub' (x:xs) ls -- ' + | x `elem` ls = nub' xs ls -- ' + | otherwise = x : nub' xs (x:ls) -- ' #endif nubBy :: (a -> a -> Bool) -> [a] -> [a] diff --git a/ghc/lib/std/Maybe.lhs b/ghc/lib/std/Maybe.lhs index 32d4490..99d5f47 100644 --- a/ghc/lib/std/Maybe.lhs +++ b/ghc/lib/std/Maybe.lhs @@ -29,10 +29,12 @@ module Maybe -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where +#ifndef __HUGS__ import PrelErr ( error ) import PrelList import PrelMaybe import PrelBase +#endif \end{code} diff --git a/ghc/lib/std/Monad.lhs b/ghc/lib/std/Monad.lhs index f95e1cb..b1c5a9c 100644 --- a/ghc/lib/std/Monad.lhs +++ b/ghc/lib/std/Monad.lhs @@ -39,12 +39,14 @@ module Monad , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b ) where +#ifndef __HUGS__ import PrelList import PrelTup import PrelBase import PrelMaybe ( Maybe(..) ) infixr 1 =<< +#endif \end{code} %********************************************************* @@ -78,6 +80,13 @@ instance MonadPlus Maybe where %********************************************************* \begin{code} +#ifdef __HUGS__ +-- These functions are defined in the Prelude. +-- sequence :: Monad m => [m a] -> m [a] +-- sequence_ :: Monad m => [m a] -> m () +-- mapM :: Monad m => (a -> m b) -> [a] -> m [b] +-- mapM_ :: Monad m => (a -> m b) -> [a] -> m () +#else sequence :: Monad m => [m a] -> m [a] sequence [] = return [] sequence (m:ms) = do { x <- m; xs <- sequence ms; return (x:xs) } @@ -93,6 +102,7 @@ mapM f as = sequence (map f as) mapM_ :: Monad m => (a -> m b) -> [a] -> m () {-# INLINE mapM_ #-} mapM_ f as = sequence_ (map f as) +#endif guard :: MonadPlus m => Bool -> m () guard pred @@ -114,9 +124,14 @@ msum :: MonadPlus m => [m a] -> m a {-# INLINE msum #-} msum = foldr mplus mzero +#ifdef __HUGS__ +-- This function is defined in the Prelude. +--(=<<) :: Monad m => (a -> m b) -> m a -> m b +#else {-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} (=<<) :: Monad m => (a -> m b) -> m a -> m b f =<< x = x >>= f +#endif \end{code} diff --git a/ghc/lib/std/Numeric.lhs b/ghc/lib/std/Numeric.lhs index a0365e8..fa56105 100644 --- a/ghc/lib/std/Numeric.lhs +++ b/ghc/lib/std/Numeric.lhs @@ -34,6 +34,7 @@ module Numeric -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where +#ifndef __HUGS__ import PrelBase import PrelMaybe import PrelShow @@ -42,9 +43,14 @@ import PrelNum import PrelNumExtra import PrelRead import PrelErr ( error ) - +#else +import Char +import Array +#endif \end{code} +#ifndef __HUGS__ + \begin{code} showInt :: Integral a => a -> ShowS showInt i rs @@ -75,3 +81,233 @@ showFFloat d x = showString (formatRealFloat FFFixed d x) showGFloat d x = showString (formatRealFloat FFGeneric d x) \end{code} + +#else +\begin{code} +-- This converts a rational to a floating. This should be used in the +-- Fractional instances of Float and Double. + +fromRat :: (RealFloat a) => Rational -> a +fromRat x = + if x == 0 then encodeFloat 0 0 -- Handle exceptional cases + else if x < 0 then - fromRat' (-x) -- first. + else fromRat' x + +-- Conversion process: +-- Scale the rational number by the RealFloat base until +-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat). +-- Then round the rational to an Integer and encode it with the exponent +-- that we got from the scaling. +-- To speed up the scaling process we compute the log2 of the number to get +-- a first guess of the exponent. +fromRat' :: (RealFloat a) => Rational -> a +fromRat' x = r + where b = floatRadix r + p = floatDigits r + (minExp0, _) = floatRange r + minExp = minExp0 - p -- the real minimum exponent + xMin = toRational (expt b (p-1)) + xMax = toRational (expt b p) + p0 = (integerLogBase b (numerator x) - + integerLogBase b (denominator x) - p) `max` minExp + f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1 + (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f) + r = encodeFloat (round x') p' + +-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp. +scaleRat :: Rational -> Int -> Rational -> Rational -> + Int -> Rational -> (Rational, Int) +scaleRat b minExp xMin xMax p x = + if p <= minExp then + (x, p) + else if x >= xMax then + scaleRat b minExp xMin xMax (p+1) (x/b) + else if x < xMin then + scaleRat b minExp xMin xMax (p-1) (x*b) + else + (x, p) + +-- Exponentiation with a cache for the most common numbers. +minExpt = 0::Int +maxExpt = 1100::Int +expt :: Integer -> Int -> Integer +expt base n = + if base == 2 && n >= minExpt && n <= maxExpt then + expts!n + else + base^n + +expts :: Array Int Integer +expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] + +-- Compute the (floor of the) log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, +-- but that would be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i = + if i < b then + 0 + else + -- Try squaring the base first to cut down the number of divisions. + let l = 2 * integerLogBase (b*b) i + doDiv :: Integer -> Int -> Int + doDiv i l = if i < b then l else doDiv (i `div` b) (l+1) + in doDiv (i `div` (b^l)) l + + +-- Misc utilities to show integers and floats + +showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFloat :: (RealFloat a) => a -> ShowS + +showEFloat d x = showString (formatRealFloat FFExponent d x) +showFFloat d x = showString (formatRealFloat FFFixed d x) +showGFloat d x = showString (formatRealFloat FFGeneric d x) +showFloat = showGFloat Nothing + +-- These are the format types. This type is not exported. + +data FFFormat = FFExponent | FFFixed | FFGeneric + +formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String +formatRealFloat fmt decs x = s + where base = 10 + s = if isNaN x then + "NaN" + else if isInfinite x then + if x < 0 then "-Infinity" else "Infinity" + else if x < 0 || isNegativeZero x then + '-' : doFmt fmt (floatToDigits (toInteger base) (-x)) + else + doFmt fmt (floatToDigits (toInteger base) x) + doFmt fmt (is, e) = + let ds = map intToDigit is + in case fmt of + FFGeneric -> + doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) + (is, e) + FFExponent -> + case decs of + Nothing -> + case ds of + ['0'] -> "0.0e0" + [d] -> d : ".0e" ++ show (e-1) + d:ds -> d : '.' : ds ++ 'e':show (e-1) + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0':'.':take dec' (repeat '0') ++ "e0" + _ -> + let (ei, is') = roundTo base (dec'+1) is + d:ds = map intToDigit + (if ei > 0 then init is' else is') + in d:'.':ds ++ "e" ++ show (e-1+ei) + FFFixed -> + case decs of + Nothing -> + let f 0 s ds = mk0 s ++ "." ++ mk0 ds + f n s "" = f (n-1) (s++"0") "" + f n s (d:ds) = f (n-1) (s++[d]) ds + mk0 "" = "0" + mk0 s = s + in f e "" ds + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let (ei, is') = roundTo base (dec' + e) is + (ls, rs) = splitAt (e+ei) (map intToDigit is') + in (if null ls then "0" else ls) ++ + (if null rs then "" else '.' : rs) + else + let (ei, is') = roundTo base dec' + (replicate (-e) 0 ++ is) + d : ds = map intToDigit + (if ei > 0 then is' else 0:is') + in d : '.' : ds + +roundTo :: Int -> Int -> [Int] -> (Int, [Int]) +roundTo base d is = case f d is of + (0, is) -> (0, is) + (1, is) -> (1, 1 : is) + where b2 = base `div` 2 + f n [] = (0, replicate n 0) + f 0 (i:_) = (if i >= b2 then 1 else 0, []) + f d (i:is) = + let (c, ds) = f (d-1) is + i' = c + i + in if i' == base then (1, 0:ds) else (0, i':ds) + +-- +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R. K. Dybvig, in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- This function returns a list of digits (Ints in [0..base-1]) and an +-- exponent. + +floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) + +floatToDigits _ 0 = ([0], 0) +floatToDigits base x = + let (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = let n = minExp - e0 + in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + + (r, s, mUp, mDn) = + if e >= 0 then + let be = b^e in + if f == b^(p-1) then + (f*be*b*2, 2*b, be*b, b) + else + (f*be*2, 2, be, be) + else + if e > minExp && f == b^(p-1) then + (f*b*2, b^(-e+1)*2, b, 1) + else + (f*2, b^(-e)*2, 1, 1) + k = + let k0 = + if b==2 && base==10 then + -- logBase 10 2 is slightly bigger than 3/10 so + -- the following will err on the low side. Ignoring + -- the fraction will make it err even more. + -- Haskell promises that p-1 <= logBase b f < p. + (p - 1 + e0) * 3 `div` 10 + else + ceiling ((log (fromInteger (f+1)) + + fromInt e * log (fromInteger b)) / + log (fromInteger base)) + fixup n = + if n >= 0 then + if r + mUp <= expt base n * s then n else fixup (n+1) + else + if expt base (-n) * (r + mUp) <= s then n + else fixup (n+1) + in fixup k0 + + gen ds rn sN mUpN mDnN = + let (dn, rn') = (rn * base) `divMod` sN + mUpN' = mUpN * base + mDnN' = mDnN * base + in case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + rds = + if k >= 0 then + gen [] r (s * expt base k) mUp mDn + else + let bk = expt base (-k) + in gen [] (r * bk) s (mUp * bk) (mDn * bk) + in (map toInt (reverse rds), k) +\end{code} +#endif diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs index b914d74..25b4752 100644 --- a/ghc/lib/std/Random.lhs +++ b/ghc/lib/std/Random.lhs @@ -28,6 +28,7 @@ module Random , newStdGen ) where +#ifndef __HUGS__ import CPUTime (getCPUTime) import PrelST import PrelRead @@ -37,9 +38,10 @@ import PrelIOBase import PrelNumExtra ( float2Double, double2Float ) import PrelBase import PrelArr -import Char ( isSpace, chr, ord ) import Time (getClockTime, ClockTime(..)) - +#else +#endif +import Char ( isSpace, chr, ord ) \end{code} \begin{code} @@ -57,11 +59,19 @@ instance RandomGen StdGen where next = stdNext split = stdSplit +#ifdef __HUGS__ +instance Show StdGen where + showsPrec p (StdGen s1 s2) = + showsPrec p s1 . + showChar ' ' . + showsPrec p s2 +#else instance Show StdGen where showsPrec p (StdGen s1 s2) = showSignedInt p s1 . showSpace . showSignedInt p s2 +#endif instance Read StdGen where readsPrec _p = \ r -> @@ -157,19 +167,31 @@ instance Random Double where random g = randomR (0::Double,1) g -- hah, so you thought you were saving cycles by using Float? + +#ifdef __HUGS__ +instance Random Float where + random g = randomIvalDouble (0::Double,1) realToFrac g + randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g +#else instance Random Float where randomR (a,b) g = randomIvalDouble (float2Double a, float2Double b) double2Float g random g = randomIvalDouble (0::Double,1) double2Float g +#endif \end{code} \begin{code} +#ifdef __HUGS__ +mkStdRNG :: Integer -> IO StdGen +mkStdRNG o = return (createStdGen o) +#else mkStdRNG :: Integer -> IO StdGen mkStdRNG o = do ct <- getCPUTime (TOD sec _) <- getClockTime return (createStdGen (sec * 12345 + ct + o)) +#endif randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) randomIvalInteger (l,h) rng @@ -220,13 +242,39 @@ stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'') s2' = 40692 * (s2 - k' * 52774) - k' * 3791 s2'' = if s2' < 0 then s2' + 2147483399 else s2' +#ifdef __HUGS__ +stdSplit :: StdGen -> (StdGen, StdGen) +stdSplit std@(StdGen s1 s2) + = (left, right) + where + -- no statistical foundation for this! + left = StdGen new_s1 t2 + right = StdGen t1 new_s2 + + new_s1 | s1 == 2147483562 = 1 + | otherwise = s1 + 1 + + new_s2 | s2 == 1 = 2147483398 + | otherwise = s2 - 1 + + StdGen t1 t2 = snd (next std) +#else stdSplit :: StdGen -> (StdGen, StdGen) stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1))) - +#endif \end{code} \begin{code} +#ifdef __HUGS__ +-- TODO: Hugs/setStdGen +setStdGen :: StdGen -> IO () +setStdGen sgen = error "not currently implemented in Stg Hugs" + +-- TODO: Hugs/getStdGen +getStdGen :: IO StdGen +getStdGen = error "not currently implemented in Stg Hugs" +#else global_rng :: MutableVar RealWorld StdGen global_rng = unsafePerformIO $ do rng <- mkStdRNG 0 @@ -237,6 +285,8 @@ setStdGen sgen = stToIO (writeVar global_rng sgen) getStdGen :: IO StdGen getStdGen = stToIO (readVar global_rng) +#endif + newStdGen :: IO StdGen newStdGen = do diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs index 7c8107f..a002888 100644 --- a/ghc/lib/std/Ratio.lhs +++ b/ghc/lib/std/Ratio.lhs @@ -32,6 +32,8 @@ module Ratio ) where +#ifndef __HUGS__ import PrelNum import PrelNumExtra +#endif \end{code} diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index dee3c3d..0080df6 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -16,15 +16,11 @@ module System , exitWith -- :: ExitCode -> IO a , exitFailure -- :: IO a ) where +\end{code} -#ifdef __HUGS__ -import PreludeBuiltin - -indexAddrOffAddr = primIndexAddrOffAddr - -unpackCString = unsafeUnpackCString -#else +#ifndef __HUGS__ +\begin{code} import Prelude import PrelAddr import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) @@ -38,7 +34,6 @@ primUnpackCString s = stToIO ( unpackCStringST s ) primPackString :: String -> PrimByteArray primPackString s = packString s -#endif \end{code} @@ -180,3 +175,51 @@ unpackProgName argv de_slash _acc ('/':xs) = de_slash [] xs de_slash acc (x:xs) = de_slash (x:acc) xs \end{code} + +#else + +\begin{code} +----------------------------------------------------------------------------- +-- Standard Library: System operations +-- +-- Warning: the implementation of these functions in Hugs 98 is very weak. +-- The functions themselves are best suited to uses in compiled programs, +-- and not to use in an interpreter-based environment like Hugs. +-- +-- Suitable for use with Hugs 98 +----------------------------------------------------------------------------- + +data ExitCode = ExitSuccess | ExitFailure Int + deriving (Eq, Ord, Read, Show) + +getArgs :: IO [String] +getArgs = primGetRawArgs >>= \rawargs -> + return (drop 1 (dropWhile (/= "--") rawargs)) + +getProgName :: IO String +getProgName = primGetRawArgs >>= \rawargs -> + return (head rawargs) + +getEnv :: String -> IO String +getEnv = primGetEnv + +system :: String -> IO ExitCode +system s = error "System.system unimplemented" + +exitWith :: ExitCode -> IO a +exitWith c = error "System.exitWith unimplemented" + +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +toExitCode :: Int -> ExitCode +toExitCode 0 = ExitSuccess +toExitCode n = ExitFailure n + +fromExitCode :: ExitCode -> Int +fromExitCode ExitSuccess = 0 +fromExitCode (ExitFailure n) = n + +----------------------------------------------------------------------------- +\end{code} +#endif -- 1.7.10.4