[project @ 2000-01-10 16:23:32 by sewardj]

[ghc-hetmet.git] / ghc / lib / hugs / Prelude.hs

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 33145a9..ce05049 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -119,7 +119,7 @@ module Prelude (
     ,unsafeInterleaveIO,nh_write,primCharToInt,
     nullAddr, incAddr, isNullAddr, 
     nh_filesize, nh_iseof, nh_system, nh_exitwith, nh_getPID,
-    nh_getCPUtime, nh_getCPUprec,
+    nh_getCPUtime, nh_getCPUprec, prelCleanupAfterRunAction,
 
     Word,
     primGtWord, primGeWord, primEqWord, primNeWord,
@@ -135,11 +135,7 @@ module Prelude (
     primAddrToInt, primIntToAddr,
 
     primDoubleToFloat, primFloatToDouble,
-    -- debugging hacks
-    --,ST(..)
-    --,primIntToAddr
-    --,primGetArgc
-    --,primGetArgv
+
   ) where
 
 -- Standard value bindings {Prelude} ----------------------------------------
@@ -374,7 +370,9 @@ class Enum a where
     -- Minimal complete definition: toEnum, fromEnum
     succ                  = toEnum . (1+)       . fromEnum
     pred                  = toEnum . subtract 1 . fromEnum
+    enumFrom x            = map toEnum [ fromEnum x .. ]
     enumFromTo x y        = map toEnum [ fromEnum x .. fromEnum y ]
+    enumFromThen x y      = map toEnum [ fromEnum x, fromEnum y .. ]
     enumFromThenTo x y z  = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
 
 -- Read and Show classes ------------------------------------------------------
@@ -1550,11 +1548,11 @@ readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
 primCompAux      :: Ord a => a -> a -> Ordering -> Ordering
 primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
 
-primPmInt        :: Num a => Int -> a -> Bool
-primPmInt n x     = fromInt n == x
+hugsprimPmInt        :: Num a => Int -> a -> Bool
+hugsprimPmInt n x     = fromInt n == x
 
-primPmInteger    :: Num a => Integer -> a -> Bool
-primPmInteger n x = fromInteger n == x
+hugsprimPmInteger    :: Num a => Integer -> a -> Bool
+hugsprimPmInteger n x = fromInteger n == x
 
 primPmDouble     :: Fractional a => Double -> a -> Bool
 primPmDouble n x  = fromDouble n == x
@@ -1564,23 +1562,28 @@ primPmFail       :: a
 primPmFail        = error "Pattern Match Failure"
 
 -- used in desugaring Foreign functions
-primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-primMkIO = ST
+hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+hugsprimMkIO = ST
 
-primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
-primCreateAdjThunk fun typestr callconv
+hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
+hugsprimCreateAdjThunk fun typestr callconv
    = do sp <- makeStablePtr fun
         p  <- copy_String_to_cstring typestr  -- is never freed
         a  <- primCreateAdjThunkARCH sp p callconv
         return a
 
 -- The following primitives are only needed if (n+k) patterns are enabled:
-primPmNpk        :: Integral a => Int -> a -> Maybe a
-primPmNpk n x     = if n'<=x then Just (x-n') else Nothing
-                   where n' = fromInt n
+hugsprimPmSub           :: Integral a => Int -> a -> a
+hugsprimPmSub n x        = x - fromInt n
+
+hugsprimPmFromInteger   :: Integral a => Integer -> a
+hugsprimPmFromInteger    = fromIntegral
+
+hugsprimPmSubtract      :: Integral a => a -> a -> a
+hugsprimPmSubtract x y   = x - y
 
-primPmSub        :: Integral a => Int -> a -> a
-primPmSub n x     = x - fromInt n
+hugsprimPmLe            :: Integral a => a -> a -> Bool
+hugsprimPmLe x y         = x <= y
 
 -- Unpack strings generated by the Hugs code generator.
 -- Strings can contain \0 provided they're coded right.
@@ -1810,7 +1813,6 @@ newtype ST s a = ST (s -> (a,s))
 data RealWorld
 type IO a = ST RealWorld a
 
-
 --primRunST :: (forall s. ST s a) -> a
 primRunST :: ST RealWorld a -> a
 primRunST m = fst (unST m theWorld)
@@ -1829,11 +1831,29 @@ instance Monad (ST s) where
    m >>= k   = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
 
 
+-- Library IO has a global variable which accumulates Handles
+-- as they are opened.  We keep here a second global variable
+-- into which a cleanup action may be specified.  When evaluation
+-- finishes, either normally or as a result of System.exitWith,
+-- this cleanup action is run, closing all known-about Handles.
+-- Doing it like this means the Prelude does not have to know
+-- anything about the grotty details of the Handle implementation.
+prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
+prelCleanupAfterRunAction = primRunST (newIORef Nothing)
+
 -- used when Hugs invokes top level function
-primRunIO :: IO () -> ()
-primRunIO m
-   = protect 5 (fst (unST m realWorld))
+hugsprimRunIO_toplevel :: IO a -> ()
+hugsprimRunIO_toplevel m
+   = protect 5 (fst (unST composite_action realWorld))
      where
+        composite_action
+           = do writeIORef prelCleanupAfterRunAction Nothing
+                m 
+                cleanup_handles <- readIORef prelCleanupAfterRunAction
+                case cleanup_handles of
+                   Nothing -> return ()
+                   Just xx -> xx
+
         realWorld = error "primRunIO: entered the RealWorld"
         protect :: Int -> () -> ()
         protect 0 comp