Compare commits
3 Commits
37c8d2a62a
...
46a1553dac
| Author | SHA1 | Date | |
|---|---|---|---|
| 46a1553dac | |||
| 4d440dc1d7 | |||
| d24f8dc77f |
1
.gitignore
vendored
1
.gitignore
vendored
@@ -1 +1,2 @@
|
|||||||
_build
|
_build
|
||||||
|
*~
|
||||||
|
|||||||
31
lib/ast.ml
31
lib/ast.ml
@@ -21,38 +21,11 @@ type lisp_val =
|
|||||||
| LMacro of string * environment * lisp_val * lisp_val
|
| LMacro of string * environment * lisp_val * lisp_val
|
||||||
| LUnnamedMacro of environment * lisp_val * lisp_val
|
| LUnnamedMacro of environment * lisp_val * lisp_val
|
||||||
| LQuoted of lisp_val
|
| LQuoted of lisp_val
|
||||||
|
(* the environment type needs to be defined here, as it is mutually
|
||||||
|
recursive with lisp_val *)
|
||||||
and environment = (string, lisp_val) Hashtbl.t list
|
and environment = (string, lisp_val) Hashtbl.t list
|
||||||
|
|
||||||
|
|
||||||
let env_set_local env s v =
|
|
||||||
match env with
|
|
||||||
| [] -> ()
|
|
||||||
| e1 :: _ -> Hashtbl.replace e1 s v
|
|
||||||
|
|
||||||
let rec env_update env s v =
|
|
||||||
match env with
|
|
||||||
| [] -> ()
|
|
||||||
| e1 :: erest ->
|
|
||||||
match Hashtbl.find_opt e1 s with
|
|
||||||
| None -> env_update erest s v
|
|
||||||
| Some _ -> Hashtbl.replace e1 s v
|
|
||||||
|
|
||||||
let env_new_lexical env =
|
|
||||||
let h = Hashtbl.create 16 in
|
|
||||||
h :: 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 rec dbg_print_one v =
|
||||||
let pf = Printf.sprintf in
|
let pf = Printf.sprintf in
|
||||||
match v with
|
match v with
|
||||||
|
|||||||
34
lib/env.ml
Normal file
34
lib/env.ml
Normal file
@@ -0,0 +1,34 @@
|
|||||||
|
open Ast
|
||||||
|
(* the type `environment` is defined in Ast *)
|
||||||
|
|
||||||
|
|
||||||
|
let new_lexical env =
|
||||||
|
let h = Hashtbl.create 16 in
|
||||||
|
h :: env
|
||||||
|
|
||||||
|
let set_local env s v =
|
||||||
|
match env with
|
||||||
|
| [] -> ()
|
||||||
|
| e1 :: _ -> Hashtbl.replace e1 s v
|
||||||
|
|
||||||
|
let rec update env s v =
|
||||||
|
match env with
|
||||||
|
| [] -> ()
|
||||||
|
| e1 :: erest ->
|
||||||
|
match Hashtbl.find_opt e1 s with
|
||||||
|
| None -> update erest s v
|
||||||
|
| Some _ -> Hashtbl.replace e1 s v
|
||||||
|
|
||||||
|
let rec get_root (env : environment) =
|
||||||
|
match env with
|
||||||
|
| [] -> raise (Invalid_argument "Empty environment passed to env_root!")
|
||||||
|
| e :: [] -> e
|
||||||
|
| _ :: t -> get_root t
|
||||||
|
|
||||||
|
let set_global env s v =
|
||||||
|
Hashtbl.replace (get_root env) s v
|
||||||
|
|
||||||
|
let copy env =
|
||||||
|
List.map Hashtbl.copy env
|
||||||
|
|
||||||
|
|
||||||
20
lib/eval.ml
20
lib/eval.ml
@@ -5,11 +5,11 @@ open InterpreterStdlib;;
|
|||||||
let default_env: environment = [Hashtbl.create 1024];;
|
let default_env: environment = [Hashtbl.create 1024];;
|
||||||
|
|
||||||
let add_builtin s f =
|
let add_builtin s f =
|
||||||
env_set_global default_env s (LBuiltinFunction (s, f))
|
Env.set_global default_env s (LBuiltinFunction (s, f))
|
||||||
let add_special s f =
|
let add_special s f =
|
||||||
env_set_global default_env s (LBuiltinSpecial (s, f))
|
Env.set_global default_env s (LBuiltinSpecial (s, f))
|
||||||
|
|
||||||
let make_env () = [Hashtbl.copy (List.hd default_env)]
|
let make_env () = Env.copy default_env
|
||||||
|
|
||||||
(* the type annotations are unnecessary, but help constrain us from a
|
(* the type annotations are unnecessary, but help constrain us from a
|
||||||
potentially more general function here *)
|
potentially more general function here *)
|
||||||
@@ -50,10 +50,10 @@ and bind_args env = function
|
|||||||
| _ -> err "cannot bind arguments")
|
| _ -> err "cannot bind arguments")
|
||||||
| LSymbol s ->
|
| LSymbol s ->
|
||||||
(function
|
(function
|
||||||
| v -> env_set_local env s v; ())
|
| v -> Env.set_local env s v; ())
|
||||||
| LCons (LSymbol hl, tl) -> (function
|
| LCons (LSymbol hl, tl) -> (function
|
||||||
| LCons (ha, ta) ->
|
| LCons (ha, ta) ->
|
||||||
env_set_local env hl ha;
|
Env.set_local env hl ha;
|
||||||
bind_args env tl ta;
|
bind_args env tl ta;
|
||||||
| _ -> err "cannot bind arguments")
|
| _ -> err "cannot bind arguments")
|
||||||
| _ -> fun _ -> err "bind_args"
|
| _ -> fun _ -> err "bind_args"
|
||||||
@@ -61,12 +61,12 @@ and bind_args env = function
|
|||||||
and eval_apply args = function
|
and eval_apply args = function
|
||||||
| LLambda (e, l, b)
|
| LLambda (e, l, b)
|
||||||
| LFunction (_, e, l, b) ->
|
| LFunction (_, e, l, b) ->
|
||||||
let lexical_env = env_new_lexical e in
|
let lexical_env = Env.new_lexical e in
|
||||||
bind_args lexical_env l args;
|
bind_args lexical_env l args;
|
||||||
eval_body lexical_env b
|
eval_body lexical_env b
|
||||||
| LUnnamedMacro (e, l, b)
|
| LUnnamedMacro (e, l, b)
|
||||||
| LMacro (_, e, l, b) ->
|
| LMacro (_, e, l, b) ->
|
||||||
let lexical_env = env_new_lexical e in
|
let lexical_env = Env.new_lexical e in
|
||||||
bind_args lexical_env l args;
|
bind_args lexical_env l args;
|
||||||
eval_body lexical_env b
|
eval_body lexical_env b
|
||||||
| v ->
|
| v ->
|
||||||
@@ -93,8 +93,8 @@ and eval_call env func args =
|
|||||||
and (* This only creates a *local* binding, contained to the body given. *)
|
and (* This only creates a *local* binding, contained to the body given. *)
|
||||||
bind_local env = function
|
bind_local env = function
|
||||||
| LCons (LSymbol s, LCons (v, body)) ->
|
| LCons (LSymbol s, LCons (v, body)) ->
|
||||||
let e = env_new_lexical env in
|
let e = Env.new_lexical env in
|
||||||
env_set_local e s v;
|
Env.set_local e s v;
|
||||||
eval_body e body
|
eval_body e body
|
||||||
| _ -> invalid_arg "invalid argument to bind-local"
|
| _ -> invalid_arg "invalid argument to bind-local"
|
||||||
|
|
||||||
@@ -102,7 +102,7 @@ and (* This only creates a *local* binding, contained to the body given. *)
|
|||||||
and lisp_define env = function
|
and lisp_define env = function
|
||||||
| LCons (LSymbol s, LCons (v, LNil)) ->
|
| LCons (LSymbol s, LCons (v, LNil)) ->
|
||||||
let evaluated = eval_one env v in
|
let evaluated = eval_one env v in
|
||||||
env_set_global env s evaluated;
|
Env.set_global env s evaluated;
|
||||||
evaluated
|
evaluated
|
||||||
| _ -> invalid_arg "invalid args to def"
|
| _ -> invalid_arg "invalid args to def"
|
||||||
|
|
||||||
|
|||||||
@@ -50,7 +50,7 @@ let lisp_list _ vs = vs
|
|||||||
(* builtin function that updates an existing binding *)
|
(* builtin function that updates an existing binding *)
|
||||||
let lisp_set env = function
|
let lisp_set env = function
|
||||||
| LCons (LSymbol s, LCons (v, LNil)) ->
|
| LCons (LSymbol s, LCons (v, LNil)) ->
|
||||||
env_update env s v;
|
Env.update env s v;
|
||||||
v
|
v
|
||||||
| _ -> invalid_arg "invalid args to set"
|
| _ -> invalid_arg "invalid args to set"
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user