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

This commit is contained in:
Emin Arslan
2025-10-14 20:21:29 +03:00
committed by Emin Arslan
parent 965804c18d
commit 22e7c3dbb3
3 changed files with 48 additions and 52 deletions

View File

@@ -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 "<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>"*)

View File

@@ -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)));;

View File

@@ -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 ()