Add tests and fix variables.

12 files changed, 62 insertions, 28 deletions

diff --git a/codegen.sml b/codegen.sml
index 84f3ad5..befedac 100644
--- a/codegen.sml
+++ b/codegen.sml
@@ -51,9 +51,9 @@ struct
       shuffle' inputMap outputMap @ constants
     end
 
-  fun buildVarMap (expr : Syntax.cexp) : Syntax.var VarMap.map =
+  fun buildVarMap (first : int) (expr : Syntax.cexp) : Syntax.var VarMap.map =
     let
-      val next = ref 0
+      val next = ref first
       fun insert v m =
         let val this = !next
         in
@@ -78,7 +78,7 @@ struct
                           (ListPair.zip
                             (List.tabulate (length args, fn x => x + 1),
                              args))
-                      val bodyVars = buildVarMap body
+                      val bodyVars = buildVarMap (length args + 1) body
                     in VarMap.union (VarMap.union acc argsVars) bodyVars
                     end)
                   VarMap.empty
@@ -106,7 +106,7 @@ struct
 
   fun toASM (expr : Syntax.cexp) : Syntax.opcode list =
     let
-      val varMap = buildVarMap expr
+      val varMap = buildVarMap 0 expr
       fun translate v =
         case VarMap.lookup v varMap of
           NONE => raise Fail ("unable to translate var " ^ Int.toString v)
@@ -144,7 +144,7 @@ struct
             in
               bodyASM @ funcsASM
             end
-        | Syntax.CPrimop (Syntax.PExit, [arg], _, _)=> [Syntax.OExit arg]
+        | Syntax.CPrimop (Syntax.PExit, [arg], _, _)=> [Syntax.OExit (translateVal arg)]
         | _ => raise Fail ("malformed CPS:\n" ^ Syntax.cexpToString expr)
     in go expr
     end
diff --git a/cps.sml b/cps.sml
index 56780a9..adb29c0 100644
--- a/cps.sml
+++ b/cps.sml
@@ -61,17 +61,18 @@ struct
 
   fun hoist (expr : Syntax.cexp) : Syntax.cexp =
     let
-      fun funs (Syntax.CRecord (_, _, k)) acc = funs k acc
-        | funs (Syntax.CSelect (_, _, _, k)) acc = funs k acc
-        | funs (Syntax.CApp _) acc = acc
-        | funs (Syntax.CFix (fs, body)) acc = funs body (fs @ acc)
-        | funs (Syntax.CPrimop (_, _, _, ks)) acc = foldl (fn (x, acc) => funs x acc) acc ks
-
       fun exprs (Syntax.CRecord (args, res, k)) = Syntax.CRecord (args, res, exprs k)
         | exprs (Syntax.CSelect (i, arg, res, k)) = Syntax.CSelect (i, arg, res, exprs k)
         | exprs (expr as Syntax.CApp _) = expr
         | exprs (Syntax.CFix (_, body)) = exprs body
         | exprs (Syntax.CPrimop (p, args, res, ks)) = Syntax.CPrimop (p, args, res, (map exprs ks))
+
+      fun funs (Syntax.CRecord (_, _, k)) acc = funs k acc
+        | funs (Syntax.CSelect (_, _, _, k)) acc = funs k acc
+        | funs (Syntax.CApp _) acc = acc
+        | funs (Syntax.CFix (fs, body)) acc =
+            funs body (foldl (fn ((fName, fVars, fBody), acc) => (fName, fVars, exprs fBody) :: funs fBody acc) acc fs)
+        | funs (Syntax.CPrimop (_, _, _, ks)) acc = foldl (fn (x, acc) => funs x acc) acc ks
       val entryPoint = Gensym.new ()
     in
       Syntax.CFix ((entryPoint, [], exprs expr) :: funs expr [], Syntax.CApp (Syntax.VLabel entryPoint, []))
diff --git a/elab.sml b/elab.sml
index 032d1d7..52d0089 100644
--- a/elab.sml
+++ b/elab.sml
@@ -27,21 +27,26 @@ struct
     | Syntax.ETyped (e, _) => elab env e
     | Syntax.EAndAlso (_, _) => raise Fail "unimplemented"
     | Syntax.EOrElse (_, _) => raise Fail "unimplemented"
-    | Syntax.ELet (decls, body) =>
-        foldr
-          (fn (Syntax.DVal v, acc) =>
-            Syntax.LApp (Syntax.LFn (Gensym.new (), acc), elab env v))
-          (elab env body)
-          decls
-    | Syntax.ELambda (var, body) =>
+    | Syntax.ELet ([], body) => elab env body
+    | Syntax.ELet (Syntax.DVal (pat, v) :: decls, body) =>
+        elab env (Syntax.ECase (v, [(pat, Syntax.ELet (decls, body))]))
+    | Syntax.ELambda (pat, body) =>
         let
           val v = Gensym.new ()
           val env' =
-            case var of
+            case pat of
               Syntax.PWild => env
             | Syntax.PVar name => StringMap.insert name v env
         in Syntax.LFn (v, elab env' body)
         end
+    | Syntax.ECase (expr, []) => raise Fail "nonexhaustive match"
+    | Syntax.ECase (expr, (pat, body) :: rest) =>
+        if rest <> [] then raise Fail "redundant match" else
+        let val v = Gensym.new () in
+          case pat of
+            Syntax.PWild => Syntax.LApp (Syntax.LFn (v, elab env body), elab env expr)
+          | Syntax.PVar name => Syntax.LApp (Syntax.LFn (v, elab (StringMap.insert name v env) body), elab env expr)
+        end
 
   fun elaborate (p : Syntax.expr) : Syntax.lexp = elab StringMap.empty p
 end
diff --git a/parser.sml b/parser.sml
index af3dfd7..6efc4aa 100644
--- a/parser.sml
+++ b/parser.sml
@@ -447,7 +447,12 @@ struct
       const (Syntax.ELambda (p, e)))))
   <|> raiseExpr) st
   and expr : Syntax.expr parser = fn st => fnExpr st
-  and dec : Syntax.dec parser = fn st => (reserved "val" >> reserved "_" >> reserved "=" >> Syntax.DVal <$> expr) st
+  and dec : Syntax.dec parser = fn st =>
+    (reserved "val" >>
+    bind pat (fn p =>
+    reserved "=" >>
+    bind expr (fn e =>
+    const (Syntax.DVal (p, e))))) st
 
   val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec
   fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
diff --git a/run_tests.fish b/run_tests.fish
new file mode 100644
index 0000000..f91b8ae
--- /dev/null
+++ b/run_tests.fish
@@ -0,0 +1,18 @@
+#!/usr/bin/env fish
+
+set d (realpath (status dirname))
+
+cd $d/bytecode
+cargo build
+
+cd $d
+
+for f in $d/tests/*.sml
+    $d/bytecode/target/debug/bytecode (sml $d/main.sml -o /dev/stderr $f >/dev/null 2>| psub)
+    set -l got $status
+    if test $got -eq 42
+        echo (basename -s.sml $f): PASS
+    else
+        echo (basename -s.sml $f): FAIL "(status $got)"
+    end
+end
diff --git a/syntax.sml b/syntax.sml
index 2a7ee9a..3e70ba1 100644
--- a/syntax.sml
+++ b/syntax.sml
@@ -24,8 +24,9 @@ struct
   | EOrElse of expr * expr
   | ELet of dec list * expr
   | ELambda of pat * expr
+  | ECase of expr * (pat * expr) list
 
-  and dec = DVal of expr
+  and dec = DVal of pat * expr
 
   (* Lambda language *)
   type var = int
@@ -106,11 +107,12 @@ struct
        | EOrElse (a, b) => "EOrElse (" ^ self a ^ ", " ^ self b ^ ")"
        | ELet (decs, e) => "ELet (" ^ multilineListToString decToStringI indent decs ^ ", " ^ self e ^ ")"
        | ELambda (pat, e) => "ELambda (" ^ patToString pat ^ ", " ^ exprToStringI indent e ^ ")"
+       | ECase (e, branches) => "ECase (" ^ self e ^ ", " ^ multilineListToString (fn indent => fn (pat, body) => "(" ^ patToString pat ^ ", " ^ exprToStringI indent body ^ ")") indent branches ^ ")"
     end
 
   and decToStringI (indent : string) (x : dec) : string =
     case x of
-      DVal e => "DVal (" ^ exprToStringI indent e ^ ")"
+      DVal (p, e) => "DVal (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")"
 
   val exprToString : expr -> string = exprToStringI ""
 
@@ -154,11 +156,11 @@ struct
 
   fun opcodeToString (oper : opcode) : string =
     case oper of
-      OAlloc (r, s) => "OAlloc (" ^ Int.toString r ^ ", " ^ valueToString s ^ ")"
+      OAlloc (r, s) => "Var " ^ Int.toString r ^ " = OAlloc(" ^ valueToString s ^ ")"
     | OCall => "OCall"
-    | OPoke (i, p, v) => "OPoke (" ^ Int.toString i ^ ", " ^ Int.toString p ^ ", " ^ valueToString v ^ ")"
-    | OPeek (r, i, p) => "OPeek (" ^ Int.toString r ^ ", " ^ Int.toString i ^ ", " ^ valueToString p ^ ")"
-    | OShuf (d, s) => "OShuf (" ^ Int.toString d ^ ", " ^ valueToString s ^ ")"
+    | OPoke (i, p, v) => "Var " ^ Int.toString p ^ "[" ^ Int.toString i ^ "] = " ^ valueToString v
+    | OPeek (r, i, p) => "Var " ^ Int.toString r ^ " = " ^ valueToString p ^ "[" ^ Int.toString i ^ "]"
+    | OShuf (d, s) => "Var " ^ Int.toString d ^ " = " ^ valueToString s
     | OExit v => "OExit " ^ valueToString v
     | OLabel l => "OLabel " ^ Int.toString l
 end
diff --git a/tests/01-simple.sml b/tests/01-simple.sml
new file mode 100644
index 0000000..3e87f14
--- /dev/null
+++ b/tests/01-simple.sml
@@ -0,0 +1 @@
+val _ = __builtin "exit" 42
diff --git a/tests/02-lambda.sml b/tests/02-lambda.sml
new file mode 100644
index 0000000..41470a2
--- /dev/null
+++ b/tests/02-lambda.sml
@@ -0,0 +1 @@
+val _ = (fn _ => __builtin "exit" 42) ()
diff --git a/tests/03-arg.sml b/tests/03-arg.sml
new file mode 100644
index 0000000..8d10139
--- /dev/null
+++ b/tests/03-arg.sml
@@ -0,0 +1 @@
+val _ = (fn x => __builtin "exit" x) 42
diff --git a/tests/04-val.sml b/tests/04-val.sml
new file mode 100644
index 0000000..20d07b4
--- /dev/null
+++ b/tests/04-val.sml
@@ -0,0 +1,2 @@
+val x = 42
+val _ = __builtin "exit" x
diff --git a/tests/lambda b/tests/lambda
deleted file mode 100644
index 45a6137..0000000
--- a/tests/lambda
+++ /dev/null
@@ -1 +0,0 @@
-val _ = (fn _ => __builtin "exit" 5) ()
diff --git a/tests/simple b/tests/simple
deleted file mode 100644
index d757a7f..0000000
--- a/tests/simple
+++ /dev/null
@@ -1 +0,0 @@
-val _ = __builtin "exit" 5