(* *)
(* 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
(*
*)