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   val typeof : Ast.program -> Type.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Type.vtype
  14 end;
  15
  16 structure TypeChecker :> TYPE_CHECK =
  17 struct
  18   structure A = Ast
  19   structure AU = AstUtils
  20   structure T = Type
  21
  22   fun typeof (tds, funcs) vars mark e =
  23     ( case e
  24       of A.Var a => (case Symbol.look vars a
  25                      of NONE => (ErrorMsg.error mark ("variable `"^(Symbol.name a)^"' not declared here") ; raise ErrorMsg.Error)
  26                       | SOME t => t)
  27        | A.Cast (ty, e') => if (T.issmall ty) andalso (T.issmall (typeof (tds, funcs) vars mark e'))
  28                             then ty
  29                             else (ErrorMsg.error mark ("cannot cast: one of `"^(T.Print.pp_type ty)^"' or `"^(T.Print.pp_type (typeof (tds, funcs) vars mark e))^"' was not small"); raise ErrorMsg.Error)
  30        | A.ConstExp _ => T.Int
  31        | A.StringExp _ => T.String
  32        | A.OpExp (A.EQ, [a, b]) =>
  33            (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b)
  34             of (T.Int, T.Int) => T.Int (* You shall pass! *)
  35              | (a', b') =>
  36                  if (T.typeeq (a', T.TNull) andalso T.castable (b', T.TNull)) orelse
  37                     (T.typeeq (b', T.TNull) andalso T.castable (a', T.TNull)) orelse
  38                     (T.typeeq (a', b'))
  39                  then T.Int
  40                  else (ErrorMsg.error mark ("incorrect types for equality opexp:" ^ T.Print.pp_type a' ^ ", " ^ T.Print.pp_type b') ; raise ErrorMsg.Error ))
  41        | A.OpExp (A.NEQ, el) => typeof (tds, funcs) vars mark (A.OpExp (A.EQ, el))
  42        | A.OpExp (_, el) => (List.app
  43                               (fn e =>
  44                                 (case (typeof (tds, funcs) vars mark e)
  45                                  of T.Int => ()
  46                                   | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error)))
  47                               el ; T.Int)
  48        | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e)
  49        | A.FuncCall (i, exps) =>
  50          let
  51            val func = (case Symbol.look funcs i
  52                        of NONE => (ErrorMsg.error mark ("function `"^(Symbol.name i)^"' not declared") ; raise ErrorMsg.Error)
  53                         | SOME f => f)
  54            val funcmark = AU.Function.mark func
  55            val (ftype, fparams) = (AU.Function.returntype func, AU.Function.params func)
  56            val exptypes = List.map (fn znt => typeof (tds, funcs) vars mark znt) exps
  57            val () = if (length exptypes = length fparams) then ()
  58                     else (ErrorMsg.error mark ("call to function `"^(Symbol.name i)^"' has incorrect parameter count [you must construct additional tycons]") ; raise ErrorMsg.Error)
  59            val () = List.app
  60                       (fn (t, (i, t')) =>
  61                         if not (T.castable (t', t))
  62                         then (ErrorMsg.error mark ("parameter `"^(Symbol.name i)^"' in function call has wrong type [you must construct additional tycons]") ; raise ErrorMsg.Error)
  63                         else ())
  64                       (ListPair.zip (exptypes, fparams))
  65          in
  66            ftype
  67          end
  68        | A.Member (e, i) =>
  69          let
  70            val t = typeof (tds, funcs) vars mark e
  71            val name = case t
  72                       of (T.Typedef i) => i
  73                        | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error)
  74            val s = case Symbol.look tds name
  75                    of SOME s => s
  76                     | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
  77            val (s, smark) = (T.defdata s, T.defmark s)
  78            val vl = case s
  79                     of T.Struct vl => vl
  80                      | _ => raise ErrorMsg.InternalError "mark of marked typedef?"
  81            val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl)
  82                    of SOME (_, t) => t
  83                     | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error)
  84          in
  85            t
  86          end
  87        | A.DerefMember (e, i) =>
  88          let
  89            val t = typeof (tds, funcs) vars mark e
  90            val name = case t
  91                       of (T.Pointer (T.Typedef i)) => i
  92                        | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error)
  93            val s = case Symbol.look tds name
  94                    of SOME s => s
  95                     | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
  96            val (s, smark) = case s
  97                             of T.Struct vl => (s, NONE)
  98                              | T.MarkedTypedef m => (Mark.data m, Mark.ext m)
  99            val vl = case s
 100                     of T.Struct vl => vl
 101                      | _ => raise ErrorMsg.InternalError "mark of marked typedef?"
 102            val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl)
 103                    of SOME (_, t) => t
 104                     | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error)
 105          in
 106            t
 107          end
 108        | A.Dereference e =>
 109          (case typeof (tds, funcs) vars mark e
 110           of (T.Pointer e') => e'
 111            | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error))
 112        | A.ArrIndex (e, i) =>
 113          (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i)
 114           of (T.Array e', T.Int) => e'
 115            | (_, T.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error)
 116            | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error))
 117        | A.New (t) => T.Pointer t
 118        | A.NewArr (t, s) =>
 119          (case typeof (tds, funcs) vars mark s
 120           of T.Int => (T.Array t)
 121            | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error))
 122        | A.Null => T.TNull
 123        | A.Conditional (q, e1, e2) =>
 124          let
 125            val _ = case typeof (tds, funcs) vars mark q
 126                    of T.Int => ()
 127                     | _ => (ErrorMsg.error mark ("ternary condition not of Int type") ; raise ErrorMsg.Error)
 128            val t1 = typeof (tds, funcs) vars mark e1
 129            val t2 = typeof (tds, funcs) vars mark e2
 130          in
 131            if (T.typeeq (t1, t2) orelse T.castable (t1, t2))
 132            then t1
 133            else if (T.castable (t2, t1))
 134            then t2
 135            else (ErrorMsg.error mark ("ternary types do not agree [you must construct additional tycons]") ; raise ErrorMsg.Error)
 136          end
 137     )
 138
 139   datatype asn = ASSIGNED | UNASSIGNED
 140
 141   (* returncheck prog vars mark t l
 142    * Determines if the statement list 'l' is guaranteed to return vtype 't'.
 143    * If it ever does not return vtype 't', then raises an error.
 144    * true if vtype 't' is always returned, or false if there is a possibility that vtype 't' will not be returned.
 145    *)
 146   fun returncheck prog vars mark t l =
 147     let
 148       fun returns' nil = false
 149         | returns' (A.Assign _ :: stms) = returns' stms
 150         | returns' (A.AsnOp _ :: stms) = returns' stms
 151         | returns' (A.Effect _ :: stms) = returns' stms
 152         | returns' (A.Return e :: stms) =
 153             if (T.castable (t, typeof prog vars mark e))
 154             then true
 155             else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error)
 156         | returns' (A.Nop :: stms) = returns' stms
 157         | returns' (A.Break :: stms) = true (* blah *)
 158         | returns' (A.Continue :: stms) = true (* blah *)
 159         | returns' (A.If (_, s1, NONE) :: stms) = returns' stms
 160         | returns' (A.If (_, s1, SOME s2) :: stms) = (returns' s1 andalso returns' s2) orelse returns' stms
 161         | returns' (A.For _ :: stms) = returns' stms
 162         | returns' (A.While _ :: stms) = returns' stms
 163         | returns' (A.MarkedStm m :: stms) = returncheck prog vars (Mark.ext m) t (Mark.kane m :: stms)
 164     in
 165       returns' l
 166     end
 167
 168   (* returns l
 169    * true iff the statement list 'l' always returns.
 170    *)
 171   fun returns nil = false
 172     | returns (A.Assign _ :: stms) = returns stms
 173     | returns (A.AsnOp _ :: stms) = returns stms
 174     | returns (A.Effect _ :: stms) = returns stms
 175     | returns (A.Return e :: stms) = true
 176     | returns (A.Nop :: stms) = returns stms
 177     | returns (A.Break :: stms) = true (* blah *)
 178     | returns (A.Continue :: stms) = true (* blah *)
 179     | returns (A.If (_, s1, NONE) :: stms) = returns stms
 180     | returns (A.If (_, s1, SOME s2) :: stms) = (returns s1 andalso returns s2) orelse returns stms
 181     | returns (A.For _ :: stms) = returns stms
 182     | returns (A.While _ :: stms) = returns stms
 183     | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
 184
 185   (* breakcheck l mark
 186    * Throws an error exception if a break or continue ever occurs in an illegal context.
 187    *)
 188   fun breakcheck nil mark = ()
 189     | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
 190                                              raise ErrorMsg.Error )
 191     | breakcheck (A.Continue :: stms) mark = ( ErrorMsg.error mark ("Illegal continue outside loop") ;
 192                                                 raise ErrorMsg.Error )
 193     | breakcheck (A.If (_, s1, NONE) :: stms) mark =
 194         ( breakcheck s1 mark;
 195           breakcheck stms mark)
 196     | breakcheck (A.If (_, s1, SOME s2) :: stms) mark =
 197         ( breakcheck s1 mark;
 198           breakcheck s2 mark;
 199           breakcheck stms mark)
 200     | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
 201     | breakcheck (_ :: stms) mark = breakcheck stms mark
 202
 203   (* varcheck_exp env exp mark
 204    * Throws an error exception if a variable used in this excpression was unassigned or undefined in this context.
 205    *)
 206   fun varcheck_exp env (A.Var v) mark =
 207         ( case Symbol.look env v
 208           of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
 209                        raise ErrorMsg.Error )
 210            | SOME UNASSIGNED => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;
 211                                   raise ErrorMsg.Error )
 212            | SOME ASSIGNED => ())
 213     | varcheck_exp env (A.Cast (ty, e)) mark = varcheck_exp env e mark
 214     | varcheck_exp env (A.ConstExp _) mark = ()
 215     | varcheck_exp env (A.StringExp _) mark = ()
 216     | varcheck_exp env (A.OpExp (_, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l
 217     | varcheck_exp env (A.FuncCall (f, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l
 218     | varcheck_exp env (A.Marked m) mark = varcheck_exp env (Mark.kane m) (Mark.ext m)
 219     | varcheck_exp env (A.Member (e, i)) mark = varcheck_exp env e mark
 220     | varcheck_exp env (A.DerefMember (e, i)) mark = varcheck_exp env e mark
 221     | varcheck_exp env (A.Dereference e) mark = varcheck_exp env e mark
 222     | varcheck_exp env (A.ArrIndex (e1, e2)) mark = (varcheck_exp env e1 mark ; varcheck_exp env e2 mark)
 223     | varcheck_exp env (A.New _) mark = ()
 224     | varcheck_exp env (A.NewArr (_, e)) mark = varcheck_exp env e mark
 225     | varcheck_exp env (A.Null) mark = ()
 226     | varcheck_exp env (A.Conditional (q, e1, e2)) mark = (varcheck_exp env q mark ; varcheck_exp env e1 mark ; varcheck_exp env e2 mark)
 227
 228   (* computeassigns env exp
 229    * Computes the assigned variables after expression exp has been executed with a starting context of env.
 230    *)
 231   fun computeassigns env nil = env
 232     | computeassigns env (A.Assign (A.Var id,e) :: stms) =
 233         computeassigns (Symbol.bind env (id, ASSIGNED)) stms
 234     | computeassigns env (A.Assign (A.Marked a, e) :: stms) =
 235         computeassigns env (A.Assign (Mark.data a, e) :: stms)
 236     | computeassigns env (A.AsnOp (oper, a, e) :: stms) =
 237         computeassigns env (A.Assign (a, a) :: stms)
 238     | computeassigns env (A.Assign (_) :: stms) = computeassigns env stms
 239     | computeassigns env (A.Effect _ :: stms) = computeassigns env stms
 240     | computeassigns env (A.Return _ :: stms) = env
 241     | computeassigns env (A.Nop :: stms) = computeassigns env stms
 242     | computeassigns env (A.Break :: stms) = env
 243     | computeassigns env (A.Continue :: stms) = env
 244     | computeassigns env (A.If (e, s1, NONE) :: stms) = computeassigns env stms
 245     | computeassigns env (A.If (e, s1, SOME s2) :: stms) =
 246         let
 247           val env1 = computeassigns env s1
 248           val env2 = computeassigns env s2
 249           val env' =
 250             Symbol.intersect
 251               (fn (ASSIGNED, ASSIGNED) => ASSIGNED
 252                 | _ => UNASSIGNED)
 253               (env1, env2)
 254           val env' =
 255             if (returns s1) then env2
 256             else if (returns s2) then env1
 257             else env'
 258         in
 259           computeassigns env' stms
 260         end
 261     | computeassigns env (A.While (e, s1) :: stms) = computeassigns env stms
 262     | computeassigns env (A.For (sbegin, e, sloop, inner) :: stms) =
 263        let
 264          val env' = case sbegin
 265                     of SOME(s) => computeassigns env [s]
 266                      | NONE => env
 267        in
 268          computeassigns env' stms
 269        end
 270     | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
 271
 272   (* varcheck env l mark
 273    * Checks that all variables used in the statement list l have been defined before being used, and removes code that is unreachable according to simple return analysis.
 274    *)
 275   fun varcheck env nil mark = nil
 276     | varcheck env (A.Assign (A.Var id, e) :: stms) mark =
 277         let
 278           val sym = Symbol.look env id
 279           val _ = if not (isSome sym)
 280                   then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error)
 281                   else ()
 282           val t = valOf sym
 283           val _ = varcheck_exp env e mark
 284         in
 285           A.Assign (A.Var id, e) :: (varcheck (Symbol.bind env (id, ASSIGNED)) stms mark)
 286         end
 287     | varcheck env (A.Assign (A.Marked a, e) :: stms) mark = varcheck env (A.Assign (Mark.data a, e) :: stms) mark
 288     | varcheck env ((a as A.Assign (A.Member (e', i), e)) :: stms) mark =
 289         (varcheck_exp env e' mark ;
 290          varcheck_exp env e mark ;
 291          a :: varcheck env stms mark)
 292     | varcheck env ((a as A.Assign (A.DerefMember (e', i), e)) :: stms) mark =
 293         (varcheck_exp env e' mark ;
 294          varcheck_exp env e mark ;
 295          a :: varcheck env stms mark)
 296     | varcheck env ((a as A.Assign (A.Dereference e', e)) :: stms) mark =
 297         (varcheck_exp env e' mark ;
 298          varcheck_exp env e mark ;
 299          a :: varcheck env stms mark)
 300     | varcheck env ((a as A.Assign (A.ArrIndex (e', e''), e)) :: stms) mark =
 301         (varcheck_exp env e' mark ;
 302          varcheck_exp env e'' mark ;
 303          varcheck_exp env e mark ;
 304          a :: varcheck env stms mark)
 305     | varcheck env ((a as A.Assign (A.NewArr (_, e'), e)) :: stms) mark =
 306         (varcheck_exp env e' mark ;
 307          varcheck_exp env e mark ;
 308          a :: varcheck env stms mark)
 309     | varcheck env ((A.Assign _) :: stms) mark = raise ErrorMsg.InternalError "assign to non lvalue"
 310     | varcheck env ((a as A.AsnOp (oper, e1, e2)) :: stms) mark = ( varcheck_exp env e1 mark ; varcheck_exp env e2 mark ; a :: varcheck env stms mark )
 311     | varcheck env ((a as A.Effect e) :: stms) mark = (varcheck_exp env e mark ; a :: varcheck env stms mark)
 312     | varcheck env (A.Return (e) :: stms) mark =
 313         ( varcheck_exp env e mark;
 314           A.Return (e) :: nil )
 315     | varcheck env (A.Nop :: stms) mark =
 316         ( A.Nop :: (varcheck env stms mark))
 317     | varcheck env (A.Break :: stms) mark =
 318         ( A.Break :: nil )
 319     | varcheck env (A.Continue :: stms) mark =
 320         ( A.Continue :: nil )
 321     | varcheck env (A.If (e, s1, NONE) :: stms) mark =
 322         ( varcheck_exp env e mark ;
 323           varcheck env s1 mark ;
 324           A.If (e, s1, NONE) :: (varcheck env stms mark) )
 325     | varcheck env ((i as A.If (e, s1, SOME s2)) :: stms) mark =
 326         ( varcheck_exp env e mark ;
 327           varcheck env s1 mark ;
 328           varcheck env s2 mark ;
 329           A.If (e, s1, SOME s2) ::
 330             (if (returns [i])
 331              then nil
 332              else varcheck (computeassigns env [i]) stms mark)  )
 333     | varcheck env (A.While (e, s1) :: stms) mark =
 334         ( varcheck_exp env e mark ;
 335           varcheck env s1 mark ;
 336           A.While (e, s1) :: (varcheck env stms mark) )
 337     | varcheck env (A.For (sbegin, e, sloop, inner) :: stms) mark =
 338         let
 339           val sbegin = case sbegin
 340                        of SOME(s) => SOME (hd (varcheck env [s] mark))
 341                         | NONE => NONE
 342           val env' = case sbegin
 343                      of SOME(s) => computeassigns env [s]
 344                       | NONE => env
 345           val _ = varcheck_exp env' e mark
 346           val inner = varcheck env' inner mark
 347           val env'' = computeassigns env' inner
 348           val sloop = case sloop
 349                   of SOME(s) => SOME (hd (varcheck env'' [s] mark))
 350                    | NONE => NONE
 351         in
 352           A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark)
 353         end
 354     | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.kane m) :: stms) (Mark.ext m)
 355
 356   fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,stat)) sym l
 357   fun bindtypes sym l = foldr (fn ((i,t), s) => Symbol.bind s (i,t)) sym l
 358
 359   fun dupchk mark l src =
 360         List.app
 361           (fn (n, _) =>
 362             let
 363               val name = Symbol.name n
 364               val all = List.filter (fn (n', _) => name = (Symbol.name n')) l
 365               val count = length all
 366             in
 367               if count = 1
 368               then ()
 369               else ( ErrorMsg.error mark ("multiple definition of variable " ^ (Symbol.name n) ^ " in " ^ src);
 370                      raise ErrorMsg.Error )
 371             end) l
 372
 373   fun check_lvalue prog vars mark (A.Marked m) = check_lvalue prog vars (Mark.ext m) (Mark.data m)
 374     | check_lvalue prog vars mark (e as A.Var _) = typeof prog vars mark e
 375     | check_lvalue prog vars mark (e as A.Member _) = typeof prog vars mark e
 376     | check_lvalue prog vars mark (e as A.DerefMember _) = typeof prog vars mark e
 377     | check_lvalue prog vars mark (e as A.Dereference _) = typeof prog vars mark e
 378     | check_lvalue prog vars mark (e as A.ArrIndex _) = typeof prog vars mark e
 379     | check_lvalue prog vars mark _ = ( ErrorMsg.error mark ("invalid lvalue") ; raise ErrorMsg.Error )
 380   fun typecheck_stm prog vars mark stm =
 381     case stm
 382     of A.Assign (e1, e2) =>
 383          if not (T.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2))
 384          then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error )
 385          else if not (T.issmall (check_lvalue prog vars mark e1))
 386          then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error)
 387          else ()
 388      | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2])))
 389      | A.Effect e =>
 390          if not (T.issmall (typeof prog vars mark e))
 391          then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error )
 392          else ()
 393      | A.Return e => (typeof prog vars mark e ; ())
 394      | A.Nop => ()
 395      | A.Break => ()
 396      | A.Continue => ()
 397      | A.If (e, s, NONE) =>
 398          if T.castable (T.Int, typeof prog vars mark e)
 399          then (List.app (typecheck_stm prog vars mark) s)
 400          else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
 401      | A.If (e, s1, SOME s2) =>
 402          if T.castable (T.Int, typeof prog vars mark e)
 403          then (List.app (typecheck_stm prog vars mark) s1 ; List.app (typecheck_stm prog vars mark) s2)
 404          else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
 405      | A.For (sbegin, e, sloop, s) =>
 406          if T.castable (T.Int, typeof prog vars mark e)
 407          then (List.app (typecheck_stm prog vars mark) ((case sbegin of SOME l => [l] | NONE => nil) @ (case sloop of SOME l => [l] | NONE => nil) @ s))
 408          else (ErrorMsg.error mark "conditional in for statement is not of int type" ; raise ErrorMsg.Error )
 409      | A.While (e, s) =>
 410          if T.castable (T.Int, typeof prog vars mark e)
 411          then (List.app (typecheck_stm prog vars mark) s)
 412          else (ErrorMsg.error mark "conditional in while statement is not of int type" ; raise ErrorMsg.Error )
 413      | A.MarkedStm (m) => typecheck_stm prog vars (Mark.ext m) (Mark.data m)
 414
 415   (* XXX does not check big vs. small types *)
 416   fun typecheck_type (tds, funcs) mark T.Int = ()
 417     | typecheck_type (tds, funcs) mark T.String = ()
 418     | typecheck_type (tds, funcs) mark T.TNull = ()
 419     | typecheck_type (tds, funcs) mark (T.Pointer t) = typecheck_type (tds, funcs) mark t
 420     | typecheck_type (tds, funcs) mark (T.Array t) = typecheck_type (tds, funcs) mark t
 421     | typecheck_type (tds, funcs) mark (T.Typedef t) =
 422         case (Symbol.look tds t)
 423         of SOME _ => ()
 424          | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error)
 425
 426   fun typecheck_fn prog _ (id, A.MarkedFunction m) = typecheck_fn prog (Mark.ext m) (id, Mark.data m)
 427     | typecheck_fn (prog as (tds, funcs)) mark (id, A.Extern (t, al)) =
 428       (if (String.isPrefix "_l5_" (Symbol.name id))
 429        then
 430          let
 431            val n = String.extract (Symbol.name id, 4, NONE)
 432          in
 433            if List.exists (fn (id, f) => case (AU.Function.data f) of A.Function _ => (Symbol.name id = n) | _ => false) (Symbol.elemsi funcs)
 434            then (ErrorMsg.error mark ("you anus, extern " ^ Symbol.name id ^ " conflicts with local function"); raise ErrorMsg.Error)
 435            else ()
 436          end
 437        else () ;
 438        dupchk mark al ;
 439        List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) al) ;
 440        A.Extern (t, al))
 441     | typecheck_fn prog mark (id, A.Function (t, al, vl, sl)) =
 442       let
 443         val () = dupchk mark (al @ vl) ("function `"^Symbol.name id^"'")        (* Before we do any bindings, check for duplicate names. *)
 444         val () = List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) (al @ vl))
 445         val env = Symbol.empty
 446         val env = bindvars env ASSIGNED al
 447         val env = bindvars env UNASSIGNED vl
 448         val vars = Symbol.empty
 449         val vars = bindtypes vars al
 450         val vars = bindtypes vars vl
 451         val () = breakcheck sl mark
 452         val () = if not (returncheck prog vars NONE t sl)
 453                  then ( ErrorMsg.error mark ("function `"^ Symbol.name id ^ "' does not return in all cases");
 454                         raise ErrorMsg.Error )
 455                  else ()
 456         val () = List.app (
 457                   fn (n, t) =>
 458                     if (T.issmall t)
 459                     then ()
 460                     else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error))
 461                  (al @ vl)
 462         val () = List.app (typecheck_stm prog vars mark) sl
 463       in
 464         A.Function (t, al, vl, varcheck env sl NONE)
 465       end
 466
 467   structure SymbolSet = ListSetFn (
 468     struct
 469       type ord_key = Symbol.symbol
 470       val compare = Symbol.compare
 471     end
 472   )
 473
 474   fun typecheck_structs (prog as (tds, funcs)) =
 475     let
 476       exception Yuq
 477
 478       val all = SymbolSet.addList (SymbolSet.empty, Symbol.keys tds)
 479       fun lookup mark sym =
 480         let
 481           val s = case Symbol.look tds sym
 482                   of SOME a => a
 483                    | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name sym)^"' does not exist") ; raise ErrorMsg.Error)
 484           val vl = case T.defdata s
 485                    of T.Struct vl => vl
 486                     | T.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type"
 487         in
 488           (vl, T.defmark s)
 489         end
 490       fun checksym mark sym stack k remaining =
 491         if not (SymbolSet.member (remaining, sym))
 492         then k remaining
 493         else if (SymbolSet.member (stack, sym))
 494         then ( ErrorMsg.error mark ("structure `"^ (Symbol.name sym) ^"' is involved in a recursive mess") ; raise Yuq)
 495         else
 496           let
 497             val stack' = SymbolSet.add (stack, sym)
 498             val (vl, mark') = lookup mark sym
 499             val () = dupchk mark vl ("structure `"^(Symbol.name sym)^"'")
 500             fun remove k remaining' = k (SymbolSet.delete (remaining', sym))
 501             val newk = (* OH GOD D: *)
 502               foldr
 503                 (fn ((_, T.Typedef s), k') => checksym mark' s stack' k'
 504                   | (_, k') => k')
 505                 (remove k)
 506                 vl
 507           in
 508             newk remaining handle Yuq => (ErrorMsg.error mark' ("from structure `"^(Symbol.name sym)^"'") ; raise Yuq)
 509           end
 510       fun chooseone k set =
 511         case (SymbolSet.listItems set)
 512         of nil => k set
 513          | (h::l) => checksym NONE h SymbolSet.empty (chooseone k) set
 514     in
 515       chooseone (fn _ => ()) all handle Yuq => raise ErrorMsg.Error
 516     end
 517
 518   fun typecheck (tds, funcs) =
 519       let
 520         val main = case (Symbol.look funcs (Symbol.symbol "main"))
 521                    of NONE => ( ErrorMsg.error NONE ("no function named main");
 522                                 raise ErrorMsg.Error )
 523                     | SOME m => m
 524         val (main, mainp) = (AU.Function.data main, AU.Function.mark main)
 525         val () = case main
 526                  of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern");
 527                                     raise ErrorMsg.Error )
 528                   | A.Function (T.Int, nil, _, _) => ()
 529                   | A.Function (T.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");
 530                                                         raise ErrorMsg.Error )
 531                   | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type");
 532                                                  raise ErrorMsg.Error )
 533                   | _ => raise ErrorMsg.InternalError "marked of marked disallowed"
 534         val () = typecheck_structs (tds, funcs)
 535       in
 536         (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs)
 537       end
 538 end