type/typechecker.sml

   1 (* L3 Compiler
   2  * TypeChecker
   3  * Author: Alex Vaynberg <alv@andrew.cmu.edu>
   4  * Modified: Frank Pfenning <fp@cs.cmu.edu>
   5  * Modified: Joshua Wise <jwise>
   6  * Modified: Chris Lu <czl>
   7  *)
   8
   9 signature TYPE_CHECK =
  10 sig
  11   (* prints error message and raises ErrorMsg.error if error found *)
  12   val typecheck : Ast.program -> Ast.program
  13 end;
  14
  15 structure TypeChecker :> TYPE_CHECK =
  16 struct
  17   structure A = Ast
  18
  19   datatype asn = ASSIGNED | UNASSIGNED
  20
  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
  31     | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
  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)
  45     | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
  46     | breakcheck (_ :: stms) mark = breakcheck stms mark
  47
  48   fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype =
  49         ( case Symbol.look env v
  50           of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
  51                        raise ErrorMsg.Error )
  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)
  76
  77   fun computeassigns env nil = env
  78     | computeassigns env (A.Assign (id,e) :: stms) =
  79         computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms
  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
  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)
  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
 110     | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
 111
 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;
 126           A.Return (e) :: nil )
 127     | varcheck env fenv (A.Nop :: stms) mark =
 128         ( A.Nop :: (varcheck env fenv stms mark))
 129     | varcheck env fenv (A.Break :: stms) mark =
 130         ( A.Break :: nil )
 131     | varcheck env fenv (A.Continue :: stms) mark =
 132         ( A.Continue :: nil )
 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 ;
 141           A.If (e, s1, SOME s2) ::
 142             (if (returns [i])
 143              then nil
 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 =
 150         let
 151           val sbegin = case sbegin
 152                        of SOME(s) => SOME (hd (varcheck env fenv [s] mark))
 153                         | NONE => NONE
 154           val env' = case sbegin
 155                      of SOME(s) => computeassigns env [s]
 156                       | NONE => env
 157           val _ = varcheck_exp env' fenv e
 158           val inner = varcheck env' fenv inner mark
 159           val env'' = computeassigns env' inner
 160           val sloop = case sloop
 161                   of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark))
 162                    | NONE => NONE
 163         in
 164           A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark)
 165         end
 166     | varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m)
 167
 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
 243 end