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