(*
*) (* The code for illustrating Mutual Recursion *) datatype MLtype = Unit | Int | Real | Char | Bool | Product of MLtype list | Arrow of (MLtype * MLtype) fun showt Unit = "()" | showt Int = "int" | showt Real = "real" | showt Char = "char" | showt Bool = "bool" | showt (Product ts) = let fun showeach [] = "" | showeach [x] = showt x | showeach (x::xs) = (showt x)^"*"^(showeach xs) in "("^(showeach ts)^")" end | showt (Arrow(x,y)) = "("^showt x^" -> "^showt y^")" fun typeeq (x,y) = case (x,y) of (Unit,Unit) => true | (Int,Int) => true | (Real,Real) => true | (Char,Char) => true | (Bool,Bool) => true | (Arrow(d1,r1),Arrow(d2,r2)) => typeeq(d1,d2) andalso typeeq(r1,r2) | (Product(ss),Product(ts)) => (listeq ss ts) | (_,_) => false and listeq (x::xs) (y::ys) = typeeq(x,y) andalso listeq xs ys | listeq [] [] = true | listeq _ _ = false; (* **************************************************** *) datatype Op = Plus | Less | And datatype Constant = Cint of int | Cchar of char | Cbool of bool datatype Exp = Lit of Constant (* 5 *) | Var of string (* x *) | App of Exp*Exp (* f x *) | Tuple of Exp list (* (x,3,true) *) | Infix of Exp*Op*Exp (* x+3 *) | Stmt of Exp list (* (print x; 3) *) | If of Exp * Exp * Exp (* if x then y else 3 *) | While of Exp * Exp (* while x do (f x) *) | Anonfun of string* MLtype * Exp (* (fn x => x+1) *) | Let of Dec*Exp (* let val x = 1 in x end *) | Int2Real of Exp and Dec = Valdec of (string*MLtype)*Exp | Fundec of (string*MLtype*MLtype)*string*Exp | Mutdec of Dec list fun TCConstant (Cint n) = Int | TCConstant (Cchar c) = Char | TCConstant (Cbool t) = Bool; exception TypeError of Exp*string; fun error e s = raise(TypeError (e,s)); fun unexpected r t1 t2 = error r ("Found type "^(showt t1)^" expecting type "^(showt t2)); fun TCExp x cntxt = case x of Lit c => TCConstant c | Var s => (case List.find (fn (nm,t) => nm=s) cntxt of SOME(nm,t) => t | NONE => error x "Undeclared variable") and TCDec (Valdec((nm,t),exp)) cntxt = let val bodyt = TCExp exp cntxt in if typeeq(t,bodyt) then [(nm,t)] else unexpected exp bodyt t end | TCDec (Fundec((f,dom,rng),x,body)) cntxt = let val ft = Arrow(dom,rng) val bodyt = TCExp body((x,dom)::cntxt) (* f is not recursive unless inside a Mutdec *) in if typeeq(bodyt,rng) then [(f,ft)] else unexpected body bodyt rng end | TCDec (Mutdec ds) cntxt = let fun pass1 [] cntxt = cntxt | pass1 (Valdec(p,b)::ds) cntxt = pass1 ds (p::cntxt) | pass1 (Fundec((f,d,r),x,b)::ds) cntxt = pass1 ds ((f,Arrow(d,r))::(x,d)::cntxt) val temp = pass1 ds cntxt val pass2 = map (fn d => TCDec d temp) ds in List.concat pass2 end; fun TCOp Plus = (Int,Int,Int) | TCOp Less = (Int,Int,Bool) | TCOp And = (Bool,Bool,Bool); fun TCConstant (Cint n) = Int | TCConstant (Cchar c) = Char | TCConstant (Cbool t) = Bool; (* ********* Code rebuilding type checker ******** *) fun fst (x,y) = x fun snd (x,y) = y fun Fix result info left right = case info of (Plus,Int,Real) => (result,Infix(Int2Real left,Plus,right)) | (Plus,Real,Int) => (result,Infix(left,Plus,Int2Real right)) | (oper, _ , _ ) => (result,Infix(left,oper,right)) fun TCExp2 x cntxt = case x of Lit c => (TCConstant c,x) | Var s => (case List.find (fn (nm,t) => nm=s) cntxt of SOME(nm,t) => (t,Var s) | NONE => error x "Undeclared variable") | Infix(l,x,r) => let val (ltype,l2) = TCExp2 l cntxt val (rtype,r2) = TCExp2 r cntxt val (lneed,rneed,result) = TCOp x in case (typeeq(ltype,lneed),typeeq(rtype,rneed)) of (true,true) => Fix result (x,ltype,rtype) l2 r2 | (true,false) => unexpected r rtype rneed | (false,true) => unexpected l ltype lneed | (false,false) => unexpected l ltype lneed end | App(f,x) => let val (ftype,f2) = TCExp2 f cntxt val (xtype,x2) = TCExp2 x cntxt in case ftype of Arrow(dom,rng) => if (typeeq(dom,xtype)) then (rng,App(f2,x2)) else unexpected x xtype dom | other => error f ("the type "^showt other^" is not a function") end | Stmt xs => let val pairs = List.map (fn x => TCExp2 x cntxt) xs val xs2 = List.map snd pairs fun last [x] = x | last (x::xs) = last xs | last [] = error x "Tuple with no elements" in (fst(last pairs), Stmt xs2) end | Tuple xs => let val pairs = List.map (fn x => TCExp2 x cntxt) xs val xstypes = map fst pairs val xs2 = map snd pairs in (Product xstypes, Tuple xs2) end | If(x,y,z) => let val (xtype,x2) = TCExp2 x cntxt val (ytype,y2) = TCExp2 y cntxt val (ztype,z2) = TCExp2 z cntxt in if typeeq(xtype,Bool) then if (typeeq(ytype,ztype)) then (ytype,If(x2,y2,z2)) else unexpected y ytype ztype else error x ("the type "^ showt xtype^ " is not boolean") end | While(test,body) => let val (ttype,test2) = TCExp2 test cntxt val (btype,body2) = TCExp2 body cntxt in if typeeq(ttype,Bool) then (btype,While(test2,body2)) else unexpected test ttype Bool end | Anonfun(x,t,body) => let val (btype,body2) = TCExp2 body ((x,t)::cntxt) in (Arrow(t,btype),Anonfun(x,t,body2)) end | Let(d,b) => let val cntxt2 = TCDec d cntxt val (btype,b2) = TCExp2 b cntxt2 in (btype,Let(d,b2)) end; (* ********** Scopes ******************* *) type ('name,'value)table = ('name * 'value) list; type ('name,'value)Scope = (('name,'value)table) list ; fun initialize scope = [ ] :: scope fun insert name value (table::scope) = ((name,value)::table)::scope fun Lookup name (table::scope) = case List.find (fn (x,y) => x=name) table of NONE => error | SOME (x,y) => y fun finalize (table::scope) = scope (**)