(* disclaimers: 0. we assume there are no free variables in our input program 1. none of this is tested (it does typecheck) 2. the capture-avoiding substitution is brutally inefficient; there are much better ways 3. we assume in a few places that the only values are lambdas, which is true for our tiniest calculus *) (* definition of syntax and substitution *) type exp = V of string | L of string * exp | A of exp * exp let new_string = let i = ref 0 in (fun () -> i := (!i)+1; "__" ^ (string_of_int !i)) let rec rename old_s new_s e = let r = rename old_s new_s in match e with V s -> if old_s=s then V new_s else e | L (s,e') -> if s=old_s then e else L(s, r e') | A (e1,e2) -> A(r e1, r e2) let rec substitute e_for s in_e = let r = substitute e_for s in match in_e with V s2 -> if s2=s then e_for else in_e | L (s,e') -> let new_s = new_string() in L(new_s, r (rename s new_s e')) | A(e1,e2) -> A(r e1, r e2) (* version 1: plain-old small-step semantics *) let rec interp_one e = match e with V _ -> failwith "interp_one" | L _ -> failwith "interp_one" | A(L(s1,e1),L(s2,e2)) -> substitute (L(s2,e2)) s1 e1 | A(L(s1,e1),e2) -> A(L(s1,e1),interp_one e2) | A(e1,e2) -> A(interp_one e1, e2) let rec interp_small e = match e with V _ -> failwith "interp_small" | L _ -> e | A(_,_) -> interp_small (interp_one e) (* definition of evaluation contexts and hole-filling *) type eval_context = Hole | Left of eval_context * exp | Right of exp * eval_context (* exp should actually be a value *) let rec fill_with_exp e c = let r = fill_with_exp e in match c with Hole -> e | Left(c2,e2) -> A(r c2, e2) | Right(e2,c2) -> A(e2, r c2) let rec fill_with_context c1 c2 = let r = fill_with_context c1 in match c2 with Hole -> c1 | Left(c3,e) -> Left(r c3, e) | Right(e,c3) -> Right(e, r c3) (* version 2: decompose at each step *) let rec decompose e = match e with V _ -> failwith "decompose" | L _ -> failwith "decompose" | A(L(s1,e1),L(s2,e2)) -> (Hole,e) | A(L(s1,e1),e2) -> let (c,e3) = decompose e2 in (Right(L(s1,e1),c), e3) | A(e1,e2) -> let (c,e3) = decompose e1 in (Left(c,e2),e3) let rec interp_evalcontext e = match e with V _ -> failwith "interp_evalcontext" | L _ -> e | A(_,_) -> let (ctxt,e_active) = decompose e in match e_active with A(L(s1,e1),L(s2,e2)) -> let e_result = substitute (L(s2,e2)) s1 e1 in let e_new_whole = fill_with_exp e_result ctxt in interp_evalcontext e_new_whole | _ -> failwith "interp_evalcontext" (* version 3: use a stack instead of "nested holes" to avoid re-decomposing *) type stack_context_elt = SLeft of exp | SRight of exp (* exp should actually be a value *) type stack_context = stack_context_elt list (* shallow end of stack at beginning of list *) (* we do not need these next two functions; they are here just to convince us that stack_context and eval_context are isomorphic! *) let rec stack_to_eval_context stack = match stack with [] -> Hole | (SLeft(e))::tl -> fill_with_context (Left(Hole,e)) (stack_to_eval_context tl) | (SRight(e))::tl -> fill_with_context (Right(e,Hole)) (stack_to_eval_context tl) let eval_context_to_stack ctxt = let rec r ctxt = match ctxt with Hole -> [] | Left(c2,e) -> SLeft(e)::(r c2) | Right(e,c2) -> SRight(e)::(r c2) in List.rev(r ctxt) let interp_stack e = let rec loop c e = match (c,e) with ([],V _) -> failwith "interp_stack" | ([],L _) -> e | (_,A(e1,e2)) -> loop (SLeft(e2)::c) e1 | ((SLeft e2)::tl,e1) -> loop (SRight(e1)::tl) e2 | ((SRight(L(s1,e1))::tl,e2)) -> loop tl (substitute e2 s1 e1) | ((SRight _)::_, _) -> failwith "interp_stack" in loop [] e (* version 4: use environments instead of substitution *) (* must compile with -rectypes (or use a datatype) *) type env = (string * closure) list and closure = (string * exp2 * env) and exp2 = V2 of string | L2 of string * exp2 | A2 of exp2 * exp2 | Closure of closure let rec exp_to_exp2 e = match e with V s -> V2 s | L(s,e) -> L2(s,exp_to_exp2 e) | A(e1,e2) -> A2(exp_to_exp2 e1, exp_to_exp2 e2) type stack_context_elt2 = SLeft2 of exp2 * env | SRight2 of exp2 (* exp should actually be a value (a closure) *) type stack_context2 = stack_context_elt2 list let rec lookup env s = match env with [] -> failwith "lookup" | ((s2,closure)::tl) -> if s2=s then closure else lookup tl s let interp_closure e = let rec loop c env e = match (c,e) with | ([],Closure _) -> e | (_,V2 s) -> loop c env (Closure (lookup env s)) | (_,L2(s1,e1)) -> loop c env (Closure(s1,e1,env)) | (_,A2(e1,e2)) -> loop (SLeft2(e2,env)::c) env e1 | ((SLeft2 (e2,env2))::tl,e1) -> loop (SRight2(e1)::tl) env2 e2 | ((SRight2(Closure(s1,e1,env1))::tl), Closure(s2,e2,env2)) -> loop tl ((s1,(s2,e2,env2))::env1) e1 (* env1, not env!!! *) | ((SRight2 _)::_, _) -> failwith "interp_closure" in loop [] [] (exp_to_exp2 e) (* notice everything in interp_closure is tail-recursive (trivial to translate to a while-loop *)