From df75591ba46f1350b70ef145624222f583b3f448 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 22 May 2001 15:06:47 +0000 Subject: [PATCH] [project @ 2001-05-22 15:06:47 by simonmar] - System.exitWith now raises a (new) exception, ExitException ExitCode. - While I was there I cleaned up System.getArgs and System.getProgName, using foriegn label and removing progargs.c --- ghc/lib/std/PrelIO.hsc | 18 ++++++++++++-- ghc/lib/std/PrelIOBase.lhs | 26 +++++++++++++++++--- ghc/lib/std/PrelTopHandler.lhs | 12 ++++++++- ghc/lib/std/System.lhs | 53 +++++++++++++--------------------------- ghc/lib/std/cbits/progargs.c | 22 ----------------- 5 files changed, 66 insertions(+), 65 deletions(-) delete mode 100644 ghc/lib/std/cbits/progargs.c diff --git a/ghc/lib/std/PrelIO.hsc b/ghc/lib/std/PrelIO.hsc index 4eeaad1..90c8b80 100644 --- a/ghc/lib/std/PrelIO.hsc +++ b/ghc/lib/std/PrelIO.hsc @@ -3,7 +3,7 @@ #undef DEBUG_DUMP -- ----------------------------------------------------------------------------- --- $Id: PrelIO.hsc,v 1.2 2001/05/21 14:05:04 simonmar Exp $ +-- $Id: PrelIO.hsc,v 1.3 2001/05/22 15:06:47 simonmar Exp $ -- -- (c) The University of Glasgow, 1992-2001 -- @@ -36,7 +36,7 @@ import PrelHandle -- much of the real stuff is in here import PrelMaybe import PrelReal import PrelNum -import PrelRead ( Read(..), readIO ) +import PrelRead import PrelShow import PrelMaybe ( Maybe(..) ) import PrelPtr @@ -93,6 +93,20 @@ readLn = do l <- getLine r <- readIO l return r + -- raises an exception instead of an error +readIO :: Read a => String -> IO a +readIO s = case (do { (x,t) <- reads s ; + ("","") <- lex t ; + return x }) of +#ifndef NEW_READS_REP + [x] -> return x + [] -> ioError (userError "Prelude.readIO: no parse") + _ -> ioError (userError "Prelude.readIO: ambiguous parse") +#else + Just x -> return x + Nothing -> ioError (userError "Prelude.readIO: no parse") +#endif + -- --------------------------------------------------------------------------- -- Simple input operations diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 3b3a17d..918d3ed 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.38 2001/05/18 16:54:05 simonmar Exp $ +% $Id: PrelIOBase.lhs,v 1.39 2001/05/22 15:06:47 simonmar Exp $ % % (c) The University of Glasgow, 1994-2001 % @@ -14,6 +14,7 @@ module PrelIOBase where import PrelST +import PrelRead import PrelArr import PrelBase import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude @@ -217,7 +218,7 @@ bufferIsWritable Buffer{ bufState=WriteBuffer } = True bufferIsWritable _other = False bufferEmpty :: Buffer -> Bool -bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } | r == w = True +bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w bufferEmpty _other = False -- only makes sense for a write buffer @@ -283,8 +284,7 @@ type FilePath = String data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Show) - {- Read instance defined in IO. -} + deriving (Eq, Ord, Show, Read) -- --------------------------------------------------------------------------- -- IORefs @@ -370,6 +370,7 @@ data Exception | ArithException ArithException -- Arithmetic exceptions | ArrayException ArrayException -- Array-related exceptions | ErrorCall String -- Calls to 'error' + | ExitException ExitCode -- Call to System.exitWith | NoMethodError String -- A non-existent method was invoked | PatternMatchFail String -- A pattern match / guard failure | RecSelError String -- Selecting a non-existent field @@ -432,6 +433,7 @@ instance Show Exception where showsPrec _ (ArithException err) = shows err showsPrec _ (ArrayException err) = shows err showsPrec _ (ErrorCall err) = showString err + showsPrec _ (ExitException err) = showString "exit: " . shows err showsPrec _ (NoMethodError err) = showString err showsPrec _ (PatternMatchFail err) = showString err showsPrec _ (RecSelError err) = showString err @@ -444,6 +446,22 @@ instance Show Exception where showsPrec _ (NonTermination) = showString "<>" showsPrec _ (UserError err) = showString err +-- ----------------------------------------------------------------------------- +-- 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). + +-- We need it here because it is used in ExitException in the +-- Exception datatype (above). + +data ExitCode = ExitSuccess | ExitFailure Int + deriving (Eq, Ord, Read, Show) + -- -------------------------------------------------------------------------- -- Primitive throw diff --git a/ghc/lib/std/PrelTopHandler.lhs b/ghc/lib/std/PrelTopHandler.lhs index ad0f9af..2e7bf2c 100644 --- a/ghc/lib/std/PrelTopHandler.lhs +++ b/ghc/lib/std/PrelTopHandler.lhs @@ -1,5 +1,5 @@ -- ----------------------------------------------------------------------------- --- $Id: PrelTopHandler.lhs,v 1.1 2001/05/21 14:07:31 simonmar Exp $ +-- $Id: PrelTopHandler.lhs,v 1.2 2001/05/22 15:06:47 simonmar Exp $ -- -- (c) The University of Glasgow, 2001 -- @@ -36,9 +36,19 @@ real_handler :: Exception -> IO () real_handler ex = case ex of AsyncException StackOverflow -> reportStackOverflow True + + -- only the main thread gets ExitException exceptions + ExitException ExitSuccess -> shutdownHaskellAndExit 0 + ExitException (ExitFailure n) -> shutdownHaskellAndExit n + ErrorCall s -> reportError True s other -> reportError True (showsPrec 0 other "\n") +-- NOTE: shutdownHaskellAndExit must be called "safe", because it *can* +-- re-enter Haskell land through finalizers. +foreign import ccall "shutdownHaskellAndExit" + shutdownHaskellAndExit :: Int -> IO () + reportStackOverflow :: Bool -> IO () reportStackOverflow bombOut = do (hFlush stdout) `catchException` (\ _ -> return ()) diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index d7cad52..602bc99 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -1,5 +1,5 @@ -- ----------------------------------------------------------------------------- --- $Id: System.lhs,v 1.30 2001/05/18 16:54:05 simonmar Exp $ +-- $Id: System.lhs,v 1.31 2001/05/22 15:06:47 simonmar Exp $ -- -- (c) The University of Glasgow, 1994-2000 -- @@ -24,36 +24,31 @@ import PrelCTypes import PrelMarshalArray 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 +import PrelConc +-- --------------------------------------------------------------------------- +-- 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 +getArgs = do + argv <- peek prog_argv_label + argc <- peek prog_argc_label + peekArray (fromIntegral argc - 1) (advancePtr argv 1) >>= mapM peekCString -foreign import ccall "get_prog_argv" unsafe primArgv :: Ptr (Ptr CChar) -foreign import ccall "get_prog_argc" unsafe primArgc :: Int +foreign label "prog_argv" prog_argv_label :: Ptr (Ptr (Ptr CChar)) +foreign label "prog_argc" prog_argc_label :: Ptr CInt -- Computation `getProgName' returns the name of the program -- as it was invoked. getProgName :: IO String -getProgName = unpackProgName primArgv +getProgName = do + argv <- peek prog_argv_label + unpackProgName argv -- Computation `getEnv var' returns the value -- of the environment variable {\em var}. @@ -105,19 +100,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,10 +111,6 @@ 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 @@ -139,5 +121,4 @@ unpackProgName argv = do de_slash acc [] = reverse acc de_slash _acc ('/':xs) = de_slash [] xs de_slash acc (x:xs) = de_slash (x:acc) xs - \end{code} diff --git a/ghc/lib/std/cbits/progargs.c b/ghc/lib/std/cbits/progargs.c deleted file mode 100644 index 080b07a..0000000 --- a/ghc/lib/std/cbits/progargs.c +++ /dev/null @@ -1,22 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: progargs.c,v 1.5 2001/05/18 16:54:06 simonmar Exp $ - * - * System.getArgs Runtime Support - */ - -#include "Rts.h" - -HsAddr -get_prog_argv(void) -{ - return prog_argv; -} - -HsInt -get_prog_argc() -{ - return prog_argc; -} - -- 1.7.10.4