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