2019-11-27 09:06:31 -06:00

431 lines
12 KiB
OCaml

open Mini_c
(* Reference implementation:
https://www.cs.cornell.edu/courses/cs3110/2019sp/textbook/interp/lambda-subst/main.ml
...but, it has at least one bug: in subst,
`let new_body = replace e' y fresh in ...` should be:
`let new_body = replace e' fresh y in ...`,
due to the arg order choice for replace.
Below, this bug is fixed by adopting the other order choice for
replace (as well as subst). *)
(* replace in `e` the variable `x` with `y`.
It would be fine -- better? -- to only replace the _free_ x.
*)
let rec replace : expression -> var_name -> var_name -> expression =
fun e x y ->
let replace e = replace e x y in
let return content = { e with content } in
let replace_var v =
if Var.equal v x
then y
else v in
match e.content with
| E_literal _ -> e
| E_closure { binder ; body } ->
let body = replace body in
let binder = replace_var binder in
return @@ E_closure { binder ; body }
| E_skip -> e
| E_constant (c, args) ->
let args = List.map replace args in
return @@ E_constant (c, args)
| E_application (f, x) ->
let (f, x) = Tuple.map2 replace (f, x) in
return @@ E_application (f, x)
| E_variable z ->
let z = replace_var z in
return @@ E_variable z
| E_make_empty_map _ -> e
| E_make_empty_big_map _ -> e
| E_make_empty_list _ -> e
| E_make_empty_set _ -> e
| E_make_none _ -> e
| E_iterator (name, ((v, tv), body), expr) ->
let body = replace body in
let expr = replace expr in
let v = replace_var v in
return @@ E_iterator (name, ((v, tv), body), expr)
| E_fold (((v, tv), body), collection, initial) ->
let body = replace body in
let collection = replace collection in
let initial = replace initial in
let v = replace_var v in
return @@ E_fold (((v, tv), body), collection, initial)
| E_if_bool (c, bt, bf) ->
let c = replace c in
let bt = replace bt in
let bf = replace bf in
return @@ E_if_bool (c, bt, bf)
| E_if_none (c, bt, ((v, tv), bf)) ->
let c = replace c in
let bt = replace bt in
let bf = replace bf in
let v = replace_var v in
return @@ E_if_none (c, bt, ((v, tv), bf))
| E_if_cons (c, bf, (((v1, tv1), (v2, tv2)), bt)) ->
let c = replace c in
let bf = replace bf in
let v1 = replace_var v1 in
let v2 = replace_var v2 in
let bt = replace bt in
return @@ E_if_cons (c, bf, (((v1, tv1), (v2, tv2)), bt))
| E_if_left (c, ((v1, tv1), bt), ((v2, tv2), bf)) ->
let c = replace c in
let bf = replace bf in
let v1 = replace_var v1 in
let v2 = replace_var v2 in
let bt = replace bt in
return @@ E_if_left (c, ((v1, tv1), bt), ((v2, tv2), bf))
| E_let_in ((v, tv), e1, e2) ->
let v = replace_var v in
let e1 = replace e1 in
let e2 = replace e2 in
return @@ E_let_in ((v, tv), e1, e2)
| E_sequence (e1, e2) ->
let e1 = replace e1 in
let e2 = replace e2 in
return @@ E_sequence (e1, e2)
| E_assignment (v, path, e) ->
let v = replace_var v in
let e = replace e in
return @@ E_assignment (v, path, e)
| E_while (cond, body) ->
let cond = replace cond in
let body = replace body in
return @@ E_while (cond, body)
(**
Computes `body[x := expr]`.
This raises Bad_argument in the case of assignments with a name clash. (`x <- 42[x := 23]` makes no sense.)
**)
exception Bad_argument
let rec subst_expression : body:expression -> x:var_name -> expr:expression -> expression =
fun ~body ~x ~expr ->
let self body = subst_expression ~body ~x ~expr in
let subst_binder y expr' =
(* if x is shadowed, binder doesn't change *)
if Var.equal x y
then (y, expr')
(* else, if no capture, subst in binder *)
else if not (Free_variables.mem y (Free_variables.expression [] expr))
then (y, self expr')
(* else, avoid capture and subst in binder *)
else
let fresh = Var.fresh_like y in
let new_body = replace expr' y fresh in
(fresh, self new_body) in
(* hack to avoid reimplementing subst_binder for 2-ary binder in E_if_cons:
intuitively, we substitute in \hd tl. expr' as if it were \hd. \tl. expr *)
let subst_binder2 y z expr' =
let dummy = T_base Base_unit in
let hack = { content = E_closure { binder = z ; body = expr' } ;
type_value = dummy } in
match subst_binder y hack with
| (y', { content = E_closure { binder = z' ; body = body } ; type_value = _dummy }) ->
(y', z', { body with type_value = expr'.type_value })
| _ -> assert false in
let return content = {body with content} in
let return_id = body in
match body.content with
| E_variable x' ->
if x' = x
then expr
else return_id
| E_closure { binder; body } -> (
let (binder, body) = subst_binder binder body in
return @@ E_closure { binder ; body }
)
| E_let_in ((v , tv) , expr , body) -> (
let expr = self expr in
let (v, body) = subst_binder v body in
return @@ E_let_in ((v , tv) , expr , body)
)
| E_iterator (s, ((name , tv) , body) , collection) -> (
let (name, body) = subst_binder name body in
let collection = self collection in
return @@ E_iterator (s, ((name , tv) , body) , collection)
)
| E_fold (((name , tv) , body) , collection , init) -> (
let (name, body) = subst_binder name body in
let collection = self collection in
let init = self init in
return @@ E_fold (((name , tv) , body) , collection , init)
)
| E_if_none (c, n, ((name, tv) , s)) -> (
let c = self c in
let n = self n in
let (name, s) = subst_binder name s in
return @@ E_if_none (c, n, ((name, tv) , s))
)
| E_if_cons (c, n, (((hd, hdtv) , (tl, tltv)) , cons)) -> (
let c = self c in
let n = self n in
let (hd, tl, cons) = subst_binder2 hd tl cons in
return @@ E_if_cons (c, n, (((hd, hdtv) , (tl, tltv)) , cons))
)
| E_if_left (c, ((name_l, tvl) , l), ((name_r, tvr) , r)) -> (
let c = self c in
let (name_l, l) = subst_binder name_l l in
let (name_r, r) = subst_binder name_r r in
return @@ E_if_left (c, ((name_l, tvl) , l), ((name_r, tvr) , r))
)
(* All that follows is boilerplate *)
| E_literal _ | E_skip | E_make_none _
| E_make_empty_map (_,_)
| E_make_empty_big_map _
| E_make_empty_list _
| E_make_empty_set _ as em -> return em
| E_constant (name, lst) -> (
let lst' = List.map self lst in
return @@ E_constant (name,lst')
)
| E_application farg -> (
let farg' = Tuple.map2 self farg in
return @@ E_application farg'
)
| E_while eb -> (
let eb' = Tuple.map2 self eb in
return @@ E_while eb'
)
| E_if_bool cab -> (
let cab' = Tuple.map3 self cab in
return @@ E_if_bool cab'
)
| E_sequence ab -> (
let ab' = Tuple.map2 self ab in
return @@ E_sequence ab'
)
| E_assignment (s, lrl, exp) -> (
let exp' = self exp in
if Var.equal s x then raise Bad_argument ;
return @@ E_assignment (s, lrl, exp')
)
let%expect_test _ =
let dummy_type = T_base Base_unit in
let wrap e = { content = e ; type_value = dummy_type } in
let show_subst ~body ~x ~expr =
Format.printf "(%a)[%a := %a] =@ %a"
PP.expression body
Var.pp x
PP.expression expr
PP.expression (subst_expression ~body ~x ~expr) in
let x = Var.of_name "x" in
let y = Var.of_name "y" in
let z = Var.of_name "z" in
let var x = wrap (E_variable x) in
let app f x = wrap (E_application (f, x)) in
let lam x u = wrap (E_closure { binder = x ; body = u }) in
let unit = wrap (E_literal D_unit) in
(* substituted var *)
Var.reset_counter () ;
show_subst
~body:(var x)
~x:x
~expr:unit ;
[%expect{|
(V(x))[x := L(unit)] =
L(unit) |}] ;
(* other var *)
Var.reset_counter () ;
show_subst
~body:(var y)
~x:x
~expr:unit ;
[%expect{|
(V(y))[x := L(unit)] =
V(y)
|}] ;
(* closure shadowed *)
Var.reset_counter () ;
show_subst
~body:(lam x (var x))
~x:x
~expr:unit ;
[%expect{|
(C(fun x -> (V(x))))[x := L(unit)] =
C(fun x -> (V(x)))
|}] ;
(* closure not shadowed *)
Var.reset_counter () ;
show_subst
~body:(lam y (var x))
~x:x
~expr:unit ;
[%expect{|
(C(fun y -> (V(x))))[x := L(unit)] =
C(fun y -> (L(unit)))
|}] ;
(* closure capture-avoidance *)
Var.reset_counter () ;
show_subst
~body:(lam y (app (var x) (var y)))
~x:x
~expr:(wrap (E_variable y)) ;
[%expect{|
(C(fun y -> ((V(x))@(V(y)))))[x := V(y)] =
C(fun y#1 -> ((V(y))@(V(y#1))))
|}] ;
(* let-in shadowed (not in rhs) *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_let_in ((x, dummy_type), var x, var x)))
~x:x
~expr:unit ;
[%expect{|
(let x = V(x) in ( V(x) ))[x := L(unit)] =
let x = L(unit) in ( V(x) )
|}] ;
(* let-in not shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_let_in ((y, dummy_type), var x, var x)))
~x:x
~expr:unit ;
[%expect{|
(let y = V(x) in ( V(x) ))[x := L(unit)] =
let y = L(unit) in ( L(unit) )
|}] ;
(* let-in capture avoidance *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_let_in ((y, dummy_type), var x,
app (var x) (var y))))
~x:x
~expr:(var y) ;
[%expect{|
(let y = V(x) in ( (V(x))@(V(y)) ))[x := V(y)] =
let y#1 = V(y) in ( (V(y))@(V(y#1)) )
|}] ;
(* iter shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_iterator ("ITER", ((x , dummy_type) , var x) , var x)))
~x:x
~expr:unit ;
[%expect{|
(for_ITER x of V(x) do ( V(x) ))[x := L(unit)] =
for_ITER x of L(unit) do ( V(x) )
|}] ;
(* iter not shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_iterator ("ITER", ((y , dummy_type) , var x) , var x)))
~x:x
~expr:unit ;
[%expect{|
(for_ITER y of V(x) do ( V(x) ))[x := L(unit)] =
for_ITER y of L(unit) do ( L(unit) )
|}] ;
(* iter capture-avoiding *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_iterator ("ITER", ((y , dummy_type) , app (var x) (var y)), app (var x) (var y))))
~x:x
~expr:(var y) ;
[%expect{|
(for_ITER y of (V(x))@(V(y)) do ( (V(x))@(V(y)) ))[x := V(y)] =
for_ITER y#1 of (V(y))@(V(y)) do ( (V(y))@(V(y#1)) )
|}] ;
(* if_cons shadowed 1 *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_if_cons (var x,
var x,
(((x, dummy_type), (y, dummy_type)),
var x))))
~x:x
~expr:unit ;
[%expect{|
(V(x) ?? V(x) : (x :: y) -> V(x))[x := L(unit)] =
L(unit) ?? L(unit) : (x :: y) -> V(x)
|}] ;
(* if_cons shadowed 2 *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_if_cons (var x,
var x,
(((y, dummy_type), (x, dummy_type)),
var x))))
~x:x
~expr:unit ;
[%expect{|
(V(x) ?? V(x) : (y :: x) -> V(x))[x := L(unit)] =
L(unit) ?? L(unit) : (y :: x) -> V(x)
|}] ;
(* if_cons not shadowed *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_if_cons (var x,
var x,
(((y, dummy_type), (z, dummy_type)),
var x))))
~x:x
~expr:unit ;
[%expect{|
(V(x) ?? V(x) : (y :: z) -> V(x))[x := L(unit)] =
L(unit) ?? L(unit) : (y :: z) -> L(unit)
|}] ;
(* if_cons capture avoidance 1 *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_if_cons (var x,
var x,
(((y, dummy_type), (z, dummy_type)),
app (var x) (app (var y) (var z))))))
~x:x
~expr:(var y) ;
[%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(y)] =
V(y) ?? V(y) : (y#1 :: z) -> (V(y))@((V(y#1))@(V(z)))
|}] ;
(* if_cons capture avoidance 2 *)
Var.reset_counter () ;
show_subst
~body:(wrap (E_if_cons (var x,
var x,
(((y, dummy_type), (z, dummy_type)),
app (var x) (app (var y) (var z))))))
~x:x
~expr:(var z) ;
[%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(z)] =
V(z) ?? V(z) : (y :: z#1) -> (V(z))@((V(y))@(V(z#1)))
|}] ;
(* old bug *)
Var.reset_counter () ;
let y0 = Var.fresh ~name:"y" () in
show_subst
~body:(lam y (lam y0 (app (var x) (app (var y) (var y0)))))
~x:x
~expr:(var y) ;
[%expect{|
(C(fun y -> (C(fun y#1 -> ((V(x))@((V(y))@(V(y#1))))))))[x := V(y)] =
C(fun y#2 -> (C(fun y#1 -> ((V(y))@((V(y#2))@(V(y#1)))))))
|}] ;