Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Make error an Object

  • Loading branch information...
commit 9d2740f6c168f93522c7cd523d0fa9051c4a353d 1 parent 2b01cea
bjpop authored
View
6 src/Ministg/AST.hs
@@ -64,7 +64,6 @@ data Exp
| PrimApp Prim [Atom] -- ^ Saturated primitive application (op a_1 ... a_n, n >= 1).
| Let Var Object Exp -- ^ Let declaration.
| Case Exp [Alt] -- ^ Case expression.
- | Error -- ^ Raise an exception.
| Stack String Exp -- ^ Like SCC, but just for stacks. (stack str (exp))
deriving (Eq, Show)
@@ -77,7 +76,6 @@ instance FreeVars Exp where
= Set.delete var (freeVars exp `Set.union` freeVars object)
freeVars (Case exp alts)
= freeVars exp `Set.union` freeVars alts
- freeVars Error = Set.empty
freeVars (Stack _str exp) = freeVars exp
instance Pretty Exp where
@@ -96,7 +94,6 @@ instance Pretty Exp where
text "case" <+> pretty exp <+> text "of {" $$
nest 3 (vcat (punctuate semi (map pretty alts))) $$
rbrace
- pretty Error = text "error"
pretty (Stack annotation exp) =
maybeNest exp (text "stack" <+> doubleQuotes (text annotation)) (parens (pretty exp))
@@ -141,6 +138,7 @@ data Object
| Con Constructor [Atom] -- ^ Data constructor application (CON (C a_1 ... a_n)).
| Thunk Exp CallStack -- ^ THUNK (e).
| BlackHole -- ^ BLACKHOLE (only during evaluation - not part of the language syntax).
+ | Error -- ^ Raise an exception.
deriving (Eq, Show)
instance FreeVars Object where
@@ -149,6 +147,7 @@ instance FreeVars Object where
freeVars (Con constructor args) = freeVars args
freeVars (Thunk exp callStack) = freeVars exp
freeVars BlackHole = Set.empty
+ freeVars Error = Set.empty
maybeNest :: Exp -> Doc -> Doc -> Doc
maybeNest exp d1 d2 = if isNestedExp exp then d1 $$ (nest 3 d2) else d1 <+> d2
@@ -161,6 +160,7 @@ instance Pretty Object where
pretty (Thunk exp callStack)
= text "THUNK" <> parens (pretty exp) $$ (nest 3 (prettyCallStack callStack))
pretty BlackHole = text "BLACKHOLE"
+ pretty Error = text "ERROR"
-- | A top-level declaration (f = obj).
type Decl = (Var, Object)
View
3  src/Ministg/Arity.hs
@@ -75,7 +75,8 @@ instance Arity Exp where
| otherwise = Let var <$> arity object <*> local (clearVars [var]) (arity exp)
arity (Case exp alts) = Case <$> arity exp <*> mapM arity alts
arity (Stack annotation exp) = Stack annotation <$> arity exp
- arity other = return other
+ arity exp@(Atom {}) = return exp
+ arity exp@(PrimApp {}) = return exp
-- | Remove a list of variables from an ArityMap.
clearVars :: [Var] -> ArityMap -> ArityMap
View
27 src/Ministg/Eval.hs
@@ -38,10 +38,17 @@ evalProgram :: EvalStyle -> Heap -> Eval ()
evalProgram style heap = do
(newExp, _newStack, newHeap) <- bigStep style (Atom (Variable "main")) initStack heap
traceEnd
- case newExp of
- Atom (Literal lit) -> liftIO $ putStrLn $ prettyText lit
- Atom (Variable var) -> liftIO $ putStrLn $ prettyHeapObject newHeap $ lookupHeap var newHeap
- other -> liftIO $ putStrLn $ "Runtime error: result of bigStep is not an atom: " ++ show other
+ str <- case newExp of
+ Atom (Literal lit) -> return $ prettyText lit
+ Atom (Variable var) -> do
+ let object = lookupHeap var newHeap
+ case object of
+ Error -> do
+ cs <- gets state_callStack
+ return $ unlines ["Exception raised! Stack dump:", showCallStack cs]
+ other -> return $ prettyHeapObject newHeap $ lookupHeap var newHeap
+ other -> return $ "Runtime error: result of bigStep is not an atom: " ++ show other
+ liftIO $ putStrLn str
-- | Reduce an exression to WHNF (a big step reduction, which may be composed
-- of one or more small step reductions).
@@ -60,12 +67,6 @@ bigStep style exp stack heap = do
-- | Perform one step of reduction. These equations correspond to the
-- rules in the operational semantics described in the "fast curry" paper.
smallStep :: EvalStyle -> Exp -> Stack -> Heap -> Eval (Maybe (Exp, Stack, Heap))
--- ERROR
-smallStep _anyStyle Error stack heap = do
- setRule "ERROR"
- cs <- gets state_callStack
- liftIO $ putStrLn $ showCallStack cs
- return Nothing
-- STACK ANNOTATION
smallStep style (Stack annotation exp) stack heap = do
setRule "STACK"
@@ -308,7 +309,7 @@ instance Substitute Atom where
case Map.lookup var s of
Nothing -> v
Just atom -> atom
- subs _s l@(Literal _) = l
+ subs _s l@(Literal {}) = l
instance Substitute Exp where
subs s (Atom a) = Atom $ subs s a
@@ -323,7 +324,6 @@ instance Substitute Exp where
where
newSub = removeVars [var] s
subs s (Case exp alts) = Case (subs s exp) (subs s alts)
- subs _s Error = Error
subs s (Stack str e) = Stack str $ subs s e
instance Substitute Alt where
@@ -339,4 +339,5 @@ instance Substitute Object where
= Pap (subsVar s var) (subs s atoms)
subs s (Con constructor atoms) = Con constructor $ subs s atoms
subs s (Thunk exp cs) = Thunk (subs s exp) cs
- subs s BlackHole = BlackHole
+ subs _s BlackHole = BlackHole
+ subs _s Error = Error
View
2  src/Ministg/Lexer.hs
@@ -143,7 +143,7 @@ keyword =
key "gt#" GreaterThan <|>
key "gte#" GreaterThanEquals <|>
key "intToBool#" IntToBool <|>
- key "error" Error <|>
+ key "ERROR" Error <|>
key "stack" Stack
where
key :: String -> Symbol -> Parser Token
View
9 src/Ministg/Parser.hs
@@ -52,12 +52,8 @@ exp = funCallOrVar <|>
primApp <|>
letExp <|>
caseExp <|>
- errorCall <|>
stack
-errorCall :: Parser Exp
-errorCall = const Error <$> symbol Lex.Error
-
stack :: Parser Exp
stack = Stack <$> (symbol Lex.Stack *> quotedString) <*> (leftParen *> exp <* rightParen)
@@ -136,13 +132,14 @@ defaultAlt :: Parser Alt
defaultAlt = DefaultAlt <$> var <*> (rightArrow *> exp)
object :: Parser Object
-object = fun <|> pap <|> con <|> thunk
+object = fun <|> pap <|> con <|> thunk <|> errorObj
-fun, pap, con, thunk :: Parser Object
+fun, pap, con, thunk, errorObj :: Parser Object
fun = Fun <$> (symbol Lex.Fun *> leftParen *> many1 var) <*> (rightArrow *> exp <* rightParen)
pap = Pap <$> (symbol Lex.Pap *> leftParen *> var) <*> (many1 atom <* rightParen)
con = Con <$> (symbol Lex.Con *> leftParen *> constructor) <*> (many atom <* rightParen)
thunk = Thunk <$> (symbol Lex.Thunk *> leftParen *> exp <* rightParen) <*> pure []
+errorObj = const Error <$> symbol Lex.Error
var :: Parser Var
var = tokenParser getIdent
View
1  src/Ministg/State.hs
@@ -168,6 +168,7 @@ prettyHeapObject _heap (Fun {}) = "<function>"
prettyHeapObject _heap (Pap {}) = "<pap>"
prettyHeapObject _heap (Thunk {}) = "<thunk>"
prettyHeapObject _heap BlackHole = "<blackhole>"
+prettyHeapObject _heap Error = "<error>"
prettyHeapAtom :: Heap -> Atom -> String
prettyHeapAtom heap (Literal (Integer i)) = show i
View
1  test/Prelude.stg
@@ -1,3 +1,4 @@
+error = ERROR;
unit = CON(Unit);
true = CON(True);
false = CON(False);
Please sign in to comment.
Something went wrong with that request. Please try again.