X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FSystem.lhs;h=51029daf1b336878f19999b1dfa97847fc9437cc;hb=239e9471e104fd88ec93bf42623c3a68a496657a;hp=dee3c3df1463db2538a203600913db369ce4c4e8;hpb=ff99f2d33f3ea3d90f9739566f1e049a8bb851e8;p=ghc-hetmet.git diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index dee3c3d..51029da 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -1,11 +1,11 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1999 -% - -\section[System]{Module @System@} +-- ----------------------------------------------------------------------------- +-- $Id: System.lhs,v 1.37 2001/11/08 16:36:39 simonmar Exp $ +-- +-- (c) The University of Glasgow, 1994-2000 +-- \begin{code} -{-# OPTIONS -#include "cbits/stgio.h" #-} +#include "config.h" module System ( ExitCode(ExitSuccess,ExitFailure) @@ -17,166 +17,126 @@ module System , exitFailure -- :: IO a ) where -#ifdef __HUGS__ -import PreludeBuiltin - -indexAddrOffAddr = primIndexAddrOffAddr - -unpackCString = unsafeUnpackCString - -#else +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 - -\end{code} - -%********************************************************* -%* * -\subsection{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 {\em code}. The exact interpretation of {\em code} -is operating-system dependent. In particular, some values of -{\em code} may be prohibited (e.g. 0 on a POSIX-compliant system). - -\begin{code} -data ExitCode = ExitSuccess | ExitFailure Int - deriving (Eq, Ord, Read, Show) - -\end{code} - -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) - -foreign import ccall "libHS_cbits.so" "get_prog_argv" unsafe primArgv :: Addr -foreign import ccall "libHS_cbits.so" "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) -\end{code} - -Computation $getEnv var$ returns the value -of the environment variable {\em var}. - -This computation may fail with -\begin{itemize} -\item $NoSuchThing$ -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 -\end{code} - -Computation $system cmd$ returns the exit code -produced when the operating system processes the command {\em cmd}. - -This computation may fail with -\begin{itemize} -\item $PermissionDenied$ -The process has insufficient privileges to perform the operation. -\item $ResourceExhausted$ -Insufficient resources are available to perform the operation. -\item $UnsupportedOperation$ -The implementation does not support system calls. -\end{itemize} - -\begin{code} -system :: String -> IO ExitCode -system "" = ioError (IOError Nothing InvalidArgument "system" "null command") -system cmd = do - status <- primSystem (primPackString cmd) +import PrelCError +import PrelCString +import PrelCTypes +import PrelMarshalArray +import PrelMarshalAlloc +import PrelPtr +import PrelStorable +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 = + 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 = + 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}. + +-- This computation may fail with +-- NoSuchThing: The environment variable does not exist. + +getEnv :: String -> IO String +getEnv name = + 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 :: CString -> IO (Ptr CChar) + +-- --------------------------------------------------------------------------- +-- system + +-- Computation `system cmd' returns the exit code +-- produced when the operating system processes the command {\em cmd}. + +-- This computation may fail with +-- PermissionDenied +-- The process has insufficient privileges to perform the operation. +-- ResourceExhausted +-- Insufficient resources are available to perform the operation. +-- UnsupportedOperation +-- The implementation does not support system calls. + +system :: String -> IO ExitCode +system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing) +system cmd = + withCString cmd $ \s -> do + status <- throwErrnoIfMinus1 "system" (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 -\end{code} - -@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. +foreign import ccall "systemCmd" unsafe primSystem :: CString -> IO Int -\begin{code} -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = do - primExit 0 - ioError (IOError Nothing OtherError "exitWith" "exit should not return") +-- --------------------------------------------------------------------------- +-- exitWith -exitWith (ExitFailure n) - | n == 0 = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") - | otherwise = do - primExit n - ioError (IOError Nothing OtherError "exitWith" "exit should not return") +-- `exitWith code' terminates the program, returning `code' to the +-- program's caller. Before it terminates, any open or semi-closed +-- handles are first closed. -foreign import ccall "shutdownHaskellAndExit" primExit :: Int -> IO () +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throw (ExitException ExitSuccess) +exitWith code@(ExitFailure n) + | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) + | otherwise = throw (ExitException code) exitFailure :: IO a exitFailure = exitWith (ExitFailure 1) -\end{code} - -%********************************************************* -%* * -\subsection{Local utilities} -%* * -%********************************************************* +-- --------------------------------------------------------------------------- +-- Local utilities -\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] -unpackArgv argv argc = unpack 1 - where - 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) } +unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] +unpackProgName argv = do + s <- peekElemOff argv 0 >>= peekCString + 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}