[project @ 2001-11-14 11:35:23 by simonmar]

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

diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs
index d7cad52..51029da 100644 (file)
--- a/ghc/lib/std/System.lhs
+++ b/ghc/lib/std/System.lhs
@@ -1,10 +1,11 @@
 -- -----------------------------------------------------------------------------
--- $Id: System.lhs,v 1.30 2001/05/18 16:54:05 simonmar Exp $
+-- $Id: System.lhs,v 1.37 2001/11/08 16:36:39 simonmar Exp $
 --
 -- (c) The University of Glasgow, 1994-2000
 --
 
 \begin{code}
+#include "config.h"
 module System 
     ( 
       ExitCode(ExitSuccess,ExitFailure)
@@ -22,38 +23,40 @@ import PrelCError
 import PrelCString
 import PrelCTypes
 import PrelMarshalArray
+import PrelMarshalAlloc
 import PrelPtr
 import PrelStorable
-import PrelIOBase      ( IOException(..), ioException, IOErrorType(..))
-
--- -----------------------------------------------------------------------------
--- The ExitCode type
-
--- The `ExitCode' type defines the exit codes that a program
--- can return.  `ExitSuccess' indicates successful termination;
--- and `ExitFailure code' indicates program failure
--- with value `code'.  The exact interpretation of `code'
--- is operating-system dependent.  In particular, some values of 
--- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
-
-data ExitCode = ExitSuccess | ExitFailure Int 
-                deriving (Eq, Ord, Read, Show)
+import PrelIOBase
 
+-- ---------------------------------------------------------------------------
+-- getArgs, getProgName, getEnv
 
 -- Computation `getArgs' returns a list of the program's command
 -- line arguments (not including the program name).
 
 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
+getArgs = 
+  alloca $ \ p_argc ->  
+  alloca $ \ p_argv -> do
+   getProgArgv p_argc p_argv
+   p    <- fromIntegral `liftM` peek p_argc
+   argv <- peek p_argv
+   peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString
+   
+   
+foreign import "getProgArgv" unsafe 
+  getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
 
 -- Computation `getProgName' returns the name of the program
 -- as it was invoked.
 
 getProgName :: IO String
-getProgName = unpackProgName primArgv
+getProgName = 
+  alloca $ \ p_argc ->
+  alloca $ \ p_argv -> do
+     getProgArgv p_argc p_argv
+     argv <- peek p_argv
+     unpackProgName argv
 
 -- Computation `getEnv var' returns the value
 -- of the environment variable {\em var}.  
@@ -63,14 +66,14 @@ getProgName = unpackProgName primArgv
 
 getEnv :: String -> IO String
 getEnv name =
-    withUnsafeCString name $ \s -> do
+    withCString 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)
+foreign import ccall "getenv" unsafe _getenv :: CString -> IO (Ptr CChar)
 
 -- ---------------------------------------------------------------------------
 -- system
@@ -89,13 +92,13 @@ foreign import ccall "getenv" unsafe _getenv :: UnsafeCString -> IO (Ptr CChar)
 system :: String -> IO ExitCode
 system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
 system cmd =
-  withUnsafeCString cmd $ \s -> do
+  withCString cmd $ \s -> do
     status <- throwErrnoIfMinus1 "system" (primSystem s)
     case status of
         0  -> return ExitSuccess
         n  -> return (ExitFailure n)
 
-foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int
+foreign import ccall "systemCmd" unsafe primSystem :: CString -> IO Int
 
 -- ---------------------------------------------------------------------------
 -- exitWith
@@ -105,19 +108,10 @@ foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int
 -- handles are first closed.
 
 exitWith :: ExitCode -> IO a
-exitWith ExitSuccess = do
-    primExit 0
-    ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing)
-
-exitWith (ExitFailure n) 
+exitWith ExitSuccess = throw (ExitException ExitSuccess)
+exitWith code@(ExitFailure n) 
   | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
-  | otherwise = do
-    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 ()
+  | otherwise = throw (ExitException code)
 
 exitFailure :: IO a
 exitFailure = exitWith (ExitFailure 1)
@@ -125,19 +119,24 @@ exitFailure = exitWith (ExitFailure 1)
 -- ---------------------------------------------------------------------------
 -- Local utilities
 
-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)
+  return (basename 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
+   basename :: String -> String
+   basename f = go f f
+    where
+      go acc [] = acc
+      go acc (x:xs) 
+        | isPathSeparator x = go xs xs
+        | otherwise         = go acc xs
+
+   isPathSeparator :: Char -> Bool
+   isPathSeparator '/'  = True
+#ifdef mingw32_TARGET_OS 
+   isPathSeparator '\\' = True
+#endif
+   isPathSeparator _    = False
 
 \end{code}