summaryrefslogtreecommitdiff
path: root/VM.hs
diff options
context:
space:
mode:
authorTom Smeding <tom.smeding@gmail.com>2019-11-21 12:57:59 +0100
committerTom Smeding <tom.smeding@gmail.com>2019-11-21 12:57:59 +0100
commit15ebcc764c30c18f41f179d589ad1ad5a45194f1 (patch)
treee83ebfbd8b2dc5e8524bf3fd647f55b9b8702941 /VM.hs
parentd4c554f62b007df2763c73ba7fd2b13814c186bc (diff)
Better string and IO support
Diffstat (limited to 'VM.hs')
-rw-r--r--VM.hs27
1 files changed, 24 insertions, 3 deletions
diff --git a/VM.hs b/VM.hs
index 7762b75..fb79ebd 100644
--- a/VM.hs
+++ b/VM.hs
@@ -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