From 22e7c3dbb3561f9ecbe7c886614360ba32d41d72 Mon Sep 17 00:00:00 2001 From: Emin Arslan <53535669+haxala1r@users.noreply.github.com> Date: Tue, 14 Oct 2025 20:21:29 +0300 Subject: [PATCH] Re-organized a lot of code, changed functions so that functions capture the surrounding environment and execute in that environment --- lib/ast.ml | 20 ++++++----- lib/eval.ml | 73 ++++++++++++++++++---------------------- lib/interpreterStdlib.ml | 7 ++-- 3 files changed, 48 insertions(+), 52 deletions(-) diff --git a/lib/ast.ml b/lib/ast.ml index 0685fba..8c4cfaf 100644 --- a/lib/ast.ml +++ b/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. *) - | LFunction of string * lisp_val * lisp_val + (* a function is a name, captured environment, a parameter list, and function body. *) + | 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 "" d | LBuiltinFunction (name, _) -> pf "" name - | LFunction (name, args, _) -> pf "" + | LFunction (name, _, args, _) -> pf "" name (dbg_print_one args) - | LMacro (name, args, _) -> pf "" + | LMacro (name, _, args, _) -> pf "" name (dbg_print_one args) | LQuoted v -> pf "" (dbg_print_one v) (*| _ -> ""*) diff --git a/lib/eval.ml b/lib/eval.ml index c985313..5478fd3 100644 --- a/lib/eval.ml +++ b/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 = - match v with - | LInt x -> LInt x - | LDouble x -> LDouble x - | LString s -> LString s +let rec eval_one env = function | LSymbol s -> eval_sym env s - | LNil -> LNil - | 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) + | LCons (func, args) -> eval_call env (eval_one env func) args | 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) -> - ignore (eval_one env form); eval_body env next + | LCons (form, next) -> ignore (eval_one env form); eval_body env next | _ -> LNil -and eval_apply env func args = - let lexical_env = env_new_lexical env in - let rec bind_one s a = - match a with - | LNil -> raise (Invalid_argument "not enough arguments supplied to function") - | LCons (value, resta) -> - env_add lexical_env s value; resta - | _ -> raise (Invalid_argument "invalid argument list") - and bind_args l a = - match l with - | LNil -> (match a with - | LNil -> () - | _ -> raise (Invalid_argument "too many arguments supplied to function")) - | LCons (LSymbol sym, LSymbol restl)-> - env_add lexical_env restl (bind_one sym a) - | 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; +and err s = raise (Invalid_argument s) +and bind_args env = function + | LNil -> (function + | LNil -> () | _ -> err "bind_args") + | LCons (LSymbol hl, tl) -> (function + | LCons (ha, ta) -> + env_set_local env hl ha; + bind_args env tl ta; + | _ -> err "bind_args") + | _ -> fun _ -> err "bind_args" + +and eval_apply args = function + | LFunction (_, e, l, b) -> + let lexical_env = env_new_lexical e in + bind_args lexical_env l args; eval_body lexical_env b - | LMacro (_, l, b) -> - bind_args l args; + | LMacro (_, e, l, b) -> + 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) - | LMacro (n, l, b) -> eval_apply env (LMacro (n, l, b)) args + (* The function calls don't happen in the calling environment, + 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)));; diff --git a/lib/interpreterStdlib.ml b/lib/interpreterStdlib.ml index 3757970..cf89bed 100644 --- a/lib/interpreterStdlib.ml +++ b/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 - env_add root sym f; f - + let f = (LFunction (sym, env_copy env, ll, body)) in + env_set_global env sym f; + f | _ -> rais ()