diff options
Diffstat (limited to 'VM.hs')
| -rw-r--r-- | VM.hs | 27 |
1 files changed, 24 insertions, 3 deletions
@@ -1,6 +1,7 @@ module VM(vmRun) where import Control.Monad +import Data.Char import Data.List import Data.Maybe import qualified Data.Map.Strict as Map @@ -45,7 +46,7 @@ vmRun :: IRProgram -> IO () vmRun (IRProgram bbs gfds datas) = let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs] info = Info bbmap gfds datas - state = State Map.empty [] [] Map.empty 0 + state = State Map.empty [] [] (Map.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0 in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler vmErrorHandler :: IOError -> IO () @@ -107,13 +108,15 @@ assignRef state (RTemp i) rv = state { sTempMap = Map.insert i rv (sTempMap stat assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned" vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State) --- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined +-- 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 "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b)), state) vmRunBuiltin state "+" [RVNum a, RVNum b] = return (RVNum (a + b), state) -vmRunBuiltin state "+" [RVString a, RVString b] = return (RVString (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) +vmRunBuiltin state "/" [RVNum a, RVNum b] = return (RVNum (a `div` b), state) +vmRunBuiltin state "mod" [RVNum a, RVNum b] = return (RVNum (a `mod` b), state) vmRunBuiltin state "null?" [v] = return (RVNum (case v of { RVList [] -> 1; _ -> 0 }), state) vmRunBuiltin state "car" [RVList l] = case l of a : _ -> return (a, state) @@ -139,6 +142,20 @@ vmRunBuiltin state "sys-get-char" [RVNum fid] = do vmRunBuiltin state "sys-put-string" [RVNum fid, RVString str] = do hPutStr (sHandles state ! fid) str return (RVList [], state) +vmRunBuiltin state "sys-flush" [RVNum fid] = do + hFlush (sHandles state ! fid) + return (RVList [], state) +vmRunBuiltin state "sys-stdin" [] = return (RVNum (-1), state) +vmRunBuiltin state "sys-stdout" [] = return (RVNum (-2), state) +vmRunBuiltin state "sys-stderr" [] = return (RVNum (-3), state) +vmRunBuiltin state "length" [RVString str] = return (RVNum (length str), state) +vmRunBuiltin state "substr" [RVString str, RVNum idx, RVNum len] = + return (RVString (take len (drop idx str)), state) +vmRunBuiltin state "ord" [RVString str] = return (RVNum (case str of { "" -> 0; c:_ -> ord c }), state) +vmRunBuiltin state "chr" [RVNum num] = return (RVString [chr num], state) +vmRunBuiltin state "concat" values + | Just strings <- sequence (map fromRVString values) = return (RVString (concat strings), state) + | otherwise = throw "Non-string arguments to 'concat'" vmRunBuiltin _ name args = error (name ++ " " ++ show args) equalOp :: RunValue -> RunValue -> Bool @@ -173,3 +190,7 @@ toRunValue _ = undefined throw :: String -> IO a throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit) + +fromRVString :: RunValue -> Maybe String +fromRVString (RVString str) = Just str +fromRVString _ = Nothing |