Support let* expression

.ocamlformat

@@ -1 +1 @@
-profile = default
+profile = janestreet

bin/main.ml

@@ -28,7 +28,9 @@ let rec repl a_stream env =
   let result, env' = eval ast env in
   print_endline (string_val result);
   repl a_stream env'
+;;
 
 let () =
-  try repl { chrs = []; line_num = 1; chan = stdin } basis
-  with End_of_file -> print_endline "Goodbye!"
+  try repl { chrs = []; line_num = 1; chan = stdin } basis with
+  | End_of_file -> print_endline "Goodbye!"
+;;

lib/ast.ml

@@ -21,10 +21,10 @@ open Types.Ast
 
 let rec assert_unique = function
   | [] -> ()
-  | x :: xs ->
-      if List.mem x xs then raise (Unique_error_exn x) else assert_unique xs
+  | x :: xs -> if List.mem x xs then raise (Unique_error_exn x) else assert_unique xs
+;;
 
-let let_kinds = ["let", LET; "let*", LETSTAR; "letrec", LETREC]
+let let_kinds = [ "let", LET; "let*", LETSTAR; "letrec", LETREC ]
 let valid_let s = List.mem_assoc s let_kinds
 let to_kind s = List.assoc s let_kinds
 
@@ -33,54 +33,53 @@ let rec build_ast sexpr =
   | Primitive _ | Closure _ -> raise This_can't_happen_exn
   | Fixnum _ | Boolean _ | Nil | Quote _ -> Literal sexpr
   | Symbol symbol -> Var symbol
-  | Pair _ when Object.is_list sexpr -> (
-      match Object.pair_to_list sexpr with
-      | [ Symbol "if"; cond; if_true; if_false ] ->
-          If (build_ast cond, build_ast if_true, build_ast if_false)
-      | Symbol "cond" :: conditions -> cond_to_if conditions
-      | [ Symbol "and"; cond_x; cond_y ] ->
-          And (build_ast cond_x, build_ast cond_y)
-      | [ Symbol "or"; cond_x; cond_y ] ->
-          Or (build_ast cond_x, build_ast cond_y)
-      | [ Symbol "quote"; expr ] -> Literal (Quote expr)
-      | [ Symbol "setq"; Symbol name; expr ] ->
-          Defexpr (Setq (name, build_ast expr))
-      | [ Symbol "lambda"; ns; e ] when Object.is_list ns ->
-          let names =
-            List.map
-              (function
-                | Symbol symbol -> symbol
-                | _ -> raise (Type_error_exn "(lambda (formals) body)"))
-              (Object.pair_to_list ns)
-          in
-          Lambda (names, build_ast e)
-      | [ Symbol "defun"; Symbol name; args; expr ] ->
-          let err () = raise (Type_error_exn "(defun name (formals) body)") in
-          let names =
-            List.map
-              (function Symbol s -> s | _ -> err ())
-              (Object.pair_to_list args)
-          in
-          Defexpr (Defun (name, names, build_ast expr))
-      | [ Symbol "apply"; fn_expr; args ] ->
-        Apply (build_ast fn_expr, build_ast args)
-      | (Symbol s)::bindings::exp::[] when Object.is_list bindings && valid_let s ->
-        let mkbinding = function
-          | Pair (Symbol n, Pair (expr, Nil)) -> n, build_ast expr
-          | _ -> raise (Type_error_exn "(let bindings expr)")
-        in
-        let bindings = List.map mkbinding (Object.pair_to_list bindings) in
-        let () = assert_unique (List.map fst bindings) in
-        Let (to_kind s, bindings, build_ast exp)
-      | fn_expr :: args -> Call (build_ast fn_expr, List.map build_ast args)
-      | [] -> raise (Parse_error_exn "poorly formed expression"))
+  | Pair _ when Object.is_list sexpr ->
+    (match Object.pair_to_list sexpr with
+    | [ Symbol "if"; cond; if_true; if_false ] ->
+      If (build_ast cond, build_ast if_true, build_ast if_false)
+    | Symbol "cond" :: conditions -> cond_to_if conditions
+    | [ Symbol "and"; cond_x; cond_y ] -> And (build_ast cond_x, build_ast cond_y)
+    | [ Symbol "or"; cond_x; cond_y ] -> Or (build_ast cond_x, build_ast cond_y)
+    | [ Symbol "quote"; expr ] -> Literal (Quote expr)
+    | [ Symbol "setq"; Symbol name; expr ] -> Defexpr (Setq (name, build_ast expr))
+    | [ Symbol "lambda"; ns; e ] when Object.is_list ns ->
+      let names =
+        List.map
+          (function
+            | Symbol symbol -> symbol
+            | _ -> raise (Type_error_exn "(lambda (formals) body)"))
+          (Object.pair_to_list ns)
+      in
+      Lambda (names, build_ast e)
+    | [ Symbol "defun"; Symbol name; args; expr ] ->
+      let err () = raise (Type_error_exn "(defun name (formals) body)") in
+      let names =
+        List.map
+          (function
+            | Symbol s -> s
+            | _ -> err ())
+          (Object.pair_to_list args)
+      in
+      Defexpr (Defun (name, names, build_ast expr))
+    | [ Symbol "apply"; fn_expr; args ] -> Apply (build_ast fn_expr, build_ast args)
+    | [ Symbol s; bindings; exp ] when Object.is_list bindings && valid_let s ->
+      let mkbinding = function
+        | Pair (Symbol n, Pair (expr, Nil)) -> n, build_ast expr
+        | _ -> raise (Type_error_exn "(let bindings expr)")
+      in
+      let bindings = List.map mkbinding (Object.pair_to_list bindings) in
+      let () = assert_unique (List.map fst bindings) in
+      Let (to_kind s, bindings, build_ast exp)
+    | fn_expr :: args -> Call (build_ast fn_expr, List.map build_ast args)
+    | [] -> raise (Parse_error_exn "poorly formed expression"))
   | Pair _ -> Literal sexpr
 
 and cond_to_if = function
   | [] -> Literal (Symbol "error")
   | Pair (cond, Pair (res, Nil)) :: condpairs ->
-      If (build_ast cond, build_ast res, cond_to_if condpairs)
+    If (build_ast cond, build_ast res, cond_to_if condpairs)
   | _ -> raise (Type_error_exn "(cond conditions)")
+;;
 
 let spacesep ns = String.concat " " ns
 
@@ -90,24 +89,25 @@ let rec string_exp =
   function
   | Literal e -> string_val e
   | Var n -> n
-  | If (c, t, f) ->
-      "(if " ^ string_exp c ^ " " ^ string_exp t ^ " " ^ string_exp f ^ ")"
+  | If (c, t, f) -> "(if " ^ string_exp c ^ " " ^ string_exp t ^ " " ^ string_exp f ^ ")"
   | And (c0, c1) -> "(and " ^ string_exp c0 ^ " " ^ string_exp c1 ^ ")"
   | Or (c0, c1) -> "(or " ^ string_exp c0 ^ " " ^ string_exp c1 ^ ")"
   | Apply (f, e) -> "(apply " ^ string_exp f ^ " " ^ string_exp e ^ ")"
   | Call (f, es) -> "(" ^ string_exp f ^ " " ^ spacesep_exp es ^ ")"
-  | Lambda (args, body) ->
-      "(lambda (" ^ spacesep args ^ ") " ^ string_exp body ^ ")"
+  | Lambda (args, body) -> "(lambda (" ^ spacesep args ^ ") " ^ string_exp body ^ ")"
   | Defexpr (Setq (n, e)) -> "(setq " ^ n ^ " " ^ string_exp e ^ ")"
   | Defexpr (Defun (n, ns, e)) ->
-      "(defun " ^ n ^ "(" ^ spacesep ns ^ ") " ^ string_exp e ^ ")"
+    "(defun " ^ n ^ "(" ^ spacesep ns ^ ") " ^ string_exp e ^ ")"
   | Defexpr (Expr e) -> string_exp e
   | Let (kind, bs, e) ->
-      let str =
-        match kind with LET -> "let" | LETSTAR -> "let*" | LETREC -> "letrec"
-      in
-      let bindings = spacesep (List.map string_of_binding bs) in
-      "(" ^ str ^ " (" ^ bindings ^ ") " ^ string_exp e ^ ")"
+    let str =
+      match kind with
+      | LET -> "let"
+      | LETSTAR -> "let*"
+      | LETREC -> "letrec"
+    in
+    let bindings = spacesep (List.map string_of_binding bs) in
+    "(" ^ str ^ " (" ^ bindings ^ ") " ^ string_exp e ^ ")"
 
 and string_val e =
   let rec string_list l =
@@ -126,8 +126,8 @@ and string_val e =
   | Boolean b -> if b then "#t" else "#f"
   | Symbol s -> s
   | Nil -> "nil"
-  | Pair (_, _) ->
-      "(" ^ (if Object.is_list e then string_list e else string_pair e) ^ ")"
+  | Pair (_, _) -> "(" ^ (if Object.is_list e then string_list e else string_pair e) ^ ")"
   | Primitive (name, _) -> "#<primitive:" ^ name ^ ">"
   | Quote expr -> "'" ^ string_val expr
   | Closure (_, _, _) -> "#<closure>"
+;;

lib/environment.ml

@@ -23,47 +23,52 @@ exception Unspecified_value_exn of string
 
 let rec lookup = function
   | n, [] -> raise (Not_found_exn n)
-  | n, (n', v) :: _ when n = n' -> (
-      match !v with Some v' -> v' | None -> raise (Unspecified_value_exn n))
+  | n, (n', v) :: _ when n = n' ->
+    (match !v with
+    | Some v' -> v'
+    | None -> raise (Unspecified_value_exn n))
   | n, (_, _) :: bs -> lookup (n, bs)
+;;
 
 let bind (name, value, sexpr) = (name, ref (Some value)) :: sexpr
 let mk_loc () = ref None
 let bind_loc (n, vor, e) = (n, vor) :: e
-
-let bind_list ns vs env =
-  List.fold_left2 (fun acc n v -> bind (n, v, acc)) env ns vs
+let bind_list ns vs env = List.fold_left2 (fun acc n v -> bind (n, v, acc)) env ns vs
 
 let basis =
-  let newprim acc (name, func) =
-    bind (name, Object.Primitive (name, func), acc)
-  in
-  List.fold_left newprim []
-    [
-      Primitives.Num.generate "+" ( + );
-      Primitives.Num.generate "-" ( - );
-      Primitives.Num.generate "*" ( * );
-      Primitives.Num.generate "/" ( / );
-      Primitives.Num.generate "mod" ( mod );
-      Primitives.Cmp.generate "=" ( = );
-      Primitives.Cmp.generate "<" ( < );
-      Primitives.Cmp.generate ">" ( > );
-      Primitives.Cmp.generate ">=" ( >= );
-      Primitives.Cmp.generate "<=" ( <= );
-
-      ("list", Primitives.list);
-      ("pair", Primitives.pair);
-      ("car", Primitives.car);
-      ("cdr", Primitives.cdr);
-      ("eq", Primitives.eq);
-      ("atom?", Primitives.atomp);
-      ("sym?", Primitives.symp);
+  let newprim acc (name, func) = bind (name, Object.Primitive (name, func), acc) in
+  List.fold_left
+    newprim
+    []
+    [ Primitives.Num.generate "+" ( + )
+    ; Primitives.Num.generate "-" ( - )
+    ; Primitives.Num.generate "*" ( * )
+    ; Primitives.Num.generate "/" ( / )
+    ; Primitives.Num.generate "mod" ( mod )
+    ; Primitives.Cmp.generate "=" ( = )
+    ; Primitives.Cmp.generate "<" ( < )
+    ; Primitives.Cmp.generate ">" ( > )
+    ; Primitives.Cmp.generate ">=" ( >= )
+    ; Primitives.Cmp.generate "<=" ( <= )
+    ; "list", Primitives.list
+    ; "pair", Primitives.pair
+    ; "car", Primitives.car
+    ; "cdr", Primitives.cdr
+    ; "eq", Primitives.eq
+    ; "atom?", Primitives.atomp
+    ; "sym?", Primitives.symp
     ]
+;;
 
 let rec env_to_val =
   let b_to_val (n, vor) =
     Object.Pair
-      (Symbol n, match !vor with None -> Symbol "unspecified" | Some v -> v)
+      ( Symbol n
+      , match !vor with
+        | None -> Symbol "unspecified"
+        | Some v -> v )
   in
   function
-  | [] -> Object.Nil | b :: bs -> Object.Pair (b_to_val b, env_to_val bs)
+  | [] -> Object.Nil
+  | b :: bs -> Object.Pair (b_to_val b, env_to_val bs)
+;;

lib/eval.ml

@@ -20,66 +20,69 @@ include Ast
 open Types.Object
 
 let extend newenv oldenv =
-  List.fold_right
-    (fun (b, v) acc -> Environment.bind_loc (b, v, acc))
-    newenv oldenv
+  List.fold_right (fun (b, v) acc -> Environment.bind_loc (b, v, acc)) newenv oldenv
+;;
 
 let rec eval_expr expr env =
-  let eval_apply fn_expr args =
-    match fn_expr with
-    | Primitive (_, f) -> f args
-    | Closure (ns, e, clenv) ->
-        eval_expr e (extend (Environment.bind_list ns args clenv) env)
-    | _ -> raise (Type_error_exn "(apply prim '(args)) or (prim args)")
-  in
   let rec eval = function
-    | Literal (Quote e) -> e
     | Literal l -> l
     | Var n -> Environment.lookup (n, env)
     | If (cond, if_true, _) when eval cond = Boolean true -> eval if_true
     | If (cond, _, if_false) when eval cond = Boolean false -> eval if_false
     | If _ -> raise (Type_error_exn "(if bool e1 e2)")
-    | And (cond_x, cond_y) -> (
-        match (eval cond_x, eval cond_y) with
-        | Boolean x, Boolean y -> Boolean (x && y)
-        | _ -> raise (Type_error_exn "(and bool bool)"))
-    | Or (cond_x, cond_y) -> (
-        match (eval cond_x, eval cond_y) with
-        | Boolean v1, Boolean v2 -> Boolean (v1 || v2)
-        | _ -> raise (Type_error_exn "(or bool bool)"))
-    | Apply (fn, args) -> eval_apply (eval fn) (Object.pair_to_list (eval args))
+    | And (cond_x, cond_y) ->
+      (match eval cond_x, eval cond_y with
+      | Boolean x, Boolean y -> Boolean (x && y)
+      | _ -> raise (Type_error_exn "(and bool bool)"))
+    | Or (cond_x, cond_y) ->
+      (match eval cond_x, eval cond_y with
+      | Boolean x, Boolean y -> Boolean (x && y)
+      | _ -> raise (Type_error_exn "(or bool bool)"))
+    | Apply (fn, args) -> eval_apply (eval fn) (Object.pair_to_list (eval args)) env
     | Call (Var "env", []) -> Environment.env_to_val env
-    | Call (fn, args) -> eval_apply (eval fn) (List.map eval args)
+    | Call (fn, args) -> eval_apply (eval fn) (List.map eval args) env
     | Lambda (args, body) -> Closure (args, body, env)
     | Let (LET, bindings, body) ->
-        let eval_binding (n, e) = n, ref (Some (eval e)) in
-        eval_expr body (extend (List.map eval_binding bindings) env)
-    | Let (LETSTAR, _, _) -> failwith "Not yet implemented"
-    | Let (LETREC, _, _) -> failwith "Not yet implemented"  
+      let eval_binding (n, e) = n, ref (Some (eval e)) in
+      eval_expr body (extend (List.map eval_binding bindings) env)
+    | Let (LETSTAR, bindings, body) ->
+      let eval_binding acc (n, e) = Environment.bind (n, eval_expr e acc, acc) in
+      eval_expr body (extend (List.fold_left eval_binding [] bindings) env)
+    | Let (LETREC, _, _) -> failwith "Not yet implemented"
     | Defexpr _ -> raise This_can't_happen_exn
   in
   eval expr
 
+and eval_apply fn_expr args env =
+  match fn_expr with
+  | Primitive (_, f) -> f args
+  | Closure (ns, e, clenv) -> eval_closure ns e args clenv env
+  | _ -> raise (Type_error_exn "(apply prim '(args)) or (prim args)")
+
+and eval_closure ns e args clenv env =
+  eval_expr e (extend (Environment.bind_list ns args clenv) env)
+;;
+
 let eval_def def env =
   match def with
   | Setq (name, expr) ->
-      let v = eval_expr expr env in
-      (v, Environment.bind (name, v, env))
+    let v = eval_expr expr env in
+    v, Environment.bind (name, v, env)
   | Defun (n, ns, e) ->
-      let formals, body, cl_env =
-        match eval_expr (Lambda (ns, e)) env with
-        | Closure (fs, bod, env) -> (fs, bod, env)
-        | _ -> raise (Type_error_exn "Expecting closure.")
-      in
-      let loc = Environment.mk_loc () in
-      let clo =
-        Closure (formals, body, Environment.bind_loc (n, loc, cl_env))
-      in
-      let () = loc := Some clo in
-      (clo, Environment.bind_loc (n, loc, env))
-  | Expr e -> (eval_expr e env, env)
+    let formals, body, cl_env =
+      match eval_expr (Lambda (ns, e)) env with
+      | Closure (fs, bod, env) -> fs, bod, env
+      | _ -> raise (Type_error_exn "Expecting closure.")
+    in
+    let loc = Environment.mk_loc () in
+    let clo = Closure (formals, body, Environment.bind_loc (n, loc, cl_env)) in
+    let () = loc := Some clo in
+    clo, Environment.bind_loc (n, loc, env)
+  | Expr e -> eval_expr e env, env
+;;
 
 let eval ast env =
   match ast with
   | Defexpr def_expr -> eval_def def_expr env
-  | expr -> (eval_expr expr env, env)
+  | expr -> eval_expr expr env, env
+;;