Add lambda functions.

15 files changed, 77 insertions, 58 deletions

diff --git a/bytecode/.encoding.c.swp b/bytecode/.encoding.c.swp
new file mode 100644
index 0000000..fc8e88a
--- /dev/null
+++ b/bytecode/.encoding.c.swp
diff --git a/bytecode/slice.c b/bytecode/slice.c
deleted file mode 100644
index 0739a4a..0000000
--- a/bytecode/slice.c
+++ /dev/null
@@ -1,25 +0,0 @@
-#include <assert.h>
-
-#include "slice.h"
-
-struct slice slice(struct slice a, size_t i, size_t j)
-{
-	assert(i <= a.size && j <= a.size && i <= j);
-	return (struct slice) { .size = j - i, .buf = a.buf + i };
-}
-
-struct slice slice1(struct slice a, size_t i)
-{
-	return slice(a, i, a.size);
-}
-
-struct val_slice val_slice(struct val_slice a, size_t i, size_t j)
-{
-	assert(i <= a.size && j <= a.size && i <= j);
-	return (struct val_slice) { .size = j - i, .buf = a.buf + i };
-}
-
-struct val_slice val_slice1(struct val_slice a, size_t i)
-{
-	return val_slice(a, i, a.size);
-}
diff --git a/bytecode/value.c b/bytecode/value.c
index 2a15b44..1b18a96 100644
--- a/bytecode/value.c
+++ b/bytecode/value.c
@@ -13,7 +13,7 @@ bool is_int(value v)
 int64_t to_int(value v)
 {
 	if (!is_int(v)) {
-		panicf("value %lx is not an int!\n", v);
+		panicf("value 0x%lx is not an int!\n", v);
 	}
 	return (int64_t) v >> 1;
 }
@@ -31,7 +31,7 @@ bool is_pointer(value v)
 value *to_pointer(value v)
 {
 	if (!is_pointer(v)) {
-		panicf("value %lx is not a pointer!\n", v);
+		panicf("value 0x%lx is not a pointer!\n", v);
 	}
 	return (value *) v;
 }
diff --git a/codegen.sml b/codegen.sml
index 1f6a2a8..84f3ad5 100644
--- a/codegen.sml
+++ b/codegen.sml
@@ -107,7 +107,10 @@ struct
   fun toASM (expr : Syntax.cexp) : Syntax.opcode list =
     let
       val varMap = buildVarMap expr
-      fun translate v = valOf (VarMap.lookup v varMap)
+      fun translate v =
+        case VarMap.lookup v varMap of
+          NONE => raise Fail ("unable to translate var " ^ Int.toString v)
+        | SOME x => x
       fun translateVal (Syntax.VVar v) = Syntax.VVar (translate v)
         | translateVal x = x
       fun go expr =
@@ -126,12 +129,12 @@ struct
                     in rev (Syntax.OPoke (i, translate res, temp) :: ops)
                     end)
                   (enumerate args))
-            @ toASM k
-        | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: toASM k
-        | Syntax.CApp (func, args) => shuffle (func :: args) @ [Syntax.OCall]
+            @ go k
+        | Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: go k
+        | Syntax.CApp (func, args) => shuffle (map translateVal (func :: args)) @ [Syntax.OCall]
         | Syntax.CFix (funcs, body) =>
             let
-              val bodyASM = toASM body
+              val bodyASM = go body
               val funcsASM =
                 foldl
                   (fn ((name, _, body), acc) =>
diff --git a/compiler.sml b/compiler.sml
index 599d85a..4c5e238 100644
--- a/compiler.sml
+++ b/compiler.sml
@@ -2,25 +2,28 @@ structure Compiler =
 struct
   fun compile (prog : Syntax.expr) : Word8Vector.vector =
     let
+      val _ = print ("ast:\n" ^ Syntax.exprToString prog ^ "\n")
       val elab = Elab.elaborate prog
+      val _ = print ("lambda lang:\n" ^ Syntax.lexpToString elab ^ "\n")
       val cps =
-        CPS.convertClosures
-          (CPS.toCPS elab
-            (fn _ => Syntax.CPrimop (Syntax.PExit, [Syntax.VInt 0], [], [])))
-      val _ = print ("cps:\n" ^ Syntax.cexpToString cps ^ "\n")
-      val asm = CodeGen.toASM cps
+        CPS.toCPS elab
+          (fn _ => Syntax.CPrimop (Syntax.PExit, [Syntax.VInt 0], [], []))
+      val _ = print ("cps1:\n" ^ Syntax.cexpToString cps ^ "\n")
+      val cps' = CPS.convertClosures cps
+      val _ = print ("cps:\n" ^ Syntax.cexpToString cps' ^ "\n")
+      val asm = CodeGen.toASM cps'
       val _ = print ("bytecode:\n" ^ String.concatWith "\n" (map Syntax.opcodeToString asm) ^ "\n")
     in
       Linker.link asm
     end
 
-  fun main () =
+  fun main (args : string list) : unit =
     let
       val opts = { o = ref "a.out" }
       val flags =
         [ ("o", Opts.StringOpt (fn arg => #o opts := arg)) ]
       val filename =
-        case Opts.getOpt flags of
+        case Opts.getOpt flags args of
           [arg] => arg
         | _ => raise Fail "usage: sml [-o <outfile>] <filename>"
       val ast =
diff --git a/cps.sml b/cps.sml
index 948b8c8..6854545 100644
--- a/cps.sml
+++ b/cps.sml
@@ -2,7 +2,17 @@ structure CPS =
 struct
   fun toCPS (e : Syntax.lexp) (cont : Syntax.value -> Syntax.cexp) : Syntax.cexp =
     case e of
-      Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) =>
+      Syntax.LVar v => cont (Syntax.VVar v)
+    | Syntax.LFn (v, expr) =>
+        let
+          val fnName = Gensym.new ()
+          val k = Gensym.new ()
+        in
+          Syntax.CFix
+            ([(fnName, [v, k], toCPS expr (fn ret => Syntax.CApp (Syntax.VVar k, [ret])))],
+             cont (Syntax.VVar fnName))
+        end
+    | Syntax.LApp (Syntax.LPrim primop, Syntax.LRecord args) =>
         let
           val temp = Gensym.new ()
           fun go [] acc = Syntax.CPrimop (primop, rev acc, [temp], [cont (Syntax.VVar temp)])
@@ -45,8 +55,8 @@ struct
 
       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 (func, args)) = expr
-        | exprs (Syntax.CFix (_, body)) = body
+        | 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))
       val entryPoint = Gensym.new ()
     in
@@ -148,7 +158,7 @@ struct
                   let val funcFreeVars = freeVarsClosure old
                   in Syntax.CRecord ((Syntax.VLabel newName, []) :: map (fn v => (Syntax.VVar v, [])) funcFreeVars, oldName, acc)
                   end)
-                body
+                (convertExpr varMap body)
                 (ListPair.zip (funcs, convertedFuncs))
           in
             Syntax.CFix (convertedFuncs, newBody)
diff --git a/elab.sml b/elab.sml
index 0838f38..6a80715 100644
--- a/elab.sml
+++ b/elab.sml
@@ -7,16 +7,25 @@ struct
 
   fun elaborate (p : Syntax.expr) : Syntax.lexp =
     case p of
-      Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
-    | Syntax.EIdent [i] => raise Fail "only primitive operations for now, no variables"
+      Syntax.EIdent [i] => raise Fail "only primitive operations for now, no variables"
+    | Syntax.EIdent _ => raise Fail "long identifiers are not supported"
+    | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
     | Syntax.EInt i => Syntax.LInt i
     | Syntax.EStr s => Syntax.LString s
     | Syntax.ETuple exprs => Syntax.LRecord (map elaborate exprs)
+    | Syntax.EList exprs =>
+        foldr
+          (fn (x, acc) =>
+            Syntax.LRecord [elaborate x, acc])
+          (Syntax.LInt 0)
+          exprs
     | Syntax.EApp (f, x) => Syntax.LApp (elaborate f, elaborate x)
     | Syntax.ETyped (e, _) => elaborate e
+    | Syntax.EAndAlso (_, _) => raise Fail "unimplemented"
+    | Syntax.EOrElse (_, _) => raise Fail "unimplemented"
     | Syntax.ELet (decls, body) =>
         Syntax.LRecord
           (map elaborate
             (map (fn (Syntax.DVal e) => e) decls @ [body]))
-    | _ => raise Fail "elaborate: operation not supported"
+    | Syntax.ELambda e => Syntax.LFn (Gensym.new (), elaborate e)
 end
diff --git a/format.sml b/format.sml
new file mode 100644
index 0000000..98e8230
--- /dev/null
+++ b/format.sml
@@ -0,0 +1,7 @@
+structure Format =
+struct
+  fun listToString (show : 'a -> string) (l : 'a list) =
+    "[" ^ String.concatWith ", " (map show l) ^ "]"
+
+  fun pairToString showA showB (a, b) = "(" ^ showA a ^ ", " ^ showB b ^ ")"
+end
diff --git a/linker.sml b/linker.sml
index 874e145..6694d89 100644
--- a/linker.sml
+++ b/linker.sml
@@ -31,14 +31,14 @@ struct
     end
 
   fun writeVar w v =
-    if v > 7
+    if v > CodeGen.tempReg
     then raise Fail ("var out of range: " ^ Int.toString v)
     else lowByte w (Word.fromInt v)
 
   fun writeOffset w i =
-    if ~128 > i orelse i > 127
+    if 0 > i orelse i > 127
     then raise Fail ("offset out of range: " ^ Int.toString i)
-    else lowByte w 
+    else lowByte w (Word.fromInt i)
 
   structure IntMap = Map(type k = int val cmp = Int.compare);
 
@@ -58,13 +58,13 @@ struct
           makeOpcode w 2 false false
       | Syntax.OPoke (off, p, v) =>
           (makeOpcode w 3 (isConst v) false ;
-           writeInt w off ;
+           writeOffset w off ;
            writeVar w p ;
            writeValue w v)
       | Syntax.OPeek (r, off, v) =>
           (makeOpcode w 4 (isConst v) false ;
            writeVar w r ;
-           writeInt w off ;
+           writeOffset w off ;
            writeValue w v)
       | Syntax.OShuf (r, v) =>
           (makeOpcode w 5 (isConst v) false ;
diff --git a/main.sml b/main.sml
index 10e6937..4b22f65 100644
--- a/main.sml
+++ b/main.sml
@@ -1,3 +1,4 @@
+use "format.sml";
 use "result.sml";
 use "buffer.sml";
 use "gensym.sml";
@@ -12,5 +13,5 @@ use "opts.sml";
 use "parser.sml";
 use "compiler.sml";
 
-val _ = Compiler.main ()
+val _ = Compiler.main (CommandLine.arguments ())
 val _ = OS.Process.exit OS.Process.success
diff --git a/opts.sml b/opts.sml
index ea5b935..f5be8c4 100644
--- a/opts.sml
+++ b/opts.sml
@@ -25,7 +25,7 @@ struct
     | "False" => false
     | _ => error "invalid boolean value"
 
-  fun getOpt (desc : (string * 'a optDesc) list) : string list =
+  fun getOpt (desc : (string * 'a optDesc) list) (args : string list) : string list =
     let
       val parsers = StringMap.fromList desc
       fun go [] = []
@@ -76,6 +76,6 @@ struct
                        go args)
               end
     in
-      go (CommandLine.arguments ())
+      go args
     end
 end
diff --git a/parser.sml b/parser.sml
index cfc6563..7d4d9c2 100644
--- a/parser.sml
+++ b/parser.sml
@@ -428,7 +428,10 @@ struct
           bind orelseExpr (fn e2 =>
           const (Syntax.EOrElse (e1, e2))))
       <|> const e1) st
-  and expr : Syntax.expr parser = fn st => typedExp st
+  and handleExpr : Syntax.expr parser = fn st => orelseExpr st
+  and raiseExpr : Syntax.expr parser = fn st => handleExpr st
+  and fnExpr : Syntax.expr parser = fn st => ((reserved "fn" >> reserved "_" >> reserved "=>" >> Syntax.ELambda <$> expr) <|> 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
 
   val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec
diff --git a/syntax.sml b/syntax.sml
index 5ed5954..95487d7 100644
--- a/syntax.sml
+++ b/syntax.sml
@@ -17,19 +17,22 @@ struct
                 | EAndAlso of expr * expr
                 | EOrElse of expr * expr
                 | ELet of dec list * expr
+                | ELambda of expr
 
   and dec = DVal of expr
 
   (* Lambda language *)
+  type var = int
   datatype primop = PExit
-  datatype lexp = LApp of lexp * lexp
+  datatype lexp = LVar of var
+                | LFn of var * lexp
+                | LApp of lexp * lexp
                 | LInt of int
                 | LString of string
                 | LRecord of lexp list
                 | LPrim of primop
 
   (* CPS *)
-  type var = int
   datatype value = VVar of var
                  | VLabel of var
                  | VInt of int
@@ -83,6 +86,7 @@ struct
        | EAndAlso (a, b) => "EAndAlso (" ^ self a ^ ", " ^ self b ^ ")"
        | EOrElse (a, b) => "EOrElse (" ^ self a ^ ", " ^ self b ^ ")"
        | ELet (decs, e) => "ELet (" ^ multilineListToString decToStringI indent decs ^ ", " ^ self e ^ ")"
+       | ELambda e => "ELambda " ^ exprToStringI indent e
     end
 
   and decToStringI (indent : string) (x : dec) : string =
@@ -99,7 +103,9 @@ struct
 
   fun lexpToString (x : lexp) : string =
     case x of
-      LApp (a, b) => "LApp (" ^ lexpToString a ^ ", " ^ lexpToString b ^ ")"
+      LVar v => "LVar " ^ Int.toString v
+    | LFn (arg, expr) => "LFun (" ^ Int.toString arg ^ ", " ^ lexpToString expr ^ ")"
+    | LApp (a, b) => "LApp (" ^ lexpToString a ^ ", " ^ lexpToString b ^ ")"
     | LInt i => "LInt " ^ Int.toString i
     | LString s => "LString " ^ quote s
     | LRecord l => "LRecord " ^ listToString lexpToString l
diff --git a/tests/lambda b/tests/lambda
new file mode 100644
index 0000000..45a6137
--- /dev/null
+++ b/tests/lambda
@@ -0,0 +1 @@
+val _ = (fn _ => __builtin "exit" 5) ()
diff --git a/tests/simple b/tests/simple
new file mode 100644
index 0000000..d757a7f
--- /dev/null
+++ b/tests/simple
@@ -0,0 +1 @@
+val _ = __builtin "exit" 5