ref: 1e5a13f417d66bbd84ad4f774a58f01ef213c939
parent: 6320170900cd1aca6ac9c4d9bc99287eb3f173ca
author: Lennart Augustsson <lennart@augustsson.net>
date: Tue Apr 2 08:13:24 EDT 2024
Lots of changes to use real exceptions. More to some.
--- a/ghc/Control/Exn.hs
+++ /dev/null
@@ -1,9 +1,0 @@
-module Control.Exn(Exn, exnToString) where
-import Control.Exception
-
-type Exn = SomeException
-
-exnToString :: Exn -> String
-exnToString = trunc . show
- where trunc = head . lines
-
--- a/lib/Control/Error.hs
+++ b/lib/Control/Error.hs
@@ -1,12 +1,23 @@
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
-module Control.Error(module Control.Error) where
+module Control.Error(error, undefined, ErrorCall(..)) where
import Prelude() -- do not import Prelude
-import Primitives
import Data.Char_Type
+import Data.List_Type
+import Control.Exception.Internal
+import {-# SOURCE #-} Data.Typeable+import Text.Show
+newtype ErrorCall = ErrorCall String
+ deriving (Typeable)
+
+instance Show ErrorCall where
+ show (ErrorCall s) = ("error: "::String) ++ s+
+instance Exception ErrorCall
+
error :: forall a . String -> a
-error = primError
+error s = throw (ErrorCall s)
undefined :: forall a . a
undefined = error "undefined"
--- /dev/null
+++ b/lib/Control/Error.hs-boot
@@ -1,0 +1,7 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Control.Error(module Control.Error) where
+import Prelude() -- do not import Prelude
+import Data.Char_Type
+
+error :: forall a . String -> a
--- a/lib/Control/Exception.hs
+++ b/lib/Control/Exception.hs
@@ -1,29 +1,42 @@
--- Copyright 2023 Lennart Augustsson
+-- Copyright 2023, 2024 Lennart Augustsson
-- See LICENSE file for full license.
module Control.Exception(
- catch, try,
- throwIO,
- Exn(..),
- exnToString,
- onException,
+ -- re-exports
+ catch, throw,
SomeException,
+ Exception(..),
+ -- defined here
+ try,
+ throwIO,
+-- onException,
) where
-import Primitives
-import Control.Exn
+import Control.Exception.Internal
+import {-# SOURCE #-} Data.Typeable-type SomeException = Exn
+instance Show SomeException where
+ showsPrec p (SomeException e) = showsPrec p e
-catch :: forall a . IO a -> (Exn -> IO a) -> IO a
-catch ioa hdl = primCatch ioa (hdl . Exn)
+instance Exception SomeException where
+ toException se = se
+ fromException = Just
+ displayException (SomeException e) = displayException e
-try :: forall a . IO a -> IO (Either Exn a)
+-- This is the function called by the runtime.
+-- It compiles to
+-- (U (U (K2 A)))
+-- displaySomeException :: SomeException -> String
+-- displaySomeException = displayException
+
+--------------------------
+
+try :: forall a e . Exception e => IO a -> IO (Either e a)
try ioa = catch (fmap Right ioa) (return . Left)
-throwIO :: forall a . Exn -> IO a
-throwIO (Exn s) =
- let e = error s
- in seq e (return e)
+throwIO :: forall a e . Exception e => e -> IO a
+throwIO e = throw e
+{-onException :: IO a -> IO b -> IO a
-onException io what = io `catch` \e -> do _ <- what
- throwIO e
+onException io what =
+ io `catch` \ e -> do { _ <- what; throwIO e }+-}
--- /dev/null
+++ b/lib/Control/Exception/Internal.hs
@@ -1,0 +1,70 @@
+-- Copyright 2024 Lennart Augustsson
+-- See LICENSE file for full license.
+module Control.Exception.Internal(
+ throw, catch,
+ Exception(..),
+ SomeException(..),
+ PatternMatchFail, NoMethodError,
+ ) where
+import Prelude()
+import Primitives(IO)
+import Data.Char_Type
+import Data.List_Type
+import Data.Maybe_Type
+import {-# SOURCE #-} Data.Typeable+import Text.Show
+
+primRaise :: forall a . SomeException -> a
+primRaise = primitive "raise"
+
+primCatch :: forall a . IO a -> (SomeException -> IO a) -> IO a
+primCatch = primitive "catch"
+
+throw :: forall e a. Exception e => e -> a
+throw e = primRaise (toException e)
+
+catch :: forall e a .
+ Exception e
+ => IO a
+ -> (e -> IO a)
+ -> IO a
+catch io handler = primCatch io handler'
+ where handler' e = case fromException e of
+ Just e' -> handler e'
+ Nothing -> primRaise e
+
+------------------
+
+data SomeException = forall e . Exception e => SomeException e
+ deriving (Typeable)
+
+-- NOTE: The runtime system knows about this class.
+-- It uses displayException to show an uncaught exception.
+-- Any changes here must be refleced in eval.c
+class (Typeable e, Show e) => Exception e where
+ toException :: e -> SomeException
+ fromException :: SomeException -> Maybe e
+ displayException :: e -> String
+
+ toException = SomeException
+ fromException (SomeException e) = cast e
+ displayException = show
+
+------------------
+
+-- Errors generated by the compiler
+
+newtype PatternMatchFail = PatternMatchFail String deriving (Typeable)
+newtype NoMethodError = NoMethodError String deriving (Typeable)
+
+instance Show PatternMatchFail where showsPrec _ (PatternMatchFail s) = showString s
+instance Show NoMethodError where showsPrec _ (NoMethodError s) = showString s
+
+instance Exception PatternMatchFail
+instance Exception NoMethodError
+
+patternMatchFail :: forall a . String -> a
+patternMatchFail s = throw (PatternMatchFail s)
+
+noMethodError :: forall a . String -> a
+noMethodError s = throw (NoMethodError s)
--- /dev/null
+++ b/lib/Control/Exception/Internal.hs-boot
@@ -1,0 +1,18 @@
+-- Copyright 2024 Lennart Augustsson
+-- See LICENSE file for full license.
+module Control.Exception.Internal(
+ throw,
+ Exception(..),
+ SomeException,
+ ) where
+import Data.Char_Type
+import Data.Typeable
+
+throw :: forall e a. Exception e => e -> a
+
+data SomeException
+
+class (Typeable e, Show e) => Exception e where
+ toException :: e -> SomeException
+ fromException :: SomeException -> Maybe e
+ displayException :: e -> String
--- a/lib/Control/Exn.hs
+++ /dev/null
@@ -1,11 +1,0 @@
--- Copyright 2024 Lennart Augustsson
--- See LICENSE file for full license.
-module Control.Exn(Exn(..), exnToString) where
-
--- Temporary exception type until we get proper exceptions.
-
-newtype Exn = Exn String
-
-exnToString :: Exn -> String
-exnToString (Exn s) = s
-
--- a/lib/Data/Integer_Type.hs
+++ b/lib/Data/Integer_Type.hs
@@ -3,6 +3,7 @@
module Data.Integer_Type(module Data.Integer_Type) where
import Prelude() -- do not import Prelude
import Primitives
+import {-# SOURCE #-} Control.Errorimport Data.Bool_Type
import Data.List_Type
@@ -19,7 +20,7 @@
else if _wordSize `primIntEQ` 32 then
(32768::Int) -- 2^15, this is used so multiplication of two digits doesn't overflow a 32 bit Int
else
- primError "Integer: unsupported word size"
+ error "Integer: unsupported word size"
-- Sadly, we also need a bunch of functions.
--- /dev/null
+++ b/lib/Data/Typeable.hs-boot
@@ -1,0 +1,16 @@
+module Data.Typeable where
+import Prelude()
+import Data.Char_Type
+import Data.Maybe_Type
+
+type Typeable :: forall k . k -> Constraint
+class Typeable a where
+ typeRep :: forall proxy . proxy a -> TypeRep
+
+data TypeRep
+mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
+
+data TyCon
+mkTyCon :: String -> String -> TyCon
+
+cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -159,9 +159,6 @@
primCharGE :: Char -> Char -> Bool
primCharGE = primitive ">="
-primError :: forall a . [Char] -> a
-primError = primitive "error"
-
primFix :: forall a . (a -> a) -> a
primFix = primitive "Y"
@@ -201,10 +198,6 @@
primPerformIO :: forall a . IO a -> a
primPerformIO = primitive "IO.performIO"
--- Use string for the exception until we can do better.
-primCatch :: forall a . IO a -> ([Char] -> IO a) -> IO a
-primCatch = primitive "IO.catch"
-
primRnfErr :: forall a . a -> ()
primRnfErr = primitive "rnf" (0::Int)
@@ -274,3 +267,4 @@
primArrEQ :: forall a . IOArray a -> IOArray a -> Bool
primArrEQ = primitive "A.=="
+
--- a/lib/System/Exit.hs
+++ b/lib/System/Exit.hs
@@ -5,16 +5,17 @@
exitSuccess,
die,
) where
-import Prelude
import Control.Exception
+import Data.Typeable
import System.IO
data ExitCode = ExitSuccess | ExitFailure Int
- deriving (Show)
+ deriving (Typeable, Show)
--- XXX This needs work
+instance Exception ExitCode
+
exitWith :: forall a . ExitCode -> IO a
-exitWith e = throwIO (Exn (show e))
+exitWith = throwIO
exitFailure :: forall a . IO a
exitFailure = exitWith (ExitFailure 1)
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -61,7 +61,7 @@
return ((rmn, dsn), ch')
compileMany :: Flags -> [IdentModule] -> Cache -> IO Cache
-compileMany flags mns ach = snd <$> runStateIO (mapM_ (compileModuleCached flags) mns) ach
+compileMany flags mns ach = snd <$> runStateIO (mapM_ (compileModuleCached flags ImpNormal) mns) ach
getCached :: Flags -> IO Cache
getCached flags | not (readCache flags) = return emptyCache
@@ -78,7 +78,17 @@
compile :: Flags -> IdentModule -> Cache -> IO ((IdentModule, [LDef]), Cache)
compile flags nm ach = do
let comp = do
- r <- compileModuleCached flags nm
+ r <- compileModuleCached flags ImpNormal nm
+ let loadBoots = do
+ bs <- gets getBoots
+ case bs of
+ [] -> return ()
+ bmn:_ -> do
+ when (verbosityGT flags 1) $
+ liftIO $ putStrLn $ "compiling used boot module " ++ showIdent bmn
+ _ <- compileModuleCached flags ImpNormal bmn
+ loadBoots
+ loadBoots
loadDependencies flags
return r
((cm, t), ch) <- runStateIO comp ach
@@ -90,19 +100,22 @@
-- If the module has already been compiled, return the cached result.
-- If the module has not been compiled, first try to find a source file.
-- If there is no source file, try loading a package.
-compileModuleCached :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Time)
-compileModuleCached flags mn = do
+compileModuleCached :: Flags -> ImpType -> IdentModule -> StateIO Cache (TModule [LDef], Time)
+compileModuleCached flags impt mn = do
cash <- get
case lookupCache mn cash of
- Nothing -> do
- when (verbosityGT flags 0) $
- liftIO $ putStrLn $ "importing " ++ showIdent mn
- mres <- liftIO (readModulePath flags ".hs" mn)
- case mres of
- Nothing -> findPkgModule flags mn
- Just (pathfn, file) -> do
- modify $ addWorking mn
- compileModule flags ImpNormal mn pathfn file
+ Nothing ->
+ case impt of
+ ImpBoot -> compileBootModule flags mn
+ ImpNormal -> do
+ when (verbosityGT flags 0) $
+ liftIO $ putStrLn $ "importing " ++ showIdent mn
+ mres <- liftIO (readModulePath flags ".hs" mn)
+ case mres of
+ Nothing -> findPkgModule flags mn
+ Just (pathfn, file) -> do
+ modify $ addWorking mn
+ compileModule flags ImpNormal mn pathfn file
Just tm -> do
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing cached " ++ showIdent mn
@@ -116,6 +129,7 @@
case mres of
Nothing -> error $ "boot module not found: " ++ showIdent mn
Just (pathfn, file) -> do
+ modify $ addBoot mn
compileModule flags ImpBoot mn pathfn file
compileModule :: Flags -> ImpType -> IdentModule -> FilePath -> String -> StateIO Cache (TModule [LDef], Time)
@@ -137,10 +151,8 @@
let
specs = [ s | Import s <- defs ]
imported = [ (boot, m) | ImportSpec boot _ m _ _ <- specs ]
- compileImp (ImpNormal, m) = compileModuleCached flags m
- compileImp (ImpBoot, m) = compileBootModule flags m
t2 <- liftIO getTimeMilli
- (impMdls, its) <- fmap unzip $ mapM compileImp imported
+ (impMdls, its) <- fmap unzip $ mapM (uncurry $ compileModuleCached flags) imported
t3 <- liftIO getTimeMilli
let
tmdl = typeCheck impt (zip specs impMdls) mdl
--- a/src/MicroHs/CompileCache.hs
+++ b/src/MicroHs/CompileCache.hs
@@ -1,6 +1,6 @@
module MicroHs.CompileCache(
CModule,
- Cache, addWorking, emptyCache, deleteFromCache, workToDone, workPop,
+ Cache, addWorking, emptyCache, deleteFromCache, workToDone, addBoot, getBoots,
cachedModules, lookupCache, lookupCacheChksum, getImportDeps,
addPackage, getCompMdls, getPkgs,
saveCache, loadCached,
@@ -38,6 +38,7 @@
data Cache = Cache {working :: [IdentModule], -- modules currently being processed (used to detected circular imports)
+ boots :: [IdentModule], -- modules where only the boot version has been compiled
cache :: M.Map CacheEntry, -- cached compiled modules
pkgs :: [Package] -- loaded packages
}
@@ -44,11 +45,17 @@
-- deriving (Show)
emptyCache :: Cache
-emptyCache = Cache { working = [], cache = M.empty, pkgs = [] }+emptyCache = Cache { working = [], boots = [], cache = M.empty, pkgs = [] }deleteFromCache :: IdentModule -> Cache -> Cache
deleteFromCache mn c = c{ cache = M.delete mn (cache c) }+addBoot :: IdentModule -> Cache -> Cache
+addBoot mn c = c{ boots = mn : boots c }+
+getBoots :: Cache -> [IdentModule]
+getBoots = boots
+
addWorking :: IdentModule -> Cache -> Cache
addWorking mn c =
let ws = working c
@@ -58,11 +65,9 @@
c{ working = mn : ws }workToDone :: CModule -> Cache -> Cache
-workToDone (t, i, k) c@(Cache{ working = mn:ws, cache = m }) = c{ working = ws, cache = M.insert mn (CompMdl t i k) m }+workToDone (t, i, k) c@(Cache{ working = mn:ws, boots = bs, cache = m }) =+ c{ working = ws, boots = filter (/= mn) bs, cache = M.insert mn (CompMdl t i k) m }workToDone _ _ = undefined
-
-workPop :: Cache -> Cache
-workPop c = c{ working = drop 1 (working c) }cachedModules :: Cache -> [TModule [LDef]]
cachedModules = map tModuleOf . M.elems . cache
--- a/src/MicroHs/Deriving.hs
+++ b/src/MicroHs/Deriving.hs
@@ -24,7 +24,7 @@
,("Data.Ix.Ix", derNotYet) ,("Data.Ord.Ord", derOrd) ,("Data.Typeable.Typeable", derTypeable)- ,("Text.Read.Read", derShow)+ ,("Text.Read.Read", derNotYet) ,("Text.Show.Show", derShow)]
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -222,7 +222,7 @@
body = mkTupleE $ map Var xs
in foldr Lam body xs
Nothing -> Var (conIdent c)
- _ -> impossible
+ _ -> impossibleShow aexpr
dsCompr :: Expr -> [EStmt] -> Expr -> Expr
dsCompr e [] l = EApp (EApp consCon e) l
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -1,7 +1,6 @@
module MicroHs.Interactive(module MicroHs.Interactive) where
import Data.List
import Control.Exception
-import Control.Exn
import MicroHs.Compile
import MicroHs.CompileCache
import MicroHs.Desugar(LDef)
@@ -162,8 +161,8 @@
mkTypeIt l =
"type " ++ itTypeName ++ " = " ++ l ++ "\n"
-err :: Exn -> IO ()
-err e = err' $ exnToString e
+err :: SomeException -> IO ()
+err e = err' $ displayException e
err' :: String -> IO ()
err' s = putStrLn $ "Error: " ++ s
@@ -194,7 +193,7 @@
Right _ -> ok
Left e -> bad e
-tryCompile :: String -> I (Either Exn [LDef])
+tryCompile :: String -> I (Either SomeException [LDef])
tryCompile file = do
updateCache (deleteFromCache interactiveId)
(_, flgs, cash) <- get
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -106,7 +106,6 @@
("fread", primitive "fread"), ("itof", primitive "itof"), ("seq", primitive "seq"),- ("error", primitive "error"), ("sequal", primitive "sequal"), ("equal", primitive "equal"), ("scmp", primitive "scmp"),@@ -125,7 +124,8 @@
("IO.stderr", primitive "IO.stderr"), ("IO.getArgRef", primitive "IO.getArgRef"), ("IO.performIO", primitive "IO.performIO"),- ("IO.catch", primitive "IO.catch"),+ ("raise", primitive "raise"),+ ("catch", primitive "catch"), ("dynsym", primitive "dynsym"), ("newCAStringLen", primitive "newCAStringLen"), ("peekCAString", primitive "peekCAString"),--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -929,7 +929,7 @@
dst <- tcDefsType ds
-- traceM ("tcDefs 2:\n" ++ showEDefs dst)mapM_ addTypeSyn dst
- dst' <- tcExpand dst
+ dst' <- tcExpand impt dst
-- traceM ("tcDefs 3:\n" ++ showEDefs dst')case impt of
ImpNormal -> do
@@ -977,14 +977,14 @@
return $ M.fromList iks'
-- Expand class and instance definitions (must be done after type synonym processing)
-tcExpand :: [EDef] -> T [EDef]
-tcExpand dst = withTypeTable $ do
- dsc <- concat <$> mapM expandClass dst -- Expand all class definitions
- dsf <- concat <$> mapM expandField dsc -- Add HasField instances
+tcExpand :: ImpType -> [EDef] -> T [EDef]
+tcExpand impt dst = withTypeTable $ do
+ dsc <- concat <$> mapM (expandClass impt) dst -- Expand all class definitions
+ dsf <- concat <$> mapM expandField dsc -- Add HasField instances
-- traceM $ showEDefs dsf
- dsd <- concat <$> mapM doDeriving dsf -- Add derived instances
+ dsd <- concat <$> mapM doDeriving dsf -- Add derived instances
-- traceM $ showEDefs dsd
- dsi <- concat <$> mapM expandInst dsd -- Expand all instance definitions
+ dsi <- concat <$> mapM expandInst dsd -- Expand all instance definitions
return dsi
-- Check&rename the given kinds, also insert the type variables in the symbol table.
@@ -1136,8 +1136,8 @@
-- in the desugaring pass.
-- Default methods are added as actual definitions.
-- The constructor and methods are added to the symbol table in addValueType.
-expandClass :: EDef -> T [EDef]
-expandClass dcls@(Class ctx (iCls, vks) fds ms) = do
+expandClass :: ImpType -> EDef -> T [EDef]
+expandClass impt dcls@(Class ctx (iCls, vks) fds ms) = do
mn <- gets moduleName
let
meths = [ b | b@(BSign _ _) <- ms ]
@@ -1151,10 +1151,12 @@
-- XXX This isn't right, "Prelude._nodefault" might not be in scope
noDflt = EApp noDefaultE (mkEStr (getSLoc iCls) (unIdent iCls ++ "." ++ unIdent methId))
mkDflt _ = impossible
- dDflts = concatMap mkDflt meths
+ dDflts = case impt of
+ ImpNormal -> concatMap mkDflt meths
+ ImpBoot -> []
addClassTable (qualIdent mn iCls) (vks, ctx, EUVar 0, methIds, mkIFunDeps (map idKindIdent vks) fds) -- Initial entry, no type needed.
return $ dcls : dDflts
-expandClass d = return [d]
+expandClass _ d = return [d]
mkEStr :: SLoc -> String -> Expr
mkEStr loc str = ESign (ELit loc (LStr str)) $ EListish $ LList [tConI loc "Char"]
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -178,13 +178,13 @@
T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW, T_FREAD,
#endif
T_ARR_ALLOC, T_ARR_SIZE, T_ARR_READ, T_ARR_WRITE, T_ARR_EQ,
- T_ERROR, T_NODEFAULT, T_NOMATCH, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
+ T_RAISE, T_NODEFAULT, T_NOMATCH, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
T_TICK,
T_IO_BIND, T_IO_THEN, T_IO_RETURN,
T_IO_CCBIND,
T_IO_SERIALIZE, T_IO_DESERIALIZE,
T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGREF,
- T_IO_PERFORMIO, T_IO_GETTIMEMILLI, T_IO_PRINT, T_IO_CATCH,
+ T_IO_PERFORMIO, T_IO_GETTIMEMILLI, T_IO_PRINT, T_CATCH,
T_IO_CCALL, T_DYNSYM,
T_NEWCASTRINGLEN, T_PEEKCASTRING, T_PEEKCASTRINGLEN,
T_FROMUTF8,
@@ -213,7 +213,7 @@
"C'BIND",
"IO_SERIALIZE", "IO_DESERIALIZE",
"IO_STDIN", "IO_STDOUT", "IO_STDERR", "IO_GETARGREF",
- "IO_PERFORMIO", "IO_GETTIMEMILLI", "IO_PRINT", "IO_CATCH",
+ "IO_PERFORMIO", "IO_GETTIMEMILLI", "IO_PRINT", "CATCH",
"IO_CCALL", "DYNSYM",
"NEWCASTRINGLEN", "PEEKCASTRING", "PEEKCASTRINGLEN",
"FROMUTF8",
@@ -537,6 +537,7 @@
NODEPTR combFalse, combTrue, combUnit, combCons, combPair;
NODEPTR combCC, combZ, combIOBIND, combIORETURN, combIOCCBIND;
NODEPTR combLT, combEQ, combGT;
+NODEPTR combShowExn, combU, combK2;
NODEPTR combBININT1, combBININT2, combUNINT1;
NODEPTR combBINDBL1, combBINDBL2, combUNDBL1;
@@ -622,7 +623,6 @@
{ "p+", T_PADD }, { "p-", T_PSUB }, { "seq", T_SEQ },- { "error", T_ERROR }, { "noDefault", T_NODEFAULT }, { "noMatch", T_NOMATCH }, { "equal", T_EQUAL, T_EQUAL },@@ -646,7 +646,8 @@
{ "IO.getArgRef", T_IO_GETARGREF }, { "IO.getTimeMilli", T_IO_GETTIMEMILLI }, { "IO.performIO", T_IO_PERFORMIO },- { "IO.catch", T_IO_CATCH },+ { "raise", T_RAISE },+ { "catch", T_CATCH }, { "A.alloc", T_ARR_ALLOC }, { "A.size", T_ARR_SIZE }, { "A.read", T_ARR_READ },@@ -694,6 +695,8 @@
case T_P: combPair = n; break;
case T_CC: combCC = n; break;
case T_Z: combZ = n; break;
+ case T_U: combU = n; break;
+ case T_K2: combK2 = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_RETURN: combIORETURN = n; break;
case T_IO_CCBIND: combIOCCBIND = n; break;
@@ -724,6 +727,8 @@
case T_P: combPair = n; break;
case T_CC: combCC = n; break;
case T_Z: combZ = n; break;
+ case T_U: combU = n; break;
+ case T_K2: combK2 = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_RETURN: combIORETURN = n; break;
case T_IO_CCBIND: combIOCCBIND = n; break;
@@ -763,6 +768,13 @@
NEWAP(combLT, combZ, combFalse); /* Z B */
NEWAP(combEQ, combFalse, combFalse); /* K K */
NEWAP(combGT, combFalse, combTrue); /* K A */
+ {+ /* The displaySomeException compiles to (U (U (K2 A))) */
+ NODEPTR x;
+ NEWAP(x, combK2, combTrue); /* (K2 A) */
+ NEWAP(x, combU, x); /* (U (K2 A)) */
+ NEWAP(combShowExn, combU, x); /* (U (U (K2 A))) */
+ }
#undef NEWAP
#if INTTABLE
@@ -1922,7 +1934,6 @@
case T_PNULL: putsb("pnull", f); break; case T_PADD: putsb("p+", f); break; case T_PSUB: putsb("p-", f); break;- case T_ERROR: putsb("error", f); break; case T_NODEFAULT: putsb("noDefault", f); break; case T_NOMATCH: putsb("noMatch", f); break; case T_EQUAL: putsb("equal", f); break;@@ -1939,7 +1950,8 @@
case T_IO_GETARGREF: putsb("IO.getArgRef", f); break; case T_IO_GETTIMEMILLI: putsb("IO.getTimeMilli", f); break; case T_IO_PERFORMIO: putsb("IO.performIO", f); break;- case T_IO_CATCH: putsb("IO.catch", f); break;+ case T_RAISE: putsb("raise", f); break;+ case T_CATCH: putsb("catch", f); break; case T_ARR_ALLOC: putsb("A.alloc", f); break; case T_ARR_SIZE: putsb("A.size", f); break; case T_ARR_READ: putsb("A.read", f); break;@@ -2685,12 +2697,11 @@
FREE(msg);
goto err; /* XXX not right message if the error is caught */
}
- case T_ERROR:
- if (doing_rnf) RET;
+
err:
if (cur_handler) {/* Pass the string to the handler */
- CHKARG1;
+ CHKARG1; /* argument in x */
cur_handler->hdl_exn = x;
longjmp(cur_handler->hdl_buf, 1);
} else {@@ -2708,6 +2719,40 @@
ERR1("error: %s", msg);#endif /* WANT_STDIO */
}
+
+ case T_RAISE:
+ if (doing_rnf) RET;
+ if (cur_handler) {+ /* Pass the string to the handler */
+ CHKARG1;
+ cur_handler->hdl_exn = x;
+ longjmp(cur_handler->hdl_buf, 1);
+ } else {+ /* No handler:
+ * First convert the exception to a string by calling displaySomeException.
+ * The display function compiles to combShowExn, so we need to build
+ * (combShowExn x) and evaluate it.
+ */
+ CHECK(1);
+ GCCHECK(1);
+ TOP(0) = new_ap(combShowExn, TOP(0)); /* (combShowExn x) */
+ x = evali(TOP(0));
+ msg = evalstring(x, 0);
+ POP(1);
+#if WANT_STDIO
+ /* A horrible hack until we get proper exceptions */
+ if (strcmp(msg, "ExitSuccess") == 0) {+ EXIT(0);
+ } else {+ fprintf(stderr, "mhs: %s\n", msg);
+ EXIT(1);
+ }
+#else /* WANT_STDIO */
+ ERR1("mhs error: %s", msg);+#endif /* WANT_STDIO */
+ }
+
+
case T_SEQ: CHECK(2); evali(ARG(TOP(0))); POP(2); n = TOP(-1); y = ARG(n); GOIND(y); /* seq x y = eval(x); y */
case T_EQUAL:
@@ -2742,7 +2787,7 @@
case T_IO_GETARGREF:
case T_IO_GETTIMEMILLI:
case T_IO_CCALL:
- case T_IO_CATCH:
+ case T_CATCH:
case T_NEWCASTRINGLEN:
case T_PEEKCASTRING:
case T_PEEKCASTRINGLEN:
@@ -3114,7 +3159,7 @@
RETIO(n); /* and this is the result */
}
- case T_IO_CATCH:
+ case T_CATCH:
{h = MALLOC(sizeof *h);
if (!h)
--- a/tests/Catch.hs
+++ b/tests/Catch.hs
@@ -14,11 +14,13 @@
main = do
let sshow :: String -> String
sshow = show
- x <- catch (return ("o" ++ "k")) (\ _ -> return "what?")+ exn :: SomeException -> IO String
+ exn e = return (displayException e)
+ x <- catch (return ("o" ++ "k")) (\ (_ :: SomeException) -> return "what?")putStrLn $ sshow x
- y <- catch (do { error "bang!"; return "yyy" }) (\ (Exn s) -> return s)+ y <- catch (do { error "bang!"; return "yyy" }) exnputStrLn $ sshow y
- z <- catch (do { print (f []); return "zzz" }) (\ (Exn s) -> return s)+ z <- catch (do { print (f []); return "zzz" }) exnputStrLn $ sshow z
- w <- catch (do { print (m ()); return "www" }) (\ (Exn s) -> return s)+ w <- catch (do { print (m ()); return "www" }) exnputStrLn $ sshow w
--
⑨