[project @ 2001-01-11 17:51:02 by simonmar]
[ghc-hetmet.git] / ghc / lib / std / System.lhs
index 192fa29..26dd948 100644 (file)
@@ -1,20 +1,35 @@
+% -----------------------------------------------------------------------------
+% $Id: System.lhs,v 1.29 2001/01/11 17:51:02 simonmar Exp $
 %
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The University of Glasgow, 1994-2000
 %
 
 \section[System]{Module @System@}
 
 \begin{code}
-module System ( 
-    ExitCode(ExitSuccess,ExitFailure),
-    getArgs, getProgName, getEnv, system, exitWith
+{-# OPTIONS -#include "cbits/stgio.h" #-}
+module System 
+    ( 
+      ExitCode(ExitSuccess,ExitFailure)
+    , getArgs      -- :: IO [String]
+    , getProgName   -- :: IO String
+    , getEnv        -- :: String -> IO String
+    , system        -- :: String -> IO ExitCode
+    , exitWith      -- :: ExitCode -> IO a
+    , exitFailure   -- :: IO a
   ) where
+\end{code}
 
+\begin{code}
+import Monad
 import Prelude
-import PrelAddr
-import PrelIOBase      ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo )
-import PrelPack        ( unpackCString )
-
+import PrelCString
+import PrelCTypes
+import PrelMarshalArray
+import PrelPtr
+import PrelStorable
+import PrelIOBase      ( IOException(..), ioException, 
+                         IOErrorType(..), constructErrorAndFailWithInfo )
 \end{code}
 
 %*********************************************************
@@ -36,33 +51,23 @@ data ExitCode = ExitSuccess | ExitFailure Int
 
 \end{code}
 
-
-%*********************************************************
-%*                                                     *
-\subsection{Other functions}
-%*                                                     *
-%*********************************************************
-
-\begin{code}
-getArgs                :: IO [String]
-getProgName            :: IO String
-getEnv                 :: String -> IO String
-system                 :: String -> IO ExitCode
-exitWith               :: ExitCode -> IO a
-\end{code}
-
 Computation $getArgs$ returns a list of the program's command
 line arguments (not including the program name).
 
 \begin{code}
-getArgs = return (unpackArgv ``prog_argv'' (``prog_argc''::Int))
+getArgs :: IO [String]
+getArgs = unpackArgv primArgv primArgc
+
+foreign import ccall "get_prog_argv" unsafe   primArgv :: Ptr (Ptr CChar)
+foreign import ccall "get_prog_argc" unsafe   primArgc :: Int
 \end{code}
 
 Computation $getProgName$ returns the name of the program
 as it was invoked.
 
 \begin{code}
-getProgName = return (unpackProgName ``prog_argv'')
+getProgName :: IO String
+getProgName = unpackProgName primArgv
 \end{code}
 
 Computation $getEnv var$ returns the value
@@ -75,12 +80,16 @@ The environment variable does not exist.
 \end{itemize}
 
 \begin{code}
-getEnv name = do
-    litstring <- _ccall_ getenv name
-    if litstring /= ``NULL'' 
-       then return (unpackCString litstring)
-        else fail (IOError Nothing NoSuchThing 
-                       ("environment variable: " ++ name))
+getEnv :: String -> IO String
+getEnv name =
+    withUnsafeCString name $ \s -> do
+      litstring <- _getenv s
+      if litstring /= nullPtr
+       then peekCString litstring
+        else ioException (IOError Nothing NoSuchThing "getEnv"
+                         "no environment variable" (Just name))
+
+foreign import ccall "getenv" unsafe _getenv :: UnsafeCString -> IO (Ptr CChar)
 \end{code}
 
 Computation $system cmd$ returns the exit code
@@ -97,30 +106,40 @@ The implementation does not support system calls.
 \end{itemize}
 
 \begin{code}
-system "" = fail (IOError Nothing InvalidArgument "null command")
-system cmd = do
-    status <- _ccall_ systemCmd cmd
+system                 :: String -> IO ExitCode
+system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
+system cmd =
+  withUnsafeCString cmd $ \s -> do
+    status <- primSystem s
     case status of
         0  -> return ExitSuccess
         -1 -> constructErrorAndFailWithInfo "system" cmd
         n  -> return (ExitFailure n)
 
+foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int
 \end{code}
 
-Computation $exitWith code$ terminates the
-program, returning {\em code} to the program's caller.
+@exitWith code@ terminates the program, returning {\em code} to the program's caller.
 Before it terminates, any open or semi-closed handles are first closed.
 
 \begin{code}
+exitWith               :: ExitCode -> IO a
 exitWith ExitSuccess = do
-    _ccall_ EXIT (0::Int)
-    fail (IOError Nothing OtherError "exit should not return")
+    primExit 0
+    ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
 
 exitWith (ExitFailure n) 
-  | n == 0 = fail (IOError Nothing InvalidArgument "ExitFailure 0")
+  | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
   | otherwise = do
-    _ccall_ EXIT n
-    fail (IOError Nothing OtherError "exit should not return")
+    primExit n
+    ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
+
+-- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
+-- re-enter Haskell land through finalizers.
+foreign import ccall "shutdownHaskellAndExit" primExit :: Int -> IO ()
+
+exitFailure :: IO a
+exitFailure = exitWith (ExitFailure 1)
 \end{code}
 
 
@@ -131,28 +150,18 @@ exitWith (ExitFailure n)
 %*********************************************************
 
 \begin{code}
-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 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) }
-
-unpackProgName argv
-  = case (indexAddrOffAddr argv 0) of { prog ->
-    de_slash [] (unpackCString prog) }
+unpackArgv :: Ptr (Ptr CChar) -> Int -> IO [String] -- argv[1 .. argc-1]
+unpackArgv argv argc
+  = peekArray (argc-1) (advancePtr argv 1) >>= mapM peekCString
+
+unpackProgName :: Ptr (Ptr CChar) -> IO String   -- argv[0]
+unpackProgName argv = do 
+  s <- peekElemOff argv 0 >>= peekCString
+  return (de_slash "" s)
   where
     -- re-start accumulating at every '/'
     de_slash :: String -> String -> String
-    de_slash acc []      = reverse acc
-    de_slash acc ('/':xs) = de_slash []             xs
-    de_slash acc (x:xs)          = de_slash (x:acc) xs
+    de_slash  acc []      = reverse acc
+    de_slash _acc ('/':xs) = de_slash []      xs
+    de_slash  acc (x:xs)   = de_slash (x:acc) xs
 \end{code}