Added type annotations for the environment module to make things clearer, switched bind_args implementation with a simpler one.

.gitignore

@@ -1 +1,2 @@
-_build
+_build
+*~

lib/ast.ml

@@ -21,30 +21,11 @@ type lisp_val =
   | LMacro of string * environment * lisp_val * lisp_val
   | LUnnamedMacro of environment * lisp_val * lisp_val
   | LQuoted of lisp_val
+(* the environment type needs to be defined here, as it is mutually
+ recursive with lisp_val *)
 and environment = (string, lisp_val) Hashtbl.t list
 
 
-let env_set_local env s v =
-  match env with
-  | [] -> ()
-  | e1 :: _ ->  Hashtbl.replace e1 s v
-
-let env_new_lexical env = 
-  let h = Hashtbl.create 16 in
-  h :: env
-
-let rec env_root (env : environment) =
-  match env with
-  | [] -> raise (Invalid_argument "Empty environment passed to env_root!")
-  | e :: [] -> e
-  | _ :: t -> env_root t
-
-let env_set_global env s v =
-  Hashtbl.replace (env_root env) s v
-
-let env_copy env =
-  List.map Hashtbl.copy env
-
 let rec dbg_print_one v =
   let pf = Printf.sprintf in
   match v with

lib/env.ml

@@ -0,0 +1,33 @@
+open Ast
+(* the type `environment` is defined in Ast *)
+
+let new_lexical (env : environment) : environment = 
+  let h = Hashtbl.create 16 in
+  h :: env
+
+let set_local (env : environment) (s : string) (v : lisp_val) : unit =
+  match env with
+  | [] -> ()
+  | e1 :: _ -> Hashtbl.replace e1 s v
+
+let rec update (env : environment) s v =
+  match env with
+  | [] -> ()
+  | e1 :: erest ->
+     match Hashtbl.find_opt e1 s with
+     | None -> update erest s v
+     | Some _ -> Hashtbl.replace e1 s v
+
+let rec get_root (env : environment) =
+  match env with
+  | [] -> raise (Invalid_argument "Empty environment passed to env_root!")
+  | e :: [] -> e
+  | _ :: t -> get_root t
+
+let set_global (env : environment) s v =
+  Hashtbl.replace (get_root env) s v
+
+let copy (env : environment) : environment =
+  List.map Hashtbl.copy env
+
+

lib/eval.ml

@@ -5,11 +5,11 @@ open InterpreterStdlib;;
 let default_env: environment = [Hashtbl.create 1024];;
 
 let add_builtin s f =
-  env_set_global default_env s (LBuiltinFunction (s, f))
+  Env.set_global default_env s (LBuiltinFunction (s, f))
 let add_special s f =
-  env_set_global default_env s (LBuiltinSpecial (s, f))
+  Env.set_global default_env s (LBuiltinSpecial (s, f))
 
-let make_env () = [Hashtbl.copy (List.hd default_env)]
+let make_env () = Env.copy default_env
 
 (* the type annotations are unnecessary, but help constrain us from a
 potentially more general function here *)
@@ -43,35 +43,26 @@ and eval_body env body =
   | LCons (form, next) -> ignore (eval_one env form); eval_body env next
   | _ -> LNil
 
-and err s = raise (Invalid_argument s)
 and bind_args env = function
-  | LNil -> (function
+  | (LNil, LNil) -> ()
-      | LNil -> ()
+  | (LSymbol s, v) -> Env.set_local env s v
-      | _ -> err "cannot bind arguments")
+  | (LCons (LSymbol hl, tl), LCons (ha, ta)) -> Env.set_local env hl ha; bind_args env (tl, ta)
-  | LSymbol s ->
+  | _ -> invalid_arg "cannot bind argument list for function"
-    (function
+
-      | v -> env_set_local env s v; ())
-  | LCons (LSymbol hl, tl) -> (function
-      | LCons (ha, ta) -> 
-        env_set_local env hl ha;
-        bind_args env tl ta;
-      | _ -> err "cannot bind arguments")
-  | _ -> fun _ -> err "bind_args"
-  
 and eval_apply args = function
   | LLambda (e, l, b)
   | LFunction (_, e, l, b) ->
-    let lexical_env = env_new_lexical e in
+    let lexical_env = Env.new_lexical e in
-    bind_args lexical_env l args;
+    bind_args lexical_env (l, args);
     eval_body lexical_env b
   | LUnnamedMacro (e, l, b)
   | LMacro (_, e, l, b) ->
-    let lexical_env = env_new_lexical e in
+    let lexical_env = Env.new_lexical e in
-    bind_args lexical_env l args;
+    bind_args lexical_env (l, args);
     eval_body lexical_env b
   | v ->
-    err ("Non-macro non-function value passed to eval_apply "
+    invalid_arg ("Non-macro non-function value passed to eval_apply "
-        ^ dbg_print_one v); LNil
+        ^ dbg_print_one v)
     
 
 
@@ -90,40 +81,80 @@ and eval_call env func args =
   | v -> raise (Invalid_argument 
                   (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))
 
-and (* This only creates a *local* binding, contained to the body given. *)
+ (* This only creates a *local* binding, contained to the body given. *)
-  bind_local env =
+let bind_local env = function
-  function
   | LCons (LSymbol s, LCons (v, body)) ->
-    let e = env_new_lexical env in
+    let e = Env.new_lexical env in
-    env_set_local e s v;
+    Env.set_local e s v;
     eval_body e body
   | _ -> invalid_arg "invalid argument to bind-local"
 
+(* special form that creates a global binding *)
+let lisp_define env = function
+  | LCons (LSymbol s, LCons (v, LNil)) ->
+     let evaluated = eval_one env v in
+     Env.set_global env s evaluated;
+     evaluated
+  | _ -> invalid_arg "invalid args to def"
+
+let lisp_if env = function
+  | LCons (cond, LCons (if_true, LNil)) ->
+    (match eval_one env cond with
+     | LNil -> LNil
+     | _ -> eval_one env if_true)
+  | LCons (cond, LCons (if_true, LCons (if_false, LNil))) ->
+    (match eval_one env cond with
+     | LNil -> eval_one env if_false
+     | _ -> eval_one env if_true)
+  | _ -> invalid_arg "invalid argument list passed to if!"
 
 let eval_all env vs =
   let ev v = eval_one env v in
   List.map ev vs
 
-let () = add_builtin "+" iadd
+let () = add_builtin "+" add
-let () = add_builtin "-" isub
+let () = add_builtin "-" sub
 let () = add_builtin "car" car
 let () = add_builtin "cdr" cdr
 let () = add_builtin "cons" cons
-let () = add_builtin "bind-symbol" bind_symbol 
+let () = add_special "def" lisp_define
+let () = add_builtin "set" lisp_set
 let () = add_builtin "list" lisp_list
-let () = add_special "lambda" lambda
+let () = add_special "fn" lambda
-let () = add_special "lambda-macro" lambda_macro
+let () = add_special "fn-macro" lambda_macro
 let () = add_special "let-one" bind_local
 let () = add_special "quote" (fun _ -> function
-    | LCons (x, LNil) -> x
+             | LCons (x, LNil) -> x
-                         | _ -> invalid_arg "hmm")
+             | _ -> invalid_arg "hmm")
+let () = add_special "if" lisp_if
+let () = add_builtin "nil?" lisp_not
+let () = add_builtin "not" lisp_not (* Yes, these are the same thing *)
+(*let () = add_builtin "print" lisp_prin *)
 
-(* I know this looks insane. please trust me. *)
+(* I know this looks insane. please trust me.
-let _ = eval_all default_env (Read.parse_str "
+   Idea: maybe put this in a file instead of putting
-(bind-symbol 'defun
+   literally the entire standard library in a constant string
-  (lambda-macro (name lm . body)
+ *)
-    (list 'bind-symbol (list 'quote name) (cons 'lambda (cons lm body)))))
+let _ = eval_all default_env (Read.parse_str
-(bind-symbol 'defmacro
+"
-  (lambda-macro (name lm . body)
+(def defn
-    (list 'bind-symbol (list 'quote name) (cons 'lambda-macro (cons lm body)))))")
+  (fn-macro (name lm . body)
+    (list 'def name (cons 'fn (cons lm body)))))
+(def defmacro
+  (fn-macro (name lm . body)
+    (list 'def name (cons 'fn-macro (cons lm body)))))
+
+(defmacro setq (sym val)
+ (list 'set (list 'quote sym) val))
+(defmacro letfn (sym fun . body)
+ (cons 'let-one (cons sym (cons '() (cons (list 'setq sym fun) body)))))
+
+
+(defn filter (f l)
+   (letfn helper
+       (fn (l acc)
+         (if (nil? l) acc (helper (cdr l) (if (f (car l)) (cons (car l) acc) acc))))
+     (helper l '())))
+ 
+")
 

lib/interpreterStdlib.ml

@@ -1,37 +1,33 @@
 open Ast;;
 
-let iadd _ vs : lisp_val =
+let add _ vs =
-  let rec auxi vs accum = 
+  let rec aux accum = function
-    match vs with
+    | LCons (a, b) ->
-    | LCons (LInt a, b) -> (auxi b (accum + a))
+      (match accum, a with
-    | LCons (LDouble a, b) -> (auxf b ((float_of_int accum) +. a))
+       | LInt x , LInt y -> aux (LInt (x + y)) b
-    | _ -> LInt accum
+       | LDouble x, LInt y -> aux (LDouble (x +. (float_of_int y))) b
-  and auxf vs accum =
+       | LInt x, LDouble y -> aux (LDouble ((float_of_int x) +. y)) b
-    match vs with
+       | LDouble x, LDouble y -> aux (LDouble (x +. y)) b
-    | LCons (LInt a, b) -> (auxf b (accum +. (float_of_int a)))
+       | _ -> invalid_arg "invalid args to +")
-    | LCons (LDouble a, b) -> (auxf b (accum +. a))
+    | LNil -> accum
-    | _ -> LDouble accum
+    | _ -> invalid_arg "invalid args to +"
-  in (auxi vs 0);;
+  in aux (LInt 0) vs
-let isub _ vs =
+let sub _ vs =
-  let rec auxi vs accum = 
+  let rec aux accum = function
-    match vs with
+    | LNil -> accum
-    | LNil -> LInt accum
+    | LCons (a, b) -> (match accum, a, b with
-    | LCons (LInt a, b) -> auxi b (accum - a)
+        | LNil, LDouble x, LNil -> LDouble (-. x)
-    | LCons (LDouble a, b) -> auxf b ((float_of_int accum) -. a)
+        | LNil, LInt x, LNil -> LInt (-x)
-    | _ -> raise (Invalid_argument "-: invalid argument to subtraction operator")
+        | LNil, LDouble _, _
-  and auxf vs accum = 
+        | LNil, LInt _, _ -> aux a b
-    match vs with
+        | LInt x, LInt y, _ -> aux (LInt (x - y)) b
-    | LNil -> LDouble accum
+        | LInt x, LDouble y, _ -> aux (LDouble ((float_of_int x) -. y)) b
-    | LCons (LInt a, b) -> auxf b (accum -. (float_of_int a))
+        | LDouble x, LDouble y, _ -> aux (LDouble (x -. y)) b
-    | LCons (LDouble a, b) -> auxf b (accum -. a)
+        | LDouble x, LInt y, _ -> aux (LDouble (x -. (float_of_int y))) b
-    | _ -> raise (Invalid_argument "-: invalid argument to subtraction operator")
+        | _ -> invalid_arg "invalid argument to -")
-  in
+    | _ -> invalid_arg "argument to -"
-  match vs with
+  in aux LNil vs
-  | LCons (LInt a, LNil) -> LInt (-a)
+      
-  | LCons (LInt a, b) -> auxi b a
-  | LCons (LDouble a, LNil) -> LDouble (-. a)
-  | LCons (LDouble a, b) -> auxf b a
-  | _ -> auxi vs 0;;
 
 
 let car _ vs =
@@ -51,30 +47,12 @@ let cons _ vs =
 
 let lisp_list _ vs = vs
 
-
+(* builtin function that updates an existing binding *)
-(* This is the special built-in function that allows us to create
+let lisp_set env = function
-a new function.
-
-(bind-function 'sym '(a b) '(+ a b))
-*)
-
-(* Binds any value to a symbol, in the *global environment*. *)
-let bind_symbol env =
-  function
-  (* Special case for setting a function to a symbol, if the function
-     is a lambda then we turn it into a real "function" by giving it this
-     new name *)
-  | LCons (LQuoted (LSymbol s), LCons (LLambda (e, l, b), LNil))
-  | LCons (LSymbol s, LCons (LLambda (e, l, b), LNil)) ->
-    let f = LFunction (s, e, l, b) in
-    env_set_global env s f;
-    f
-  | LCons (LQuoted (LSymbol s), LCons (v, LNil))
   | LCons (LSymbol s, LCons (v, LNil)) ->
-    env_set_global env s v;
+     Env.update env s v;
-    v
+     v
-  | _ -> raise (Invalid_argument "invalid args to set!")
+  | _ -> invalid_arg "invalid args to set"
-           
 
 let lambda env = function
   | LCons (l, body) ->
@@ -84,3 +62,8 @@ let lambda env = function
 let lambda_macro env = function
   | LCons (l, body) -> LUnnamedMacro (env, l, body)
   | _ -> invalid_arg "invalid args to lambda-macro"
+
+
+let lisp_not _ = function
+  | LCons (LNil, LNil) -> LSymbol "t"
+  | _ -> LNil