From 15ebcc764c30c18f41f179d589ad1ad5a45194f1 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Thu, 21 Nov 2019 12:57:59 +0100
Subject: Better string and IO support

---
 VM.hs | 27 ++++++++++++++++++++++++---
 1 file changed, 24 insertions(+), 3 deletions(-)

(limited to 'VM.hs')

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
-- 
cgit v1.2.3-54-g00ecf