113 lines
2.5 KiB
Coq
113 lines
2.5 KiB
Coq
(*
|
|
Source language: STLC
|
|
Target language: CPS
|
|
*)
|
|
|
|
Module Stlc.
|
|
(* Source language *)
|
|
Inductive type : Set :=
|
|
| Bool: type
|
|
| Arrow: type -> type -> type.
|
|
|
|
(* V is type family of variables *)
|
|
Inductive term (V:type->Type): type -> Type :=
|
|
| Tru: term V Bool
|
|
| Fls: term V Bool
|
|
| Var: forall t:type,
|
|
V t -> term V t
|
|
| App: forall t1 t2:type,
|
|
term V (Arrow t1 t2) -> term V t1 -> term V t2
|
|
| Abs: forall t1 t2:type,
|
|
(V t1 -> term V t2) -> term V (Arrow t1 t2).
|
|
|
|
Arguments Tru {V}.
|
|
Arguments Fls {V}.
|
|
Arguments Var {V t}.
|
|
Arguments App {V t1 t2}.
|
|
Arguments Abs {V t1 t2}.
|
|
|
|
Definition Term (t:type) (V:type -> Type) := term V t.
|
|
End Stlc.
|
|
|
|
|
|
Module Cps.
|
|
|
|
(* Target language *)
|
|
Inductive type : Set :=
|
|
| Bool: type
|
|
| Cont: type -> type
|
|
| Prod: type -> type -> type.
|
|
|
|
Inductive term (V:type -> Type) : type -> Type :=
|
|
| Halt: forall t:type, (* Done. No more continuation *)
|
|
V t -> term V t
|
|
| App: forall t,
|
|
V (Cont t) -> V t -> term V t
|
|
| LetBind: forall (t:type),
|
|
primop V t
|
|
-> (V t -> term V t)
|
|
-> term V t
|
|
with primop (V:type -> Type) : type -> Type :=
|
|
| Tru: primop V Bool
|
|
| Fls: primop V Bool
|
|
| Var: forall t:type,
|
|
V t -> primop V t
|
|
| Abs: forall t1 t2:type,
|
|
(V t1 -> term V t2) -> primop V (Cont t2)
|
|
| Pair: forall t1 t2:type,
|
|
V t1 -> V t2 -> primop V (Prod t1 t2)
|
|
| Fst: forall t1 t2:type,
|
|
V (Prod t1 t2) -> primop V t1
|
|
| Snd: forall t1 t2:type,
|
|
V (Prod t1 t2) -> primop V t2.
|
|
|
|
Arguments Halt {V t}.
|
|
Arguments App {V t}.
|
|
Arguments LetBind {V t}.
|
|
|
|
Arguments Tru {V}.
|
|
Arguments Fls {V}.
|
|
Arguments Var {V t}.
|
|
Arguments Abs {V t1 t2}.
|
|
Arguments Pair {V t1 t2}.
|
|
Arguments Fst {V t1 t2}.
|
|
Arguments Snd {V t1 t2}.
|
|
End Cps.
|
|
|
|
|
|
Import Stlc.
|
|
Import Cps.
|
|
|
|
Fixpoint stlcToCpsType (t: Stlc.type) : Cps.type :=
|
|
match t with
|
|
| Stlc.Bool => Cps.Bool
|
|
| Stlc.Arrow t1 t2 =>
|
|
let t1' := (stlcToCpsType t1) in
|
|
let t2' := (stlcToCpsType t2) in
|
|
Cps.Cont (Cps.Prod t1' (Cps.Cont t2'))
|
|
end.
|
|
|
|
(* Convert Stlc terms to equivalent Cps terms *)
|
|
Fixpoint stlcToCps {sV: Stlc.type -> Type} {cV: Cps.type -> Type}
|
|
{sT: Stlc.type} {cT: Cps.type} (t: Stlc.term sV sT)
|
|
: Cps.term cV cT :=
|
|
match t with
|
|
| Stlc.Tru => LetBind Cps.Tru Cps.Halt
|
|
| Stlc.Fls => LetBind Cps.Tru Cps.Halt
|
|
| Stlc.Var v => LetBind Cps.Tru Cps.Halt
|
|
| Stlc.App f e => LetBind Cps.Tru Cps.Halt
|
|
| Stlc.Abs f => LetBind Cps.Tru Cps.Halt
|
|
end.
|
|
|
|
|
|
|
|
|
|
match t with
|
|
| Halt v =>
|
|
| App f v =>
|
|
| LetBind op f =>
|
|
end.
|
|
|
|
|
|
|