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