Added bind-function primitive that allows us to define functions, also changed evaluation to allow for a persistent environment

bin/main.ml

@@ -3,15 +3,15 @@ open Printf;;
 open Lisp;;
 open Eval;;
 open Read;;
-let rec repl c =
+let rec repl env c =
   let () = printf ">>> "; Out_channel.flush Out_channel.stdout; in
   match In_channel.input_line c with
   | None -> ()
   | Some l -> 
     let vals = (parse_str l) in
     (* dbg_print_all vals; *)
-    dbg_print_all (eval_all vals);
+    dbg_print_all (eval_all env vals);
     Out_channel.flush Out_channel.stdout;
-    repl c;;
+    repl env c;;
 
-let _ = repl (In_channel.stdin)
+let _ = repl (make_env ()) (In_channel.stdin)

lib/ast.ml

@@ -13,10 +13,31 @@ type lisp_val =
   | LBuiltinFunction of string * (environment -> lisp_val -> lisp_val)
   (* a function is a name, a parameter list, and function body. *)
   | LFunction of string * lisp_val * lisp_val
+  (* a macro is exactly the same as a function, with the distinction
+  that it receives all of its arguments completely unevaluated
+  in a compiled lisp this would probably make more of a difference *)
+  | LMacro of string * lisp_val * lisp_val
   | LQuoted of lisp_val
 and environment = (string, lisp_val) Hashtbl.t list
 
 
+let env_add env s v =
+  match env with
+  | [] -> ()
+  | e1 :: _ ->  Hashtbl.add e1 s v
+
+let env_new_lexical env = 
+  let h = Hashtbl.create 16 in
+  h :: env
+
+let rec env_root env =
+  match env with
+  | [] -> raise (Invalid_argument "Empty environment passed to env_root!")
+  | e :: [] -> e
+  | _ :: t -> env_root t
+
+
+
 let rec dbg_print_one v =
   let pf = Printf.sprintf in
   match v with
@@ -28,7 +49,9 @@ let rec dbg_print_one v =
   | LDouble d -> pf "<double: %f>" d
   | LBuiltinFunction (name, _) -> pf "<builtin: %s>" name
   | LFunction (name, args, _) -> pf "<function: '%s' lambda-list: %s>" 
-    name ((dbg_print_one args))
+    name (dbg_print_one args)
+  | LMacro (name, args, _) -> pf "<function '%s' lambda-list: %s>"
+    name (dbg_print_one args)
   | LQuoted v -> pf "<quote: %s>" (dbg_print_one v)
   (*| _ -> "<Something else>"*)
 

lib/eval.ml

@@ -4,21 +4,13 @@ open InterpreterStdlib;;
 
 let default_env: environment = [Hashtbl.create 1024];;
 
-let env_add env s v =
-  match env with
-  | [] -> ()
-  | e1 :: _ ->  Hashtbl.add e1 s v
-
-let env_new_lexical env = 
-  let h = Hashtbl.create 16 in
-  h :: env
-
 let add_builtin s f =
   env_add default_env s (LBuiltinFunction (s, f))
 let () = add_builtin "+" iadd
 let () = add_builtin "-" isub
 let () = add_builtin "car" car
 let () = add_builtin "cdr" cdr
+let () = add_builtin "bind-function" bind_function
 
 let make_env () = [Hashtbl.copy (List.hd default_env)]
 
@@ -42,6 +34,7 @@ let rec eval_one env v =
   | LCons (func, args) -> eval_call env func args
   | LBuiltinFunction (n, f) -> LBuiltinFunction (n, f)
   | LFunction (n, l, f) -> LFunction (n, l, f)
+  | LMacro (n, l, f) -> LMacro (n, l, f)
   | LQuoted v -> v
 
 (* Evaluate a list of values, without evaluating the resulting
@@ -83,6 +76,9 @@ and eval_apply env func args =
   | LFunction (_, l, b) ->
     bind_args l args;
     eval_body lexical_env b
+  | LMacro (_, l, b) ->
+    bind_args l args;
+    eval_body lexical_env b
   | _ -> LNil
     
 
@@ -91,10 +87,10 @@ and eval_call env func args =
   match eval_one env func with
   | LBuiltinFunction (_, f) -> f env (eval_list env args)
   | LFunction (n, l, b) -> eval_apply env (LFunction (n, l, b)) (eval_list env args)
+  | LMacro (n, l, b) -> eval_apply env (LMacro (n, l, b)) args
   | v -> raise (Invalid_argument 
         (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)));;
 
-let eval_all vs =
-  let env = make_env () in
+let eval_all env vs =
   let ev v = eval_one env v in
   List.map ev vs

lib/interpreterStdlib.ml

@@ -44,3 +44,18 @@ let cdr _ vs =
   | LCons (LCons (_, b), LNil) -> b
   | _ -> raise (Invalid_argument "cdr: invalid argument")
 
+
+(* This is the special built-in function that allows us to create
+a new function. 
+
+(bind-function 'sym '(a b) '(+ a b))
+*)
+let bind_function env vs =
+  let root = [env_root env] in
+  let rais () = raise (Invalid_argument "not enough args to bind-function") in
+  match vs with
+  | LCons (LSymbol sym, LCons (ll, body)) ->
+    let f = (LFunction (sym, ll, body)) in
+    env_add root sym f; f
+
+  | _ -> rais ()