[project @ 2000-04-10 14:28:14 by sewardj]

[ghc-hetmet.git] / ghc / lib / std / System.lhs

diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs
index f94ee48..0404492 100644 (file)
--- a/ghc/lib/std/System.lhs
+++ b/ghc/lib/std/System.lhs
@@ -16,20 +16,16 @@ 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 )
 import PrelPack        ( unpackCString, unpackCStringST, packString )
-import PrelArr         ( ByteArray )
+import PrelByteArr     ( ByteArray )
 
 type PrimByteArray  = ByteArray Int
 
@@ -38,7 +34,6 @@ primUnpackCString s = stToIO ( unpackCStringST s )
 
 primPackString :: String -> PrimByteArray
 primPackString s    = packString s
-#endif
 
 \end{code}
 
@@ -98,7 +93,7 @@ getEnv name = do
         else ioError (IOError Nothing NoSuchThing "getEnv"
                        ("environment variable: " ++ name))
 
-foreign import ccall "libHS_cbits.so" "getenv" primGetEnv :: PrimByteArray -> IO Addr
+foreign import ccall "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr
 \end{code}
 
 Computation $system cmd$ returns the exit code
@@ -124,7 +119,7 @@ system cmd = do
         -1 -> constructErrorAndFailWithInfo "system" cmd
         n  -> return (ExitFailure n)
 
-foreign import ccall "libHS_cbits.so" "systemCmd" primSystem :: PrimByteArray -> IO Int
+foreign import ccall "libHS_cbits.so" "systemCmd" unsafe primSystem :: PrimByteArray -> IO Int
 \end{code}
 
 @exitWith code@ terminates the program, returning {\em code} to the program's caller.
@@ -142,7 +137,7 @@ exitWith (ExitFailure n)
     primExit n
     ioError (IOError Nothing OtherError "exitWith" "exit should not return")
 
-foreign import ccall "libHS_cbits.so" "exit" primExit :: Int -> IO ()
+foreign import ccall "shutdownHaskellAndExit" primExit :: Int -> IO ()
 
 exitFailure :: IO a
 exitFailure = exitWith (ExitFailure 1)
@@ -159,18 +154,17 @@ exitFailure = exitWith (ExitFailure 1)
 type CHAR_STAR_STAR    = Addr  -- this is all a  HACK
 type CHAR_STAR         = Addr
 
-unpackArgv     :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
-unpackProgName :: CHAR_STAR_STAR        -> String   -- argv[0]
-
+unpackArgv :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
 unpackArgv argv argc = unpack 1
   where
-    unpack :: Int -> [String]
-    unpack n
-      = if (n >= argc)
-       then ([] :: [String])
-       else case (indexAddrOffAddr argv n) of { item ->
-            unpackCString item : unpack (n + 1) }
+   unpack :: Int -> [String]
+   unpack n
+     | n >= argc = []
+     | otherwise =
+        case (indexAddrOffAddr argv n) of 
+          item -> unpackCString item : unpack (n + 1)
 
+unpackProgName :: CHAR_STAR_STAR        -> String   -- argv[0]
 unpackProgName argv
   = case (indexAddrOffAddr argv 0) of { prog ->
     de_slash [] (unpackCString prog) }
@@ -181,3 +175,90 @@ 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
+-----------------------------------------------------------------------------
+import PrelPrim ( primGetRawArgs
+               , primGetEnv
+               , prelCleanupAfterRunAction
+               , copy_String_to_cstring
+               , readIORef
+               , nh_stderr
+               , nh_stdout
+               , nh_stdin 
+               , nh_exitwith 
+               , nh_flush
+               , nh_close
+               , nh_system
+               , nh_free
+               , nh_getPID
+               )
+
+
+data ExitCode = ExitSuccess | ExitFailure Int
+                deriving (Eq, Ord, Read, Show)
+
+getArgs                     :: IO [String]
+getArgs                      = primGetRawArgs >>= \rawargs ->
+                               return (tail rawargs)
+
+getProgName                 :: IO String
+getProgName                  = primGetRawArgs >>= \rawargs ->
+                               return (head rawargs)
+
+getEnv                      :: String -> IO String
+getEnv                       = primGetEnv
+
+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
+
+-- see comment in Prelude.hs near primRunIO_hugs_toplevel
+exitWith :: ExitCode -> IO a
+exitWith c
+   = do cleanup_action <- readIORef prelCleanupAfterRunAction
+        case cleanup_action of
+           Just xx -> xx
+           Nothing -> return ()
+        nh_stderr >>= nh_flush
+        nh_stdout >>= nh_flush
+        nh_stdin  >>= nh_close
+        nh_exitwith (fromExitCode c)
+        (ioError.IOError) "System.exitWith: should not return"
+
+system :: String -> IO ExitCode
+system cmd
+   | null cmd
+   = (ioError.IOError) "System.system: null command"
+   | otherwise
+   = do str    <- copy_String_to_cstring cmd
+        status <- nh_system str
+        nh_free str
+        case status of
+           0  -> return ExitSuccess
+           n  -> return (ExitFailure n)
+
+getPID :: IO Int
+getPID
+   = nh_getPID
+
+-----------------------------------------------------------------------------
+\end{code}
+#endif