Add closure

ast.ml

@@ -9,6 +9,7 @@ type t =
   | Nexternal of string
   | Var of string
   | Let of string * t
+  | Letin of string * t * t
   | Unary of operator * t
   | Binop of t * operator * t
   | If of t * t * t (* cond then else *)
@@ -61,9 +62,12 @@ let print ast =
       List.iter (pr " %s") @@ List.tl args;
       pr ") "; aux e; pr ")"
     | Nexternal e -> pr "(extern %s)" e
+
     | Var v -> pr "%s" v
     | Let (v, e) ->
-      pr "(let %s " v; aux e; pr ")"
+      pr "(define %s " v; aux e; pr ")"
+    | Letin (v, e, f) ->
+      pr "(let ((%s " v; aux e; pr "))"; aux f; pr ")"
     | Unary (op, t) ->
       let op = op_to_string op in
       pr "(%s " op; aux t; pr ")"

eval.ml

@@ -7,7 +7,7 @@ type value =
   | Bool of bool
   | String of string
   | Symbol of string
-  | Function of string list * expr
+  | Function of string list * expr * env
   | External of string
   | Nop (* return of system operations (will be deprecated) *)
 
@@ -58,7 +58,7 @@ module Value = struct
     | Bool b -> string_of_bool b
     | String s -> "\"" ^ s ^ "\""
     | Symbol s -> "symbol " ^ s
-    | Function (vars, _) ->
+    | Function (vars, _, _) ->
       Printf.sprintf "function with %d arguments" @@ List.length vars
     | External f -> "external " ^ f
     | Nop -> "nop"
@@ -268,12 +268,20 @@ let rec eval env ast : string * value =
     | Nbool b -> Bool b
     | Nstring s -> String s
     | Nsymbol s -> Symbol s
-    | Nfunction (args, e) -> Function (args, e)
+    | Nfunction (args, e) ->
+      let nenv = Env.make env in
+      Function (args, e, nenv)
     | Nexternal f -> External f
+
     | Var v -> begin match Env.get_opt env v with
         | None -> raise @@ Unbound v
         | Some v -> v
       end
+    | Letin (v, e, f) ->
+      let nenv = Env.make env in
+      Env.set nenv v (aux e);
+      snd @@ eval nenv f
+
     | Unary (op, t) ->
       let t = aux t in
       let op = Operator.get_unary op in
@@ -289,7 +297,7 @@ let rec eval env ast : string * value =
       end
     | Apply (v, args) ->
       begin match aux v with
-        | Function (vars, e) ->
+        | Function (vars, e, env) ->
           assert_same_length vars args;
           let args = List.map aux args in
           let nenv = Env.make env in

parser.ml

@@ -81,7 +81,7 @@ let token_is_operator tok =
   Hashtbl.mem operators tok
 
 let is_keyword = function
-  | "if" | "then" | "else" | "let" -> true
+  | "if" | "then" | "else" | "let" | "in" -> true
   | _ -> false
 
 (* common parsers *)
@@ -155,17 +155,17 @@ let more f seq =
   let xs, seq = aux [] seq in
   List.rev xs, seq
 
-(* decl := let_value
+(* decl := let_global
  *       | expr
  *)
 let rec decl seq =
   seq |> oneof [
-    let_value;
     expr min_int;
+    let_global;
   ]
 
-(* let_value := "let" ident "=" expr *)
-and let_value seq =
+(* let_global := "let" ident "=" expr *)
+and let_global seq =
   let _, seq = ident "let" seq in
   let id, seq = any_ident seq in
   let _, seq = token Token.Equal seq in
@@ -173,6 +173,7 @@ and let_value seq =
   Let (id, e), seq
 
 (* expr := level
+ *       | let_value
  *       | assoc
  *       | apply
  *       | value binop_right
@@ -180,6 +181,7 @@ and let_value seq =
 and expr pre seq =
   seq |> oneof [
     ifexpr;
+    let_value;
     oneof [apply; unary; value] @> binop pre;
     level;
     assoc;
@@ -187,6 +189,16 @@ and expr pre seq =
     extern_value;
   ]
 
+(* let_value := "let" id "=" expr "in" expr *)
+and let_value seq =
+  let _, seq = ident "let" seq in
+  let id, seq = any_ident seq in
+  let _, seq = token Equal seq in
+  let e, seq = expr min_int seq in
+  let _, seq = ident "in" seq in
+  let f, seq = expr min_int seq in
+  Letin (id, e, f), seq
+
 (* level := "level" {"get" | "set"} [op] *)
 and level seq =
   let _, seq = ident "level" seq in