Re-organized a lot of code, changed functions so that functions capture the surrounding environment and execute in that environment

lib/ast.ml

@@ -11,32 +11,36 @@ type lisp_val =
   generally, builtin functions should handle their arguments directly,
   and eval forms in the environment as necessary. *)
   | LBuiltinFunction of string * (environment -> lisp_val -> lisp_val)
-  (* a function is a name, a parameter list, and function body. *)
+  (* a function is a name, captured environment, a parameter list, and function body. *)
-  | LFunction of string * lisp_val * lisp_val
+  | LFunction of string * environment * 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
+  | LMacro of string * environment * lisp_val * lisp_val
   | LQuoted of lisp_val
 and environment = (string, lisp_val) Hashtbl.t list
 
 
-let env_add env s v =
+let env_set_local env s v =
   match env with
   | [] -> ()
-  | e1 :: _ ->  Hashtbl.add e1 s v
+  | e1 :: _ ->  Hashtbl.replace e1 s v
 
 let env_new_lexical env = 
   let h = Hashtbl.create 16 in
   h :: env
 
-let rec env_root 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
@@ -48,9 +52,9 @@ let rec dbg_print_one v =
   | LCons (a, b) -> pf "(%s . %s)" (dbg_print_one a) (dbg_print_one b)
   | LDouble d -> pf "<double: %f>" d
   | LBuiltinFunction (name, _) -> pf "<builtin: %s>" name
-  | LFunction (name, args, _) -> pf "<function: '%s' lambda-list: %s>" 
+  | LFunction (name, _, args, _) -> pf "<function: '%s' lambda-list: %s>" 
     name (dbg_print_one args)
-  | LMacro (name, args, _) -> pf "<function '%s' lambda-list: %s>"
+  | 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

@@ -5,7 +5,7 @@ open InterpreterStdlib;;
 let default_env: environment = [Hashtbl.create 1024];;
 
 let add_builtin s f =
-  env_add default_env s (LBuiltinFunction (s, f))
+  env_set_global default_env s (LBuiltinFunction (s, f))
 let () = add_builtin "+" iadd
 let () = add_builtin "-" isub
 let () = add_builtin "car" car
@@ -24,18 +24,11 @@ let rec eval_sym (env: environment) (s: string) =
     | None -> eval_sym rest s
     | Some v -> v
 
-let rec eval_one env v = 
+let rec eval_one env = function
-  match v with
-  | LInt x -> LInt x
-  | LDouble x -> LDouble x
-  | LString s -> LString s
   | LSymbol s -> eval_sym env s
-  | LNil -> LNil
+  | LCons (func, args) -> eval_call env (eval_one env func) args
-  | 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
+  | v -> v (* All other forms are self-evaluating *)
 
 (* Evaluate a list of values, without evaluating the resulting
 function or macro call. Since macros and functions inherently
@@ -50,44 +43,44 @@ and eval_body env body =
   match body with
   | LNil -> LNil
   | LCons (form, LNil) -> eval_one env form
-  | LCons (form, next) -> 
+  | LCons (form, next) -> ignore (eval_one env form); eval_body env next
-    ignore (eval_one env form); eval_body env next
   | _ -> LNil
 
-and eval_apply env func args =
+and err s = raise (Invalid_argument s)
-  let lexical_env = env_new_lexical env in
+and bind_args env = function
-  let rec bind_one s a =
+  | LNil -> (function
-    match a with
+      | LNil -> () | _ -> err "bind_args")
-    | LNil -> raise (Invalid_argument "not enough arguments supplied to function")
+  | LCons (LSymbol hl, tl) -> (function
-    | LCons (value, resta) ->
+      | LCons (ha, ta) -> 
-      env_add lexical_env s value; resta
+        env_set_local env hl ha;
-    | _ -> raise (Invalid_argument "invalid argument list")
+        bind_args env tl ta;
-  and bind_args l a =
+      | _ -> err "bind_args")
-    match l with
+  | _ -> fun _ -> err "bind_args"
-    | LNil -> (match a with
+  
-      | LNil -> ()
+and eval_apply args = function
-      | _ -> raise (Invalid_argument "too many arguments supplied to function"))
+  | LFunction (_, e, l, b) ->
-    | LCons (LSymbol sym, LSymbol restl)->
+    let lexical_env = env_new_lexical e in
-      env_add lexical_env restl (bind_one sym a)
+    bind_args lexical_env l args;
-    | LCons (LSymbol sym, restl) ->
-      bind_args restl (bind_one sym a)
-    | _ -> raise (Invalid_argument "Failure while binding arguments")
-  in match func with
-  | LFunction (_, l, b) ->
-    bind_args l args;
     eval_body lexical_env b
-  | LMacro (_, l, b) ->
+  | LMacro (_, e, l, b) ->
-    bind_args l args;
+    let lexical_env = env_new_lexical e in
+    bind_args lexical_env l args;
     eval_body lexical_env b
-  | _ -> LNil
+  | v ->
+    err ("Non-macro non-function value passed to eval_apply "
+        ^ dbg_print_one v); LNil
     
 
 
 and eval_call env func args =
-  match eval_one env func with
+  match 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)
+  (* The function calls don't happen in the calling environment,
-  | LMacro (n, l, b) -> eval_apply env (LMacro (n, l, b)) args
+  so it makes no sense to pass env to a call. *)
+  | 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
   | v -> raise (Invalid_argument 
         (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)));;
 

lib/interpreterStdlib.ml

@@ -51,11 +51,10 @@ 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
+    let f = (LFunction (sym, env_copy env, ll, body)) in
-    env_add root sym f; f
+    env_set_global env sym f;
-
+    f
   | _ -> rais ()