(****************************************************************************** * SNU 4190.310 Programming Languages (Fall 2006) * * HW 7: let-polymorphism, algebraic data type ******************************************************************************) (****************************************************************************** * Exercise 1. * Let-polymorphism with M algorithm ******************************************************************************) structure M_PolyChecker : M_PolyTypeChecker = struct open M /// definition of types part type ty = TVar of int | TInt | TString | TBool | TPair of ty * ty | TLoc of ty | TArrow of ty * ty type tyscheme = TY of ty | G of int list * tyscheme val next_tvar = ref 0 fun newt() = next_tvar++; TVar !next_tvar val rec string_of_types = fn TInt => "int" | TString => "string" | TBool => "bool" | TVar x => "'" ^ string_of_int x | TPair (t1, t2) => "(" ^ string_of_types t1 ^ " * " ^ string_of_types t2 ^ ")" | TLoc t => "loc " ^ string_of_types t | TArrow (t1, t2) => "(" ^ string_of_types t1 ^ "->" ^ string_of_types t2 ^ ")" val rec programType = fn TInt => TyInt | TString => TyString | TBool => TyBool | TPair (t1, t2) => TyPair (programType t1, programType t2) | TLoc t => TyLoc (programType t) | t => raise TypeError ("Invalid program type: " ^ string_of_types t) // primitive operators, values fun ( @@ ) g f = (fn t => g (f t)) val emptyG = fn x => raise TypeError ("Unknown id: " ^ x) val id = (fn x => x) /// substitution, unification part // subst.t = ty -> ty // subst: int -> ty -> subst fun subst x tau = let fun s t = case t of TVar y => if y = x then tau else t | TPair (t1, t2) => TPair (s t1, s t2) | TArrow (t1, t2) => TArrow (s t1, s t2) | TLoc t' => TLoc (s t') | TInt | TString | TBool => t in s end // occurs: int -> ty -> bool fun occurs x tau = case tau of TVar y => if y = x then true else false | TPair (t1, t2) | TArrow (t1, t2) => occurs x t1 orelse occurs x t2 | TLoc t => occurs x t | _ => false // unify: ty -> ty -> subst fun unify TVar x tau = if TVar x = tau then id else if not occurs x tau then subst x tau else raise TypeError ("infinite type: " ^ string_of_types TVar x ^ " = " ^ string_of_types tau) | unify tau TVar x = unify TVar x tau | unify TPair p1 TPair p2 = unifypair p1 p2 | unify TArrow p1 TArrow p2 = unifypair p1 p2 | unify TLoc t TLoc t' = unify t t' | unify tau tau' = if tau = tau' then id else raise TypeError ("mismatch between " ^ string_of_types tau ^ " and " ^ string_of_types tau') and unifypair (t1, t2) (t1', t2') = let val s = unify t1 t1' val s' = unify (s t2) (s t2') in s' @@ s end /// constraint derivation and solving part type constraint = U of exp * ty * ty | Or of exp * ty * ty list exception TypeError' of string * exp exception AbortCheck of string * exp fun lookup g x = snd (List.find (fn a => case a of (i, j) => i = x) g) handle Not_found => raise TypeError ("Unknown id: " ^ x) // subst type scheme fun substG s tysc = case tysc of TY t => TY (s t) | G (l, g) => G (l, substG s g) // @| : (ty -> ty) -> (id -> tyscheme) -> (id -> tyscheme) //fun ( @| ) s g = fn x => substG s (g x) fun ( @| ) s [] = [] | ( @| ) s (hd as (x, t)::tl) = (x, substG s t)::(s @| tl) //fun ( @+ ) g (x, t) = fn y => if y = x then t else g y fun ( @+ ) g (x, t) = (x, t)::g fun ( @\ ) a b = let fun list2set s [] = s | list2set s (hd::tl) = list2set (Set.add hd s) tl val sa = list2set Set.empty a val sb = list2set Set.empty b val sd = Set.diff sa sb in Set.elements sd end // m: (id -> ty) -> exp -> ty -> (subst * constraint list) fun m g exp tau = let fun or tau taul = [Or (exp, tau, taul)] // instantiation fun inst tysc = case tysc of TY t => t | G ([], TY t) => t | G ((hd::tl), TY t) => let val (TVar x) = newt() in inst G (tl, TY ((subst hd TVar x) t)) end | G (l, G(l1, g)) => inst G (l @ l1, g) // generalization fun gen g tau = (* find all ftv of tau and extract ftv of g and generalize tau *) let fun ftv_t tau = case tau of TVar i => [i] | TPair (a, b) => (ftv_t a) @ (ftv_t b) | TLoc l => ftv_t l | TArrow (a, b) => (ftv_t a) @ (ftv_t b) | _ => [] fun ftv_ts tysc = case tysc of TY t => ftv_t t | G (l, g) => (ftv_ts g) @\ l fun ftv_g [] = [] | ftv_g (hd as (x, ts)::tl) = (ftv_ts ts)::(ftv_g tl) fun compact [] g' = g' | compact (hd::tl) g' = if (List.exists (fn a => case a of (l, _) => l = fst hd) g') then compact tl g' else compact tl (hd::g') val g' = compact g [] val ftv = (ftv_t tau) @\ (List.flatten (ftv_g g')) in if (List.length ftv > 0) then G (ftv, TY tau) else TY tau end fun safegen g tau e = let fun check e = case e of CONST _ => true | VAR x => true | FN (x, exp) => check exp | APP (e1, e2) => (check e1) andalso (check e2) | LET (NREC (x, e1), e2) => (check e1) andalso (check e2) | LET (REC (x, e1), e2) => (check e1) andalso (check e2) | IF (e1, e2, e3) => (check e1) andalso (check e2) andalso (check e2) | BOP (EQ, e1, e2) => false | BOP (op, e1, e2) => (check e1) andalso (check e2) | READ => true | WRITE e => false | MALLOC e => false | ASSIGN (e1, e2) => (check e1) andalso (check e2) | BANG e => check e | SEQ (e1, e2) => (check e1) andalso (check e2) | PAIR (e1, e2) => (check e1) andalso (check e2) | SEL1 e => check e | SEL2 e => check e in if (check e) then gen g tau else TY tau end in (case exp of CONST (S _) => (unify tau TString, []) | CONST (N _) => (unify tau TInt, []) | CONST (B _) => (unify tau TBool, []) | VAR x => (unify tau (inst (lookup g x)), []) | FN (x, e) => let val t1 = newt() val t2 = newt() val s1 = unify tau TArrow (t1, t2) //val (s2, c2) = m (s1 @| (g @+ (x, TY t1))) e (s1 t2) val (s2, c2) = m (s1 @| (g @+ (x, TY t1))) e (s1 t2) in (s2 @@ s1, c2) end | APP (e1, e2) => let val t1 = newt() val (s1, c1) = m g e1 TArrow (t1, tau) val (s2, c2) = m (s1 @| g) e2 (s1 t1) in (s2 @@ s1, c2 @ c1) end | LET (NREC (x, e1), e2) => let val t1 = newt() val g' = g @+ (x, TY t1) //val (s1, c1) = m g' e2 tau //val (s2, c2) = m (s1 @| g) e1 (s1 t1) val (s1, c1) = m g e1 t1 val (s2, c2) = m ((s1 @| g) @+ (x, safegen g (s1 t1) e1)) e2 (s1 tau) //in (s2 @@ s1, c1 @ c2) in (s2 @@ s1, c2 @ c1) end | LET (REC (x, e1), e2) => let val t1 = newt() val g' = g @+ (x, TY t1) //val (s1, c1) = m g' e2 tau //val (s2, c2) = m (s1 @| g') e1 (s1 t1) val (s1, c1) = m g' e1 t1 val (s2, c2) = m ((s1 @| g) @+ (x, safegen g (s1 t1) e1)) e2 (s1 tau) //in (s2 @@ s1, c1 @ c2) in (s2 @@ s1, c2 @ c1) end | IF (e1, e2, e3) => (*let val (s1, c1) = m g e3 tau val (s2, c2) = m (s1 @| g) e2 (s1 tau) val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e1 TBool *) let val (s1, c1) = m g e1 TBool val (s2, c2) = m (s1 @| g) e2 (s1 tau) val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e3 (s2s1 tau) //in (s3 @@ s2s1, c1 @ c2 @ c3) in (s3 @@ s2s1, c3 @ c2 @ c1) end | BOP (op, e1, e2) => let val (ot, rt) = case op of ADD | SUB => (TInt, TInt) | AND | OR => (TBool, TBool) | EQ => (newt(), TBool) val s1 = unify tau rt (*val (s2, c2) = m g e2 ot val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e1 (s2s1 ot) val s3s2s1 = s3 @@ s2s1 *) val (s2, c2) = m g e1 ot val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e2 (s2s1 ot) val s3s2s1 = s3 @@ s2s1 (*in (s3s2s1, c2 @ c3 @ (or (s3s2s1 ot) [TInt, TString, TBool, TLoc (newt())])) *) in (s3s2s1, (or (s3s2s1 ot) [TInt, TString, TBool, TLoc (newt())]) @ c3 @ c2) end | READ => (unify tau TInt, []) | WRITE e => let val (s1, c1) = m g e tau //in (s1, c1 @ (or (s1 tau) [TInt, TString, TBool])) in (s1, (or (s1 tau) [TInt, TString, TBool]) @ c1) end | MALLOC e => let val t = newt() val s1 = unify tau TLoc t val (s2, c2) = m (s1 @| g) e (s1 t) in (s2 @@ s1, c2) end | ASSIGN (e1, e2) => (*let val (s1, c1) = m g e2 tau val (s2, c2) = m (s1 @| g) e1 (s1 TLoc tau) in (s2 @@ s1, c1 @ c2) *) let val (s1, c1) = m g e1 (TLoc tau) val (s2, c2) = m (s1 @| g) e2 (s1 tau) in (s2 @@ s1, c2 @ c1) end | BANG e => m g e TLoc tau | SEQ (e1, e2) => (*let val (s1, c1) = m g e2 tau val (s2, c2) = m (s1 @| g) e1 (newt()) in (s2 @@ s1, c1 @ c2) *) let val (s1, c1) = m g e1 (newt()) val (s2, c2) = m (s1 @| g) e2 (s1 tau) in (s2 @@ s1, c2 @ c1) end | PAIR (e1, e2) => (*let val t1 = newt() val t2 = newt() val s1 = unify tau TPair (t1, t2) val (s2, c2) = m (s1 @| g) e2 (s1 t2) val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e1 (s2s1 t1) in (s3 @@ s2s1, c2 @ c3) *) let val t1 = newt() val t2 = newt() val s1 = unify tau TPair (t1, t2) val (s2, c2) = m (s1 @| g) e1 (s1 t1) val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e2 (s2s1 t2) in (s3 @@ s2s1, c3 @ c2) end | SEL1 e => m g e TPair (tau, newt()) | SEL2 e => m g e TPair (newt(), tau) ) handle TypeError msg => raise TypeError' (msg, exp) end // c2s: subst -> constraint list -> subst fun c2s s [] = s | c2s s (U (e, t1, t2)::c) = c2s ((unify (s t1) (s t2) @@ s) handle TypeError msg => raise TypeError' (msg, e)) c | c2s s (Or (e, t1, tl)::c) = let fun try [] = raise AbortCheck ("none matches " ^ string_of_types (s t1) ^ " among " ^ String.concat ", " (List.map (string_of_types @@ s) tl), e) | try (h::t) = c2s s (U (e, t1, h)::c) handle TypeError' _ => try t in try tl end // check: exp -> types fun check exp = let val tau = newt() val (s, c) = m [] exp tau in programType ((c2s s c) tau) end handle TypeError' (msg, e) | AbortCheck (msg, e) => raise TypeError ("For `" ^ M_String.string_of e ^ "', " ^ msg ^ ".") //fun check exp = raise TypeError "no checker" (* TODO: implementation *) end structure M_SimChecker_M : M_SimTypeChecker = struct open M /// definition of types part type ty = TVar of int | TInt | TString | TBool | TPair of ty * ty | TLoc of ty | TArrow of ty * ty val next_tvar = ref 0 fun newt() = next_tvar++; TVar !next_tvar val rec string_of_types = fn TInt => "int" | TString => "string" | TBool => "bool" | TVar x => "'" ^ string_of_int x | TPair (t1, t2) => "(" ^ string_of_types t1 ^ " * " ^ string_of_types t2 ^ ")" | TLoc t => "loc " ^ string_of_types t | TArrow (t1, t2) => "(" ^ string_of_types t1 ^ "->" ^ string_of_types t2 ^ ")" val rec programType = fn TInt => TyInt | TString => TyString | TBool => TyBool | TPair (t1, t2) => TyPair (programType t1, programType t2) | TLoc t => TyLoc (programType t) | t => raise TypeError ("Invalid program type: " ^ string_of_types t) // primitive operators, values fun ( @@ ) g f = (fn t => g (f t)) fun ( @+ ) g (x, t) = fn y => if y = x then t else g y val emptyG = fn x => raise TypeError ("Unknown id: " ^ x) val id = (fn x => x) /// substitution, unification part // subst.t = ty -> ty // subst: int -> ty -> subst fun subst x tau = let fun s t = case t of TVar y => if y = x then tau else t | TPair (t1, t2) => TPair (s t1, s t2) | TArrow (t1, t2) => TArrow (s t1, s t2) | TLoc t' => TLoc (s t') | TInt | TString | TBool => t in s end // @| : (ty -> ty) -> (id -> ty) -> (id -> ty) fun ( @| ) s g = fn x => s (g x) // occurs: int -> ty -> bool fun occurs x tau = case tau of TVar y => if y = x then true else false | TPair (t1, t2) | TArrow (t1, t2) => occurs x t1 orelse occurs x t2 | TLoc t => occurs x t | _ => false // unify: ty -> ty -> subst fun unify TVar x tau = if TVar x = tau then id else if not occurs x tau then subst x tau else raise TypeError ("infinite type: " ^ string_of_types TVar x ^ " = " ^ string_of_types tau) | unify tau TVar x = unify TVar x tau | unify TPair p1 TPair p2 = unifypair p1 p2 | unify TArrow p1 TArrow p2 = unifypair p1 p2 | unify TLoc t TLoc t' = unify t t' | unify tau tau' = if tau = tau' then id else raise TypeError ("mismatch between " ^ string_of_types tau ^ " and " ^ string_of_types tau') and unifypair (t1, t2) (t1', t2') = let val s = unify t1 t1' val s' = unify (s t2) (s t2') in s' @@ s end /// constraint derivation and solving part type constraint = U of exp * ty * ty | Or of exp * ty * ty list exception TypeError' of string * exp exception AbortCheck of string * exp // m: (id -> ty) -> exp -> ty -> (subst * constraint list) fun m g exp tau = let fun or tau taul = [Or (exp, tau, taul)] in (case exp of CONST (S _) => (unify tau TString, []) | CONST (N _) => (unify tau TInt, []) | CONST (B _) => (unify tau TBool, []) | VAR x => (unify tau (g x), []) | FN (x, e) => let val t1 = newt() val t2 = newt() val s1 = unify tau TArrow (t1, t2) val (s2, c2) = m (s1 @| (g @+ (x, t1))) e (s1 t2) in (s2 @@ s1, c2) end | APP (e1, e2) => let val t1 = newt() val (s1, c1) = m g e1 TArrow (t1, tau) val (s2, c2) = m (s1 @| g) e2 (s1 t1) in (s2 @@ s1, c1 @ c2) end | LET (NREC (x, e1), e2) => let val t1 = newt() val g' = g @+ (x, t1) val (s1, c1) = m g' e2 tau val (s2, c2) = m (s1 @| g) e1 (s1 t1) in (s2 @@ s1, c1 @ c2) end | LET (REC (x, e1), e2) => let val t1 = newt() val g' = g @+ (x, t1) val (s1, c1) = m g' e2 tau val (s2, c2) = m (s1 @| g') e1 (s1 t1) in (s2 @@ s1, c1 @ c2) end | IF (e1, e2, e3) => let val (s1, c1) = m g e3 tau val (s2, c2) = m (s1 @| g) e2 (s1 tau) val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e1 TBool in (s3 @@ s2s1, c1 @ c2 @ c3) end | BOP (op, e1, e2) => let val (ot, rt) = case op of ADD | SUB => (TInt, TInt) | AND | OR => (TBool, TBool) | EQ => (newt(), TBool) val s1 = unify tau rt val (s2, c2) = m g e2 ot val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e1 (s2s1 ot) val s3s2s1 = s3 @@ s2s1 in (s3s2s1, c2 @ c3 @ (or (s3s2s1 ot) [TInt, TString, TBool, TLoc (newt())])) end | READ => (unify tau TInt, []) | WRITE e => let val (s1, c1) = m g e tau in (s1, c1 @ (or (s1 tau) [TInt, TString, TBool])) end | MALLOC e => let val t = newt() val s1 = unify tau TLoc t val (s2, c2) = m (s1 @| g) e (s1 t) in (s2 @@ s1, c2) end | ASSIGN (e1, e2) => let val (s1, c1) = m g e2 tau val (s2, c2) = m (s1 @| g) e1 (s1 TLoc tau) in (s2 @@ s1, c1 @ c2) end | BANG e => m g e TLoc tau | SEQ (e1, e2) => let val (s1, c1) = m g e2 tau val (s2, c2) = m (s1 @| g) e1 (newt()) in (s2 @@ s1, c1 @ c2) end | PAIR (e1, e2) => let val t1 = newt() val t2 = newt() val s1 = unify tau TPair (t1, t2) val (s2, c2) = m (s1 @| g) e2 (s1 t2) val s2s1 = s2 @@ s1 val (s3, c3) = m (s2s1 @| g) e1 (s2s1 t1) in (s3 @@ s2s1, c2 @ c3) end | SEL1 e => m g e TPair (tau, newt()) | SEL2 e => m g e TPair (newt(), tau) ) handle TypeError msg => raise TypeError' (msg, exp) end // c2s: subst -> constraint list -> subst fun c2s s [] = s | c2s s (U (e, t1, t2)::c) = c2s ((unify (s t1) (s t2) @@ s) handle TypeError msg => raise TypeError' (msg, e)) c | c2s s (Or (e, t1, tl)::c) = let fun try [] = raise AbortCheck ("none matches " ^ string_of_types (s t1) ^ " among " ^ String.concat ", " (List.map (string_of_types @@ s) tl), e) | try (h::t) = c2s s (U (e, t1, h)::c) handle TypeError' _ => try t in try tl end // check: exp -> types fun check exp = let val tau = newt() val (s, c) = m emptyG exp tau in programType ((c2s s c) tau) end handle TypeError' (msg, e) | AbortCheck (msg, e) => raise TypeError ("For `" ^ M_String.string_of e ^ "', " ^ msg ^ ".") end structure M_SimChecker : M_SimTypeChecker = struct open M /// definition of types part type ty = TVar of int | TInt | TString | TBool | TPair of ty * ty | TLoc of ty | TArrow of ty * ty val next_tvar = ref 0 fun newt() = next_tvar++; TVar !next_tvar val rec string_of_types = fn TInt => "int" | TString => "string" | TBool => "bool" | TVar x => "'" ^ string_of_int x | TPair (t1, t2) => "(" ^ string_of_types t1 ^ " * " ^ string_of_types t2 ^ ")" | TLoc t => "loc " ^ string_of_types t | TArrow (t1, t2) => "(" ^ string_of_types t1 ^ "->" ^ string_of_types t2 ^ ")" val rec programType = fn TInt => TyInt | TString => TyString | TBool => TyBool | TPair (t1, t2) => TyPair (programType t1, programType t2) | TLoc t => TyLoc (programType t) | t => raise TypeError ("Invalid program type: " ^ string_of_types t) // primitive operators, values fun ( @@ ) g f = (fn t => g (f t)) fun ( @+ ) g (x, t) = fn y => if y = x then t else g y val emptyG = fn x => raise TypeError ("Unknown id: " ^ x) val id = (fn x => x) /// substitution, unification part // subst: int -> ty -> subst fun subst x tau = let fun s t = case t of TVar y => if y = x then tau else t | TPair (t1, t2) => TPair (s t1, s t2) | TArrow (t1, t2) => TArrow (s t1, s t2) | TLoc t' => TLoc (s t') | TInt | TString | TBool => t in s end // occurs: int -> ty -> bool fun occurs x tau = case tau of TVar y => if y = x then true else false | TPair (t1, t2) | TArrow (t1, t2) => occurs x t1 orelse occurs x t2 | TLoc t => occurs x t | _ => false // unify: ty -> ty -> subst fun unify TVar x tau = if TVar x = tau then id else if not occurs x tau then subst x tau else raise TypeError ("infinite type: " ^ string_of_types TVar x ^ " = " ^ string_of_types tau) | unify tau TVar x = unify TVar x tau | unify TPair p1 TPair p2 = unifypair p1 p2 | unify TArrow p1 TArrow p2 = unifypair p1 p2 | unify TLoc t TLoc t' = unify t t' | unify tau tau' = if tau = tau' then id else raise TypeError ("mismatch between " ^ string_of_types tau ^ " and " ^ string_of_types tau') and unifypair (t1, t2) (t1', t2') = let val s = unify t1 t1' val s' = unify (s t2) (s t2') in s' @@ s end /// constraint derivation and solving part type constraint = U of exp * ty * ty | Or of exp * ty * ty list exception TypeError' of string * exp exception AbortCheck of string * exp // v: (id -> ty) -> exp -> ty -> constraint list -> constraint list fun v g exp tau = let fun u tau tau' = (fn c => U (exp, tau, tau') :: c) fun or tau taul = (fn c => Or (exp, tau, taul) :: c) in case exp of CONST (S _) => u tau TString | CONST (N _) => u tau TInt | CONST (B _) => u tau TBool | VAR x => u tau (g x) | FN (x, e) => let val t1 = newt() val t2 = newt() in u tau TArrow (t1, t2) @@ v (g @+ (x, t1)) e t2 end | APP (e1, e2) => let val t1 = newt() in v g e1 TArrow (t1, tau) @@ v g e2 t1 end | LET (NREC (x, e1), e2) => let val t1 = newt() val g' = g @+ (x, t1) in v g' e2 tau @@ v g e1 t1 end | LET (REC (x, e1), e2) => let val t1 = newt() val g' = g @+ (x, t1) in v g' e2 tau @@ v g' e1 t1 end | IF (e1, e2, e3) => v g e3 tau @@ v g e2 tau @@ v g e1 TBool | BOP (op, e1, e2) => let val (t, t') = case op of ADD | SUB => (TInt, TInt) | AND | OR => (TBool, TBool) | EQ => (newt(), TBool) in u tau t' @@ or t [TInt, TString, TBool, TLoc (newt())] @@ v g e2 t @@ v g e1 t end | READ => u tau TInt | WRITE e => or tau [TInt, TString, TBool] @@ v g e tau | MALLOC e => let val t = newt() in u tau TLoc t @@ v g e t end | ASSIGN (e1, e2) => v g e2 tau @@ v g e1 TLoc tau | BANG e => v g e TLoc tau | SEQ (e1, e2) => v g e2 tau @@ v g e1 (newt()) | PAIR (e1, e2) => let val t1 = newt() val t2 = newt() in u tau TPair (t1, t2) @@ v g e2 t2 @@ v g e1 t1 end | SEL1 e => v g e TPair (tau, newt()) | SEL2 e => v g e TPair (newt(), tau) end // c2s: subst -> constraint list -> subst fun c2s s [] = s | c2s s (U (e, t1, t2)::c) = c2s ((unify (s t1) (s t2) @@ s) handle TypeError msg => raise TypeError' (msg, e)) c | c2s s (Or (e, t1, tl)::c) = let fun try [] = raise AbortCheck ("none matches " ^ string_of_types (s t1) ^ " among " ^ String.concat ", " (List.map (string_of_types @@ s) tl), e) | try (h::t) = c2s s (U (e, t1, h)::c) handle TypeError' _ => try t in try tl end // reorder: constraint list -> constraint list fun reorder c = let val (u, or) = List.partition (fn Or _ => false | _ => true) c in u @ or end // check: exp -> types fun check exp = let val tau = newt() in programType ((c2s id (reorder (v emptyG exp tau []))) tau) end handle TypeError' (msg, e) | AbortCheck (msg, e) => raise TypeError ("For `" ^ M_String.string_of e ^ "', " ^ msg ^ ".") end structure M_LowFat : M_Runner = struct open M // domains type loc = int type value = Num of int | String of string | Bool of bool | Loc of loc | Pair of value * value | Closure of closure and closure = fexpr * env and fexpr = Fun of id * exp | RecFun of id * id * exp and env = id -> value type memory = int * (loc -> value) // notations (see 5 page in M.pdf) (* f @+ (x, v) f[x |-> v] * store M (l, v) M[l |-> v] * fetch M l M(l) *) fun (@+) f (x, v) = (fn y => if y = x then v else f y) fun store (l, m) p = (l, m @+ p) fun fetch (_, m) l = m l fun malloc (l, m) = (l, (l+1, m)) // auxiliary functions fun error msg = raise RuntimeError msg val op2fn = fn ADD => (fn (Num n1,Num n2) => Num (n1 + n2)) | SUB => (fn (Num n1,Num n2) => Num (n1 - n2)) | AND => (fn (Bool b1,Bool b2) => Bool (b1 andalso b2)) | OR => (fn (Bool b1,Bool b2) => Bool (b1 orelse b2)) | EQ => (fn (v1,v2) => Bool (v1 = v2)) val rec printValue = fn Num n => print_int n; print_newline() | Bool b => print_endline (if b then "true" else "false") | String s => print_endline s fun eval env mem exp = case exp of CONST c => (case c of S s => String s | N n => Num n | B b => Bool b, mem) | VAR x => (env x, mem) | FN (x, e) => (Closure (Fun (x, e), env), mem) | APP (e1, e2) => let val (v1, m') = eval env mem e1 val Closure (c, env') = v1 val (v2, m'') = eval env m' e2 in case c of Fun (x, e) => eval (env' @+ (x,v2)) m'' e | RecFun (f, x, e) => eval ((env' @+ (x,v2)) @+ (f,v1)) m'' e end | LET (NREC (x, e1), e2) => let val (v1, m') = eval env mem e1 in eval (env @+ (x,v1)) m' e2 end | LET (REC (f, e1), e2) => let val (v1, m') = eval env mem e1 val Closure (c, env') = v1 in case c of Fun (x, e) => eval (env @+ (f, Closure (RecFun (f, x, e), env'))) m' e2 | _ => raise Invalid_argument "redundant let rec" end | IF (e1, e2, e3) => let val (Bool b, m') = eval env mem e1 in eval env m' (if b then e2 else e3) end | BOP (op, e1, e2) => let val (v1, m') = eval env mem e1 val (v2, m'') = eval env m' e2 in ((op2fn op) (v1,v2), m'') end | READ => let val n = read_int () handle _ => error "read error" in (Num n, mem) end | WRITE e => let val (v, m') = eval env mem e in printValue v; (v, m') end | MALLOC e => let val (v, m') = eval env mem e val (l, m'') = malloc m' in (Loc l, store m'' (l,v)) end | ASSIGN (e1, e2) => let val (v1, m') = eval env mem e1 val Loc l = v1 val (v, m'') = eval env m' e2 in (v, store m'' (l,v)) end | BANG e => let val (Loc l, m') = eval env mem e in (fetch m' l, m') end | SEQ (e1, e2) => let val (v1, m1) = eval env mem e1 in eval env m1 e2 end | PAIR (e1, e2) => let val (v1, m1) = eval env mem e1 val (v2, m2) = eval env m1 e2 in (Pair (v1, v2), m2) end | SEL1 e | SEL2 e => let val (Pair p, m') = eval env mem e in ((if exp = SEL1 e then fst else snd) p, m') end val emptyEnv = (fn x => raise Invalid_argument ("unknown id: " ^ x)) val emptyMem = (0, fn l => raise Invalid_argument ("unknown loc: " ^ string_of_int l)) fun run exp = ignore (eval emptyEnv emptyMem exp) end