Added type annotations for the environment module to make things clearer, switched bind_args implementation with a simpler one.
This commit is contained in:
		
							
								
								
									
										11
									
								
								lib/env.ml
									
									
									
									
									
								
							
							
						
						
									
										11
									
								
								lib/env.ml
									
									
									
									
									
								
							@@ -1,17 +1,16 @@
 | 
				
			|||||||
open Ast
 | 
					open Ast
 | 
				
			||||||
(* the type `environment` is defined in Ast *)
 | 
					(* the type `environment` is defined in Ast *)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					let new_lexical (env : environment) : environment = 
 | 
				
			||||||
let new_lexical env = 
 | 
					 | 
				
			||||||
  let h = Hashtbl.create 16 in
 | 
					  let h = Hashtbl.create 16 in
 | 
				
			||||||
  h :: env
 | 
					  h :: env
 | 
				
			||||||
 | 
					
 | 
				
			||||||
let set_local env s v =
 | 
					let set_local (env : environment) (s : string) (v : lisp_val) : unit =
 | 
				
			||||||
  match env with
 | 
					  match env with
 | 
				
			||||||
  | [] -> ()
 | 
					  | [] -> ()
 | 
				
			||||||
  | e1 :: _ -> Hashtbl.replace e1 s v
 | 
					  | e1 :: _ -> Hashtbl.replace e1 s v
 | 
				
			||||||
 | 
					
 | 
				
			||||||
let rec update env s v =
 | 
					let rec update (env : environment) s v =
 | 
				
			||||||
  match env with
 | 
					  match env with
 | 
				
			||||||
  | [] -> ()
 | 
					  | [] -> ()
 | 
				
			||||||
  | e1 :: erest ->
 | 
					  | e1 :: erest ->
 | 
				
			||||||
@@ -25,10 +24,10 @@ let rec get_root (env : environment) =
 | 
				
			|||||||
  | e :: [] -> e
 | 
					  | e :: [] -> e
 | 
				
			||||||
  | _ :: t -> get_root t
 | 
					  | _ :: t -> get_root t
 | 
				
			||||||
 | 
					
 | 
				
			||||||
let set_global env s v =
 | 
					let set_global (env : environment) s v =
 | 
				
			||||||
  Hashtbl.replace (get_root env) s v
 | 
					  Hashtbl.replace (get_root env) s v
 | 
				
			||||||
 | 
					
 | 
				
			||||||
let copy env =
 | 
					let copy (env : environment) : environment =
 | 
				
			||||||
  List.map Hashtbl.copy env
 | 
					  List.map Hashtbl.copy env
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 
 | 
				
			|||||||
							
								
								
									
										33
									
								
								lib/eval.ml
									
									
									
									
									
								
							
							
						
						
									
										33
									
								
								lib/eval.ml
									
									
									
									
									
								
							@@ -43,35 +43,26 @@ and eval_body env body =
 | 
				
			|||||||
  | 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
 | 
					  | _ -> LNil
 | 
				
			||||||
 | 
					
 | 
				
			||||||
and err s = raise (Invalid_argument s)
 | 
					 | 
				
			||||||
and bind_args env = function
 | 
					and bind_args env = function
 | 
				
			||||||
  | LNil -> (function
 | 
					  | (LNil, LNil) -> ()
 | 
				
			||||||
      | LNil -> ()
 | 
					  | (LSymbol s, v) -> Env.set_local env s v
 | 
				
			||||||
      | _ -> err "cannot bind arguments")
 | 
					  | (LCons (LSymbol hl, tl), LCons (ha, ta)) -> Env.set_local env hl ha; bind_args env (tl, ta)
 | 
				
			||||||
  | LSymbol s ->
 | 
					  | _ -> invalid_arg "cannot bind argument list for function"
 | 
				
			||||||
    (function
 | 
					 | 
				
			||||||
      | v -> Env.set_local env s v; ())
 | 
					 | 
				
			||||||
  | LCons (LSymbol hl, tl) -> (function
 | 
					 | 
				
			||||||
      | LCons (ha, ta) -> 
 | 
					 | 
				
			||||||
        Env.set_local env hl ha;
 | 
					 | 
				
			||||||
        bind_args env tl ta;
 | 
					 | 
				
			||||||
      | _ -> err "cannot bind arguments")
 | 
					 | 
				
			||||||
  | _ -> fun _ -> err "bind_args"
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
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 ->
 | 
				
			||||||
    err ("Non-macro non-function value passed to eval_apply "
 | 
					    invalid_arg ("Non-macro non-function value passed to eval_apply "
 | 
				
			||||||
        ^ dbg_print_one v); LNil
 | 
					        ^ dbg_print_one v)
 | 
				
			||||||
    
 | 
					    
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					
 | 
				
			||||||
@@ -90,8 +81,8 @@ and eval_call env func args =
 | 
				
			|||||||
  | v -> raise (Invalid_argument 
 | 
					  | v -> raise (Invalid_argument 
 | 
				
			||||||
                  (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))
 | 
					                  (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
and (* This only creates a *local* binding, contained to the body given. *)
 | 
					 (* This only creates a *local* binding, contained to the body given. *)
 | 
				
			||||||
  bind_local env = function
 | 
					let 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;
 | 
				
			||||||
@@ -99,14 +90,14 @@ and (* This only creates a *local* binding, contained to the body given. *)
 | 
				
			|||||||
  | _ -> invalid_arg "invalid argument to bind-local"
 | 
					  | _ -> invalid_arg "invalid argument to bind-local"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(* special form that creates a global binding *)
 | 
					(* special form that creates a global binding *)
 | 
				
			||||||
and lisp_define env = function
 | 
					let 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"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
and lisp_if env = function
 | 
					let lisp_if env = function
 | 
				
			||||||
  | LCons (cond, LCons (if_true, LNil)) ->
 | 
					  | LCons (cond, LCons (if_true, LNil)) ->
 | 
				
			||||||
    (match eval_one env cond with
 | 
					    (match eval_one env cond with
 | 
				
			||||||
     | LNil -> LNil
 | 
					     | LNil -> LNil
 | 
				
			||||||
 
 | 
				
			|||||||
		Reference in New Issue
	
	Block a user