X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FSystem.lhs;h=26dd948856a6805c5c5694820f32a4058312dbb5;hb=6170d17e7f78171abf7aec1b2b40a7d9c4f6e508;hp=f09a617f15e5812fbd4c39ccc743f7d95cca43de;hpb=2455da3a4d8f50e6eb6d033dcfda2c8467bfd8cd;p=ghc-hetmet.git diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index f09a617..26dd948 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -1,5 +1,7 @@ +% ----------------------------------------------------------------------------- +% $Id: System.lhs,v 1.29 2001/01/11 17:51:02 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1999 +% (c) The University of Glasgow, 1994-2000 % \section[System]{Module @System@} @@ -16,30 +18,18 @@ module System , exitWith -- :: ExitCode -> IO a , exitFailure -- :: IO a ) where +\end{code} -#ifdef __HUGS__ -import PreludeBuiltin - -indexAddrOffAddr = primIndexAddrOffAddr - -unpackCString = unsafeUnpackCString - -#else +\begin{code} +import Monad import Prelude -import PrelAddr -import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) -import PrelPack ( unpackCString, unpackCStringST, packString ) -import PrelArr ( ByteArray ) - -type PrimByteArray = ByteArray Int - -primUnpackCString :: Addr -> IO String -primUnpackCString s = stToIO ( unpackCStringST s ) - -primPackString :: String -> PrimByteArray -primPackString s = packString s -#endif - +import PrelCString +import PrelCTypes +import PrelMarshalArray +import PrelPtr +import PrelStorable +import PrelIOBase ( IOException(..), ioException, + IOErrorType(..), constructErrorAndFailWithInfo ) \end{code} %********************************************************* @@ -65,19 +55,19 @@ Computation $getArgs$ returns a list of the program's command line arguments (not including the program name). \begin{code} -getArgs :: IO [String] -getArgs = return (unpackArgv primArgv primArgc) +getArgs :: IO [String] +getArgs = unpackArgv primArgv primArgc -foreign import ccall "libHS_cbits.so" "get_prog_argv" unsafe primArgv :: Addr -foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int +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 :: IO String -getProgName = return (unpackProgName primArgv) +getProgName :: IO String +getProgName = unpackProgName primArgv \end{code} Computation $getEnv var$ returns the value @@ -90,15 +80,16 @@ The environment variable does not exist. \end{itemize} \begin{code} -getEnv :: String -> IO String -getEnv name = do - litstring <- primGetEnv (primPackString name) - if litstring /= nullAddr - then primUnpackCString litstring - else ioError (IOError Nothing NoSuchThing "getEnv" - ("environment variable: " ++ name)) - -foreign import ccall "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr +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 @@ -116,15 +107,16 @@ The implementation does not support system calls. \begin{code} system :: String -> IO ExitCode -system "" = ioError (IOError Nothing InvalidArgument "system" "null command") -system cmd = do - status <- primSystem (primPackString cmd) +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 "libHS_cbits.so" "systemCmd" unsafe primSystem :: PrimByteArray -> IO Int +foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int \end{code} @exitWith code@ terminates the program, returning {\em code} to the program's caller. @@ -134,14 +126,16 @@ Before it terminates, any open or semi-closed handles are first closed. exitWith :: ExitCode -> IO a exitWith ExitSuccess = do primExit 0 - ioError (IOError Nothing OtherError "exitWith" "exit should not return") + ioException (IOError Nothing OtherError "exitWith" "exit should not return" Nothing) exitWith (ExitFailure n) - | n == 0 = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") + | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) | otherwise = do primExit n - ioError (IOError Nothing OtherError "exitWith" "exit should not return") + 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 @@ -156,24 +150,14 @@ exitFailure = exitWith (ExitFailure 1) %********************************************************* \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