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

.gitignore

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

lib/ast.ml

@@ -19,31 +19,13 @@ type lisp_val =
   that it receives all of its arguments completely unevaluated
   in a compiled lisp this would probably make more of a difference *)
   | 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
@@ -59,7 +41,9 @@ let rec dbg_print_one v =
     (dbg_print_one args)
   | LFunction (name, _, args, _) -> pf "<function: '%s' lambda-list: %s>" 
     name (dbg_print_one args)
-  | LMacro (name, _, args, _) -> pf "<function '%s' lambda-list: %s>"
+  | LUnnamedMacro (_, args, _) -> pf "<unnamed macro, lambda-list: %s>"
+    (dbg_print_one args)
+  | LMacro (name, _, args, _) -> pf "<macro '%s' lambda-list: %s>"
     name (dbg_print_one args)
   | LQuoted v -> pf "<quote: %s>" (dbg_print_one v)
   (*| _ -> "<Something else>"*)

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,17 +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 () = add_builtin "+" iadd
-let () = add_builtin "-" isub
-let () = add_builtin "car" car
-let () = add_builtin "cdr" cdr
-let () = add_builtin "bind-symbol" bind_symbol 
-let () = add_special "lambda" lambda
 
-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 *)
@@ -49,30 +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 -> () | _ -> err "bind_args")
+  | (LSymbol s, v) -> Env.set_local env s v
-  | LCons (LSymbol hl, tl) -> (function
+  | (LCons (LSymbol hl, tl), LCons (ha, ta)) -> Env.set_local env hl ha; bind_args env (tl, ta)
-      | LCons (ha, ta) -> 
+  | _ -> invalid_arg "cannot bind argument list for function"
-        env_set_local env hl ha;
-        bind_args env tl ta;
-      | _ -> err "bind_args")
-  | _ -> 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)
     
 
 
@@ -86,10 +76,85 @@ and eval_call env func args =
   | LFunction _ -> eval_apply (eval_list env args) func
   (* Macros are the same, they just return code that *will* be evaluated
   in the calling environment *)
-  | LMacro _ -> eval_apply args func
+  | LUnnamedMacro _
+  | LMacro _ -> eval_one env (eval_apply args func)
   | v -> raise (Invalid_argument 
-        (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)));;
+                  (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))
+
+ (* This only creates a *local* binding, contained to the body given. *)
+let bind_local env = function
+  | LCons (LSymbol s, LCons (v, body)) ->
+    let e = Env.new_lexical env in
+    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 "+" add
+let () = add_builtin "-" sub
+let () = add_builtin "car" car
+let () = add_builtin "cdr" cdr
+let () = add_builtin "cons" cons
+let () = add_special "def" lisp_define
+let () = add_builtin "set" lisp_set
+let () = add_builtin "list" lisp_list
+let () = add_special "fn" lambda
+let () = add_special "fn-macro" lambda_macro
+let () = add_special "let-one" bind_local
+let () = add_special "quote" (fun _ -> function
+             | LCons (x, LNil) -> x
+             | _ -> 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.
+   Idea: maybe put this in a file instead of putting
+   literally the entire standard library in a constant string
+ *)
+let _ = eval_all default_env (Read.parse_str
+"
+(def defn
+  (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 =
@@ -44,29 +40,30 @@ let cdr _ vs =
   | LCons (LCons (_, b), LNil) -> b
   | _ -> raise (Invalid_argument "cdr: invalid argument")
 
+let cons _ vs =
+  match vs with
+  | LCons (a, LCons (b, LNil)) -> LCons (a, b)
+  | _ -> invalid_arg "invalid args to cons!"
 
-(* This is the special built-in function that allows us to create
+let lisp_list _ vs = vs
-a new function.
 
-(bind-function 'sym '(a b) '(+ a b))
+(* builtin function that updates an existing binding *)
-*)
+let lisp_set env = function
-
-(* 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 (LSymbol s, LCons (LLambda (e, l, b), LNil)) ->
-    let f = LFunction (s, e, l, b) in
-    env_set_global env s f;
-    f
   | 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) ->
     LLambda (env, l, body)
   | _ -> raise (Invalid_argument "invalid args to lambda!")
+
+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

lib/lexer.mll

@@ -11,7 +11,6 @@ let number_sign = '-' | '+'
 let int = number_sign? digit+
 let double = digit* '.' digit+ | digit+ '.' digit*
 
-
 let white = [' ' '\t']+
 let newline = '\r' | '\n' | "\r\n"
 
@@ -31,5 +30,6 @@ rule read =
     | '(' { LPAREN }
     | ')' { RPAREN }
     | '\'' { QUOTE }
+    | '.' { DOT }
     | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf))}
     | eof { EOF }

lib/parser.mly

@@ -9,6 +9,7 @@
 %token LPAREN
 %token RPAREN
 %token QUOTE
+%token DOT
 %token EOF
 
 %start <Ast.lisp_val option> prog
@@ -25,10 +26,11 @@ expr:
   | s = SYM { LSymbol s }
   | s = STR { LString (String.uppercase_ascii s) }
   | LPAREN; l = lisp_list_rest { l }
-  | QUOTE; e = expr { LQuoted e}
+  | QUOTE; e = expr { LCons (LSymbol "quote", LCons (e, LNil)) }
 ;
 
 lisp_list_rest:
   | RPAREN { LNil }
+  | DOT; e = expr; RPAREN { e }
   | e = expr; lr = lisp_list_rest { LCons (e, lr) }
 ;