From 4dd7ed521e22a0c81317b1e5ebdb235258e47a2a Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Fri, 22 Nov 2019 19:54:01 +0100 Subject: Proper 'throw' usage in VM --- VM.hs | 24 +++++++++++++++--------- 1 file 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 -- cgit v1.2.3-54-g00ecf