[snipe.git] / type / typechecker.sml

(* L3 Compiler
 * TypeChecker
 * Author: Alex Vaynberg <alv@andrew.cmu.edu>
 * Modified: Frank Pfenning <fp@cs.cmu.edu>
 * Modified: Joshua Wise <jwise>
 * Modified: Chris Lu <czl>
 *) 

signature TYPE_CHECK =
sig
  (* prints error message and raises ErrorMsg.error if error found *)
  val typecheck : Ast.program -> Ast.program
end;

structure TypeChecker :> TYPE_CHECK = 
struct
  structure A = Ast
  
  datatype asn = ASSIGNED | UNASSIGNED

  fun returns nil = false
    | returns (A.Assign _ :: stms) = returns stms
    | returns (A.Return _ :: stms) = true
    | returns (A.Nop :: stms) = returns stms
    | returns (A.Break :: stms) = true (* blah *)
    | returns (A.Continue :: stms) = true (* blah *)
    | returns (A.If (_, s1, NONE) :: stms) = returns stms
    | returns (A.If (_, s1, SOME s2) :: stms) = (returns s1 andalso returns s2) orelse returns stms
    | returns (A.For _ :: stms) = returns stms
    | returns (A.While _ :: stms) = returns stms
    | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
  
  fun breakcheck nil mark = ()
    | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
                                             raise ErrorMsg.Error )
    | breakcheck (A.Continue :: stms) mark = ( ErrorMsg.error mark ("Illegal continue outside loop") ;
                                                raise ErrorMsg.Error )
    | breakcheck (A.If (_, s1, NONE) :: stms) mark =
        ( breakcheck s1 mark;
          breakcheck stms mark)
    | breakcheck (A.If (_, s1, SOME s2) :: stms) mark =
        ( breakcheck s1 mark;
          breakcheck s2 mark;
          breakcheck stms mark)
    | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
    | breakcheck (_ :: stms) mark = breakcheck stms mark
  
  fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype =
        ( case Symbol.look env v
          of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
                       raise ErrorMsg.Error )
           | SOME (t, UNASSIGNED) => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;
                                       raise ErrorMsg.Error )
           | SOME (t, ASSIGNED) => t)
    | varcheck_exp env fenv (A.ConstExp _) mark = (A.Int)
    | varcheck_exp env fenv (A.OpExp (_, l)) mark = (List.app (fn znt => (varcheck_exp env fenv znt mark; ())) l; A.Int)
    | varcheck_exp env fenv (A.FuncCall (f, l)) mark =
      let
        val types = map (fn znt => varcheck_exp env fenv znt mark) l
        val func = case Symbol.look fenv f
                     of NONE => ( ErrorMsg.error mark ("undefined function `" ^ Symbol.name f ^ "'") ;
                                  raise ErrorMsg.Error )
                      | SOME a => a
        val (rtype, params) = case func
                               of A.Extern (rtype, _, params) => (rtype, params)
                                | A.Function (rtype, _, params, _, _) => (rtype, params)
        val paramtypes = map (fn (i, t) => t) params
        val () = if not (types = paramtypes)
                 then ( ErrorMsg.error mark ("incorrect parameters for function `" ^ Symbol.name f ^ "'") ;
                        raise ErrorMsg.Error )
                 else ()
      in
        rtype
      end
    | varcheck_exp env fenv (A.Marked m) mark = varcheck_exp env fenv (Mark.kane m) (Mark.ext m)
  
  fun computeassigns env nil = env
    | computeassigns env (A.Assign (id,e) :: stms) =
        computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms
    | computeassigns env (A.Return _ :: stms) = env
    | computeassigns env (A.Nop :: stms) = computeassigns env stms
    | computeassigns env (A.Break :: stms) = env
    | computeassigns env (A.Continue :: stms) = env
    | computeassigns env (A.If (e, s1, NONE) :: stms) = computeassigns env stms
    | computeassigns env (A.If (e, s1, SOME s2) :: stms) =
        let
          val env1 = computeassigns env s1
          val env2 = computeassigns env s2
          val env' =
            Symbol.intersect
              (fn ((t, ASSIGNED), (t', ASSIGNED)) => (t, ASSIGNED) (* XXX check types for equality *)
                | ((t, _), (t', _)) => (t, UNASSIGNED))
              (env1, env2)
          val env' =
            if (returns s1) then env2
            else if (returns s2) then env1
            else env'
        in
          computeassigns env' stms
        end
    | computeassigns env (A.While (e, s1) :: stms) = computeassigns env stms
    | computeassigns env (A.For (sbegin, e, sloop, inner) :: stms) =
       let
         val env' = case sbegin
                    of SOME(s) => computeassigns env [s]
                     | NONE => env
       in
         computeassigns env' stms
       end
    | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
  
  fun varcheck env fenv nil mark = nil
    | varcheck env fenv (A.Assign (id, e) :: stms) mark =
        let
          val sym = Symbol.look env id
          val _ = if not (isSome sym)
                  then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error)
                  else ()
          val (t, a) = valOf sym
          val t' = varcheck_exp env fenv e mark
        in 
          A.Assign (id, e) :: (varcheck (Symbol.bind env (id, (t, ASSIGNED))) fenv stms mark)
        end
    | varcheck env fenv (A.Return (e) :: stms) mark =
        ( varcheck_exp env fenv e mark;
          A.Return (e) :: nil )
    | varcheck env fenv (A.Nop :: stms) mark =
        ( A.Nop :: (varcheck env fenv stms mark))
    | varcheck env fenv (A.Break :: stms) mark =
        ( A.Break :: nil )
    | varcheck env fenv (A.Continue :: stms) mark =
        ( A.Continue :: nil )
    | varcheck env fenv (A.If (e, s1, NONE) :: stms) mark =
        ( varcheck_exp env fenv e mark ;
          varcheck env fenv s1 mark ;
          A.If (e, s1, NONE) :: (varcheck env fenv stms mark) )
    | varcheck env fenv ((i as A.If (e, s1, SOME s2)) :: stms) mark =
        ( varcheck_exp env fenv e mark ;
          varcheck env fenv s1 mark ; 
          varcheck env fenv s2 mark ;
          A.If (e, s1, SOME s2) ::
            (if (returns [i])
             then nil
             else varcheck (computeassigns env [i]) fenv stms mark)  )
    | varcheck env fenv (A.While (e, s1) :: stms) mark =
        ( varcheck_exp env fenv e mark ;
          varcheck env fenv s1 mark ;
          A.While (e, s1) :: (varcheck env fenv stms mark) )
    | varcheck env fenv (A.For (sbegin, e, sloop, inner) :: stms) mark =
        let
          val sbegin = case sbegin
                       of SOME(s) => SOME (hd (varcheck env fenv [s] mark))
                        | NONE => NONE
          val env' = case sbegin
                     of SOME(s) => computeassigns env [s]
                      | NONE => env
          val _ = varcheck_exp env' fenv e
          val inner = varcheck env' fenv inner mark
          val env'' = computeassigns env' inner
          val sloop = case sloop
                  of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark))
                   | NONE => NONE
        in
          A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark)
        end
    | varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m)

  fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,(t, stat))) sym l
  fun bindfuns sym l =
    foldr
      (fn (a as (A.Function (_, id, _, _, _)), s) => Symbol.bind s (id, a)
        | (a as (A.Extern (_, id, _)), s) => Symbol.bind s (id, a))
      sym l

  fun dupchk l =
        List.app
          (fn (n, _) =>
            let
              val name = Symbol.name n
              val all = List.filter (fn (n', _) => name = (Symbol.name n')) l
              val count = length all
            in
              if count = 1
              then ()
              else ( ErrorMsg.error NONE ("multiple definition of variable " ^ (Symbol.name n));
                     raise ErrorMsg.Error )
            end) l

  fun typecheck_fn p (e as (A.Extern (t, id, al))) = (dupchk al; e)
    | typecheck_fn p (A.Function (t, id, al, vl, sl)) =
      let
        val () = breakcheck sl NONE
        val () = if not (returns sl)
                 then ( ErrorMsg.error NONE ("function `"^ Symbol.name id ^ "' does not return in all cases");
                        raise ErrorMsg.Error )
                 else ()
        val env = Symbol.empty
        val env = bindvars env ASSIGNED al
        val env = bindvars env UNASSIGNED vl
        val fenv = bindfuns Symbol.empty p
        val () = dupchk (al @ vl)
      in
        A.Function (t, id, al, vl, varcheck env fenv sl NONE)
      end
  
  fun typecheck p =
      let
        fun getFun n =
          List.find (fn A.Extern (_, id, _) => ((Symbol.name id) = n)
                      | A.Function (_, id, _, _, _) => ((Symbol.name id) = n))
                    p
        val main = case (getFun "main")
                   of NONE => ( ErrorMsg.error NONE ("no function named main");
                                raise ErrorMsg.Error )
                    | SOME m => m
        val () = case main
                 of A.Extern _ => ( ErrorMsg.error NONE ("you anus, main can't be an extern");
                                    raise ErrorMsg.Error )
                  | A.Function (A.Int, _, nil, _, _) => ()
                  | A.Function (A.Int, _, _, _, _) => ( ErrorMsg.error NONE ("main should take no parameters");
                                                        raise ErrorMsg.Error )
        val () = List.app
                   (fn a =>
                      let
                        val id = case a
                          of A.Extern (_, id, _) => id
                           | A.Function (_, id, _, _, _) => id
                        val name = Symbol.name id
                        val all = List.filter
                          (fn A.Extern (_, id, _) => (Symbol.name id) = name
                            | A.Function (_, id, _, _, _) => (Symbol.name id) = name)
                          p
                        val num = length all
                      in
                        if num = 1
                        then ()
                        else ( ErrorMsg.error NONE ("multiple definition of " ^ name);
                               raise ErrorMsg.Error )
                      end) p
      in
        List.map (typecheck_fn p) p
      end
end
Commit	Line	Data
6ade8b0a	1	(* L3 Compiler
12aa4087 JW	2	* TypeChecker
	3	* Author: Alex Vaynberg <alv@andrew.cmu.edu>
	4	* Modified: Frank Pfenning <fp@cs.cmu.edu>
6ade8b0a JW	5	* Modified: Joshua Wise <jwise>
6ade8b0a JW	6	* Modified: Chris Lu <czl>
12aa4087 JW	7	*)
	8
	9	signature TYPE_CHECK =
	10	sig
	11	(* prints error message and raises ErrorMsg.error if error found *)
0a24e44d	12	val typecheck : Ast.program -> Ast.program
12aa4087 JW	13	end;
	14
	15	structure TypeChecker :> TYPE_CHECK =
	16	struct
	17	structure A = Ast
6ade8b0a JW	18
6ade8b0a JW	19	datatype asn = ASSIGNED \| UNASSIGNED
12aa4087	20
0a24e44d JW	21	fun returns nil = false
	22	\| returns (A.Assign _ :: stms) = returns stms
	23	\| returns (A.Return _ :: stms) = true
	24	\| returns (A.Nop :: stms) = returns stms
	25	\| returns (A.Break :: stms) = true (* blah *)
	26	\| returns (A.Continue :: stms) = true (* blah *)
	27	\| returns (A.If (_, s1, NONE) :: stms) = returns stms
	28	\| returns (A.If (_, s1, SOME s2) :: stms) = (returns s1 andalso returns s2) orelse returns stms
	29	\| returns (A.For _ :: stms) = returns stms
	30	\| returns (A.While _ :: stms) = returns stms
6ade8b0a	31	\| returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
0a24e44d JW	32
	33	fun breakcheck nil mark = ()
	34	\| breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
	35	raise ErrorMsg.Error )
	36	\| breakcheck (A.Continue :: stms) mark = ( ErrorMsg.error mark ("Illegal continue outside loop") ;
	37	raise ErrorMsg.Error )
	38	\| breakcheck (A.If (_, s1, NONE) :: stms) mark =
	39	( breakcheck s1 mark;
	40	breakcheck stms mark)
	41	\| breakcheck (A.If (_, s1, SOME s2) :: stms) mark =
	42	( breakcheck s1 mark;
	43	breakcheck s2 mark;
	44	breakcheck stms mark)
6ade8b0a	45	\| breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
0a24e44d JW	46	\| breakcheck (_ :: stms) mark = breakcheck stms mark
0a24e44d JW	47
6ade8b0a	48	fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype =
0a24e44d JW	49	( case Symbol.look env v
	50	of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
	51	raise ErrorMsg.Error )
6ade8b0a JW	52	\| SOME (t, UNASSIGNED) => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;
	53	raise ErrorMsg.Error )
	54	\| SOME (t, ASSIGNED) => t)
	55	\| varcheck_exp env fenv (A.ConstExp _) mark = (A.Int)
	56	\| varcheck_exp env fenv (A.OpExp (_, l)) mark = (List.app (fn znt => (varcheck_exp env fenv znt mark; ())) l; A.Int)
	57	\| varcheck_exp env fenv (A.FuncCall (f, l)) mark =
	58	let
	59	val types = map (fn znt => varcheck_exp env fenv znt mark) l
	60	val func = case Symbol.look fenv f
	61	of NONE => ( ErrorMsg.error mark ("undefined function `" ^ Symbol.name f ^ "'") ;
	62	raise ErrorMsg.Error )
	63	\| SOME a => a
	64	val (rtype, params) = case func
	65	of A.Extern (rtype, _, params) => (rtype, params)
	66	\| A.Function (rtype, _, params, _, _) => (rtype, params)
	67	val paramtypes = map (fn (i, t) => t) params
	68	val () = if not (types = paramtypes)
	69	then ( ErrorMsg.error mark ("incorrect parameters for function `" ^ Symbol.name f ^ "'") ;
	70	raise ErrorMsg.Error )
	71	else ()
	72	in
	73	rtype
	74	end
	75	\| varcheck_exp env fenv (A.Marked m) mark = varcheck_exp env fenv (Mark.kane m) (Mark.ext m)
0a24e44d JW	76
	77	fun computeassigns env nil = env
	78	\| computeassigns env (A.Assign (id,e) :: stms) =
6ade8b0a	79	computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms
0a24e44d JW	80	\| computeassigns env (A.Return _ :: stms) = env
	81	\| computeassigns env (A.Nop :: stms) = computeassigns env stms
	82	\| computeassigns env (A.Break :: stms) = env
	83	\| computeassigns env (A.Continue :: stms) = env
	84	\| computeassigns env (A.If (e, s1, NONE) :: stms) = computeassigns env stms
	85	\| computeassigns env (A.If (e, s1, SOME s2) :: stms) =
	86	let
	87	val env1 = computeassigns env s1
	88	val env2 = computeassigns env s2
6ade8b0a JW	89	val env' =
	90	Symbol.intersect
	91	(fn ((t, ASSIGNED), (t', ASSIGNED)) => (t, ASSIGNED) (* XXX check types for equality *)
	92	\| ((t, _), (t', _)) => (t, UNASSIGNED))
	93	(env1, env2)
0a24e44d JW	94	val env' =
	95	if (returns s1) then env2
	96	else if (returns s2) then env1
	97	else env'
	98	in
	99	computeassigns env' stms
	100	end
	101	\| computeassigns env (A.While (e, s1) :: stms) = computeassigns env stms
	102	\| computeassigns env (A.For (sbegin, e, sloop, inner) :: stms) =
	103	let
	104	val env' = case sbegin
	105	of SOME(s) => computeassigns env [s]
	106	\| NONE => env
	107	in
	108	computeassigns env' stms
	109	end
6ade8b0a	110	\| computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
0a24e44d	111
6ade8b0a JW	112	fun varcheck env fenv nil mark = nil
	113	\| varcheck env fenv (A.Assign (id, e) :: stms) mark =
	114	let
	115	val sym = Symbol.look env id
	116	val _ = if not (isSome sym)
	117	then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error)
	118	else ()
	119	val (t, a) = valOf sym
	120	val t' = varcheck_exp env fenv e mark
	121	in
	122	A.Assign (id, e) :: (varcheck (Symbol.bind env (id, (t, ASSIGNED))) fenv stms mark)
	123	end
	124	\| varcheck env fenv (A.Return (e) :: stms) mark =
	125	( varcheck_exp env fenv e mark;
0a24e44d	126	A.Return (e) :: nil )
6ade8b0a JW	127	\| varcheck env fenv (A.Nop :: stms) mark =
	128	( A.Nop :: (varcheck env fenv stms mark))
	129	\| varcheck env fenv (A.Break :: stms) mark =
0a24e44d	130	( A.Break :: nil )
6ade8b0a	131	\| varcheck env fenv (A.Continue :: stms) mark =
0a24e44d	132	( A.Continue :: nil )
6ade8b0a JW	133	\| varcheck env fenv (A.If (e, s1, NONE) :: stms) mark =
	134	( varcheck_exp env fenv e mark ;
	135	varcheck env fenv s1 mark ;
	136	A.If (e, s1, NONE) :: (varcheck env fenv stms mark) )
	137	\| varcheck env fenv ((i as A.If (e, s1, SOME s2)) :: stms) mark =
	138	( varcheck_exp env fenv e mark ;
	139	varcheck env fenv s1 mark ;
	140	varcheck env fenv s2 mark ;
0a24e44d JW	141	A.If (e, s1, SOME s2) ::
	142	(if (returns [i])
	143	then nil
6ade8b0a JW	144	else varcheck (computeassigns env [i]) fenv stms mark) )
	145	\| varcheck env fenv (A.While (e, s1) :: stms) mark =
	146	( varcheck_exp env fenv e mark ;
	147	varcheck env fenv s1 mark ;
	148	A.While (e, s1) :: (varcheck env fenv stms mark) )
	149	\| varcheck env fenv (A.For (sbegin, e, sloop, inner) :: stms) mark =
0a24e44d JW	150	let
0a24e44d JW	151	val sbegin = case sbegin
6ade8b0a	152	of SOME(s) => SOME (hd (varcheck env fenv [s] mark))
0a24e44d JW	153	\| NONE => NONE
	154	val env' = case sbegin
	155	of SOME(s) => computeassigns env [s]
	156	\| NONE => env
6ade8b0a JW	157	val _ = varcheck_exp env' fenv e
6ade8b0a JW	158	val inner = varcheck env' fenv inner mark
0a24e44d JW	159	val env'' = computeassigns env' inner
0a24e44d JW	160	val sloop = case sloop
6ade8b0a	161	of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark))
0a24e44d JW	162	\| NONE => NONE
0a24e44d JW	163	in
6ade8b0a	164	A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark)
0a24e44d	165	end
6ade8b0a	166	\| varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m)
12aa4087	167
6ade8b0a JW	168	fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,(t, stat))) sym l
	169	fun bindfuns sym l =
	170	foldr
	171	(fn (a as (A.Function (_, id, _, _, _)), s) => Symbol.bind s (id, a)
	172	\| (a as (A.Extern (_, id, _)), s) => Symbol.bind s (id, a))
	173	sym l
	174
	175	fun dupchk l =
	176	List.app
	177	(fn (n, _) =>
	178	let
	179	val name = Symbol.name n
	180	val all = List.filter (fn (n', _) => name = (Symbol.name n')) l
	181	val count = length all
	182	in
	183	if count = 1
	184	then ()
	185	else ( ErrorMsg.error NONE ("multiple definition of variable " ^ (Symbol.name n));
	186	raise ErrorMsg.Error )
	187	end) l
	188
	189	fun typecheck_fn p (e as (A.Extern (t, id, al))) = (dupchk al; e)
	190	\| typecheck_fn p (A.Function (t, id, al, vl, sl)) =
	191	let
	192	val () = breakcheck sl NONE
	193	val () = if not (returns sl)
	194	then ( ErrorMsg.error NONE ("function `"^ Symbol.name id ^ "' does not return in all cases");
	195	raise ErrorMsg.Error )
	196	else ()
	197	val env = Symbol.empty
	198	val env = bindvars env ASSIGNED al
	199	val env = bindvars env UNASSIGNED vl
	200	val fenv = bindfuns Symbol.empty p
	201	val () = dupchk (al @ vl)
	202	in
	203	A.Function (t, id, al, vl, varcheck env fenv sl NONE)
	204	end
	205
	206	fun typecheck p =
	207	let
	208	fun getFun n =
	209	List.find (fn A.Extern (_, id, _) => ((Symbol.name id) = n)
	210	\| A.Function (_, id, _, _, _) => ((Symbol.name id) = n))
	211	p
	212	val main = case (getFun "main")
	213	of NONE => ( ErrorMsg.error NONE ("no function named main");
	214	raise ErrorMsg.Error )
	215	\| SOME m => m
	216	val () = case main
	217	of A.Extern _ => ( ErrorMsg.error NONE ("you anus, main can't be an extern");
	218	raise ErrorMsg.Error )
	219	\| A.Function (A.Int, _, nil, _, _) => ()
	220	\| A.Function (A.Int, _, _, _, _) => ( ErrorMsg.error NONE ("main should take no parameters");
	221	raise ErrorMsg.Error )
	222	val () = List.app
	223	(fn a =>
	224	let
	225	val id = case a
	226	of A.Extern (_, id, _) => id
	227	\| A.Function (_, id, _, _, _) => id
	228	val name = Symbol.name id
	229	val all = List.filter
	230	(fn A.Extern (_, id, _) => (Symbol.name id) = name
	231	\| A.Function (_, id, _, _, _) => (Symbol.name id) = name)
232	p
233	val num = length all
234	in
235	if num = 1
236	then ()
237	else ( ErrorMsg.error NONE ("multiple definition of " ^ name);
238	raise ErrorMsg.Error )
239	end) p
240	in
241	List.map (typecheck_fn p) p
242	end
12aa4087	243	end