Better string and IO support

8 files changed, 71 insertions, 20 deletions

diff --git a/Compiler.hs b/Compiler.hs
index 347eb4a..b7f5639 100644
--- a/Compiler.hs
+++ b/Compiler.hs
@@ -86,9 +86,11 @@ newtype CM a = CM {unCM :: StateT CompState (Except String) a}
 -- TODO: extra info like number of arguments, dunno, might be useful
 builtinSet :: Set.Set Name
 builtinSet = Set.fromList [
-    "+", "-", "<=", "=", "print",
+    "+", "-", "*", "/", "mod", "<=", "=", "print",
     "list", "car", "cdr", "null?",
-    "sys-open-file", "sys-close-file", "sys-get-char", "sys-put-string"]
+    "sys-open-file", "sys-close-file", "sys-get-char", "sys-put-string", "sys-flush",
+    "sys-stdin", "sys-stdout", "sys-stderr",
+    "length", "substr", "ord", "chr", "concat"]
 
 bbId :: BB -> Int
 bbId (BB i _ _) = i
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
diff --git a/test.sh b/test.sh
index 1e7137f..21ce262 100755
--- a/test.sh
+++ b/test.sh
@@ -4,8 +4,13 @@ stack build
 prog="$(stack path --local-install-root)/bin/lisp"
 ok=1
 for f in tests/*.lisp; do
+	outf="$(sed 's/\.lisp$/.out/' <<<"$f")"
 	echo "- $f"
-	diff -u <("$prog" "$f") "$(sed 's/\.lisp$/.out/' <<<"$f")" || ok=0
+	if [[ ! -f $outf ]]; then
+		echo "WARNING: $outf not found"
+	else
+		diff -u <("$prog" "$f") "$outf" || ok=0
+	fi
 done
 if [[ $ok -eq 1 ]]; then
 	echo "All OK"
diff --git a/tests/interactive.lisp b/tests/interactive.lisp
new file mode 100644
index 0000000..d40758b
--- /dev/null
+++ b/tests/interactive.lisp
@@ -0,0 +1,6 @@
+#include "stdlib.lisp"
+
+(sys-put-string stdout "line: ")
+(sys-flush stdout)
+(define str (read-line stdin))
+(print str)
diff --git a/tests/letrec.lisp b/tests/letrec.lisp
deleted file mode 100644
index 52a7de9..0000000
--- a/tests/letrec.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-(define fibo (n)
-    (let ((helper (lambda (m a b)
-                        (if (= m n) b (helper m b (+ a b))))))
-        (if (<= n 0) 0
-         (if (<= n 2) 1
-          (helper 2 1 1)))))
diff --git a/tests/stdlib.lisp b/tests/stdlib.lisp
index 380fa2a..96a55bb 100644
--- a/tests/stdlib.lisp
+++ b/tests/stdlib.lisp
@@ -2,6 +2,10 @@
 (define caddr (x) (car (cdr (cdr x))))
 (define cadddr (x) (car (cdr (cdr (cdr x)))))
 
+(define not (x) (if x 0 1))
+(define or (x y) (if x 1 (if y 1 0)))
+(define and (x y) (if x (if y 1 0) 0))
+
 (define YY (recur) (lambda (f) (lambda (a) (f ((recur recur) f) a))))
 (define Y (YY YY))
 
@@ -10,6 +14,10 @@
         (do (f start) (for (+ start 1) end f))
         '()))
 
+(define stdin (sys-stdin))
+(define stdout (sys-stdout))
+(define stderr (sys-stderr))
+
 (define with-open-file (path mode f)
     (let ((fid (sys-open-file mode path)))
         (let ((value (f fid)))
@@ -17,12 +25,17 @@
                 (sys-close-file fid)
                 value))))
 
+(define read-until (fid predicate)
+    (let ((helper (lambdarec rec (s)
+                        (let ((ch (sys-get-char fid)))
+                            (if (predicate ch) s (rec (concat s ch)))))))
+        (helper "")))
+
+(define read-until-eof (fid)
+    (read-until fid null?))
+
 (define read-file (path)
-    (with-open-file path 0 (lambda (fid)
-        ; (print (sys-get-char fid))
-        ; (print (let ((x (lambda (arg) fid))) (x 42)))
-        (let ((helper (Y (lambda (recur s)
-                           (let ((ch (sys-get-char fid)))
-                             (if (null? ch) s (recur (+ s ch))))))))
-            (helper ""))
-        )))
+    (with-open-file path 0 read-until-eof))
+
+(define read-line (fid)
+    (read-until fid (lambda (ch) (or (= ch "\n") (null? ch)))))
diff --git a/tests/stringtest.lisp b/tests/stringtest.lisp
new file mode 100644
index 0000000..aa4898c
--- /dev/null
+++ b/tests/stringtest.lisp
@@ -0,0 +1,9 @@
+#include "stdlib.lisp"
+
+(define str (read-file "tests/stringtest.lisp"))
+
+(for 0 (length str) (lambda (i)
+    (if (= (mod i 60) 0)
+        (sys-put-string stdout (concat "<" (substr str i 10) ">"))
+        '())))
+(print "")
diff --git a/tests/stringtest.out b/tests/stringtest.out
new file mode 100644
index 0000000..a0c457b
--- /dev/null
+++ b/tests/stringtest.out
@@ -0,0 +1 @@
+<#include "><test.lisp"><d i 60) 0)><r str i 10>