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

This commit is contained in:
Emin Arslan
2025-10-12 21:58:54 +03:00
committed by Emin Arslan
parent aa066f87d0
commit a905ab2b42
4 changed files with 50 additions and 16 deletions

View File

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

View File

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

View File

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

View File

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