(* The core calculus, with boring, difficult, and exercise cases omitted. *) type var = int type label = int type primop = Iadd (* | Isub | Imul *) | Ieql (* | Ige | Igt *) (* | Update of label *) (* | Equal (* for records or summands *) *) type lexp = Unit | Var of var | Abs of var * lexp | App of lexp * lexp | Int of int | Prim of primop (* | Fix of (var * lexp) list * lexp *) | Record of (label * lexp) list | Select of label * lexp | Labeled of label * lexp | Switch of lexp * (label * (var * lexp)) list * lexp option (* | Raise of lexp *) (* | Handle of lexp * var * lexp *) (* Fresh variables or labels *) let gensym = let next = ref 0 in fun () -> let sym = !next in incr next; sym (* A dummy variable or label *) let dummy = gensym() (* Booleans encoded as summands *) let false_label = gensym() let true_label = gensym() let eFalse = Labeled(false_label,Unit) let eTrue = Labeled(true_label,Unit) let eIf(e,e1,e2) = Switch(e,[(true_label,(dummy,e1));(false_label,(dummy,e2))],None) (* Bindings *) let eLet(x,e1,e2) = App(Abs(x,e2),e1) (* Pairs *) let fst_label = gensym() let snd_label = gensym() let ePair(e1,e2) = Record [(fst_label,e1);(snd_label,e2)] let eFst p = Select(fst_label,p) let eSnd p = Select(snd_label,p) (* Binary operations*) let eBinop(p,e1,e2) = App(Prim p,ePair(e1,e2)) (* some examples *) let a = App(Abs(1,eBinop(Iadd,Int 1,Var 1)),Int 17) let b = eIf(eBinop(Ieql,Int 1, Int 2), Int 7, a) (* --------------------------------------------------------------------------------------- *) (* A meta-circular CBV interpreter for the core calculus. *) (* Values manipulated by the interpreter. *) type value = Vunit | Vint of int | Vrecord of (label * value) list | Vlabeled of label * value | Vfn of (value -> value) (* user-defined functions *) | Vprim of primop (* Environments are implemented using association lists (from CAML library) *) type env = Env of (var * value) list exception Bad_var let empty = Env [] let extend (Env env) v x = Env ((v,x)::env) let lookup (Env env) v = try List.assoc v env with Not_found -> raise Bad_var (* Various exceptions raised if invalid program is interpreted. *) exception Bad_exp exception Bad_app exception Bad_primarg exception Bad_prim exception Bad_switch exception Bad_select (* The main interpreter loop. *) let rec eval env = let rec eval0 = function Unit -> Vunit | Var v -> lookup env v | Abs(v,e) -> Vfn (fun x -> eval (extend env v x) e) | App(e1,e2) -> let v1 = eval0 e1 in let v2 = eval0 e2 in begin match v1 with Vfn f -> f v2 | Vprim Iadd -> begin match v2 with Vrecord [(_,Vint i1);(_,Vint i2)] -> Vint(i1+i2) | _ -> raise Bad_primarg end | Vprim Ieql -> begin match v2 with Vrecord [(_,Vint i1);(_,Vint i2)] -> if i1 = i2 then eval0 eTrue else eval0 eFalse | _ -> raise Bad_primarg end | Vprim _ -> raise Bad_prim | _ -> raise Bad_app end | Int i -> Vint i | Prim p -> Vprim p | Labeled(l,e) -> Vlabeled(l,eval0 e) | Switch(e, el, eo) -> begin match eval0 e with Vlabeled(l,v) -> begin try let (x,e) = List.assoc l el in eval (extend env x v) e with Not_found -> begin match eo with Some e -> eval0 e | None -> raise Bad_switch end end | _ -> raise Bad_switch end | _ -> raise Bad_exp in eval0 (* The top level evaluator *) let evaluate (e : lexp) : value = eval empty e