summaryrefslogtreecommitdiff
path: root/VM.hs
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2019-11-22 19:54:01 +0100
committertomsmeding <tom.smeding@gmail.com>2019-11-22 19:54:01 +0100
commit4dd7ed521e22a0c81317b1e5ebdb235258e47a2a (patch)
tree0c96ee5209960d22343fe9b1ea27176675dd1d07 /VM.hs
parentd3271899e5cda93552d9ccd0cc6e2b0b3cafe325 (diff)
Proper 'throw' usage in VM
Diffstat (limited to 'VM.hs')
-rw-r--r--VM.hs24
1 files changed, 15 insertions, 9 deletions
diff --git a/VM.hs b/VM.hs
index 138bf26..e0ed2f4 100644
--- a/VM.hs
+++ b/VM.hs
@@ -112,7 +112,10 @@ callClosure info@(Info bbmap gfds _) state@(State { sTempMap = tmap }) cl as =
vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State)
-- vmRunBuiltin _ name args | trace (name ++ " " ++ show args) False = undefined
vmRunBuiltin state "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [], state)
-vmRunBuiltin state "=" [a, b] = return (if equalOp a b then RVNum 1 else RVNum 0, state)
+vmRunBuiltin state "=" [a, b] = case equalOp a b of
+ Left err -> throw err
+ Right True -> return (RVNum 1, state)
+ Right False -> return (RVNum 0, state)
vmRunBuiltin state "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b)), state)
vmRunBuiltin state "+" [RVNum a, RVNum b] = return (RVNum (a + b), state)
vmRunBuiltin state "-" [RVNum a, RVNum b] = return (RVNum (a - b), state)
@@ -165,17 +168,20 @@ vmRunBuiltin state "type-number?" [value] = return (RVNum (case value of { RVNum
vmRunBuiltin state "type-string?" [value] = return (RVNum (case value of { RVString _ -> 1; _ -> 0 }), state)
vmRunBuiltin state "type-quoted?" [value] = return (RVNum (case value of { RVQuoted _ -> 1; _ -> 0 }), state)
vmRunBuiltin state "type-symbol?" [value] = return (RVNum (case value of { RVName _ -> 1; _ -> 0 }), state)
+vmRunBuiltin _ "error" [RVString str] = throw ("error: " ++ str)
vmRunBuiltin _ name args = error (name ++ " " ++ show args)
-equalOp :: RunValue -> RunValue -> Bool
-equalOp (RVClosure _ _) _ = error "Cannot compare closures in '='"
-equalOp _ (RVClosure _ _) = error "Cannot compare closures in '='"
-equalOp (RVList vs) (RVList ws) = length vs == length ws && all id (zipWith equalOp vs ws)
-equalOp (RVNum a) (RVNum b) = a == b
-equalOp (RVString s) (RVString t) = s == t
+equalOp :: RunValue -> RunValue -> Either String Bool
+equalOp (RVClosure _ _) _ = Left "Cannot compare closures in '='"
+equalOp _ (RVClosure _ _) = Left "Cannot compare closures in '='"
+equalOp (RVList vs) (RVList ws)
+ | length vs == length ws = all id <$> sequence (zipWith equalOp vs ws)
+ | otherwise = Right False
+equalOp (RVNum a) (RVNum b) = Right (a == b)
+equalOp (RVString s) (RVString t) = Right (s == t)
equalOp (RVQuoted v) (RVQuoted w) = equalOp v w
-equalOp (RVName n) (RVName m) = n == m
-equalOp _ _ = False
+equalOp (RVName n) (RVName m) = Right (n == m)
+equalOp _ _ = Right False
printshow :: RunValue -> String
printshow (RVString str) = str