-%
-% (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)
, 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}
projects / ghc-hetmet.git / blobdiff