(* Dan Grossman, CSE505 Fall07, lecture 10 *)
(* disclaimers:
0. we assume there are no free variables in our input program
1. none of this is tested (it does typecheck, but you must compile
with -rectypes)
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)
(* 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_prog = fill_with_exp e_result ctxt in
interp_evalcontext e_new_prog
| _ -> 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 three functions; they are here just to convince
us that stack_context and eval_context are isomorphic! *)
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 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)
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 interp_stack e =
let rec loop c e =
match (c,e) with
(* variables should be substituted away for *)
(_,V _) -> failwith "interp_stack"
(* start an application by working on left (pusing the right) *)
| (_,A(e1,e2)) -> loop (SLeft(e2)::c) e1
(* if I get to here, e must be a value (a lambda) *)
(* nothing on my stack, the whole program is a lambda *)
| ([],_) -> e
(* I was working on the left of an application; now
work on the right *)
| ((SLeft e2) ::tl, e1) -> loop (SRight(e1)::tl) e2
(* I was working on the right, now do the substitution *)
| ((SRight(L(s1,e1))::tl, e2)) -> loop tl (substitute e2 s1 e1)
(* impossible case: SRight always carries a lambda *)
| ((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 (* map variables to values *)
and closure = (string * exp2 * env) (* a value (lambda + environment) *)
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
| (_, V2 s) -> loop c env (Closure(lookup env s))
| (_, A2(e1,e2)) -> loop (SLeft2(e2,env)::c) env e1
| (_, L2(s1,e1)) -> loop c env (Closure(s1,e1,env))
(* If I get to here, e must be a value (a Closure) *)
| ([],Closure _) -> e
| ((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 *)