Propagate strings through the blarg backend.

[snipe.git] / type / typechecker.sml

diff --git a/type/typechecker.sml b/type/typechecker.sml
index 699d15ab97693516210ef7dce8aa30ec06c83f8f..8be373158bbeac5c1bea4c2e34d473f919ac6436 100644 (file)
--- a/type/typechecker.sml
+++ b/type/typechecker.sml
@@ -1,49 +1,534 @@
-(* L1 Compiler
+(* L3 Compiler

  * TypeChecker
  * Author: Alex Vaynberg <alv@andrew.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>
  * TypeChecker
  * Author: Alex Vaynberg <alv@andrew.cmu.edu>
  * Modified: Frank Pfenning <fp@cs.cmu.edu>

- *
- * Simple typechecker that is based on a unit Symbol.table
- * This is all that is needed since there is only an integer type present
+ * Modified: Joshua Wise <jwise>
+ * Modified: Chris Lu <czl>

  *) 
 
 signature TYPE_CHECK =
 sig
   (* prints error message and raises ErrorMsg.error if error found *)
  *) 
 
 signature TYPE_CHECK =
 sig
   (* prints error message and raises ErrorMsg.error if error found *)

-  val typecheck : Ast.program -> unit
+  val typecheck : Ast.program -> Ast.program
+  val typeof : Ast.program -> Type.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Type.vtype

 end;
 
 structure TypeChecker :> TYPE_CHECK = 
 struct
   structure A = Ast
 end;
 
 structure TypeChecker :> TYPE_CHECK = 
 struct
   structure A = Ast

+  structure AU = AstUtils
+  structure T = Type
+  
+  fun typeof (tds, funcs) vars mark e =
+    ( case e
+      of A.Var a => (case Symbol.look vars a
+                     of NONE => (ErrorMsg.error mark ("variable `"^(Symbol.name a)^"' not declared here") ; raise ErrorMsg.Error)
+                      | SOME t => t)
+       | A.ConstExp _ => T.Int
+       | A.StringExp _ => T.String
+       | A.OpExp (A.EQ, [a, b]) =>
+           (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b)
+            of (T.Int, T.Int) => T.Int (* You shall pass! *)
+             | (a', b') =>
+                 if (T.typeeq (a', T.TNull) andalso T.castable (b', T.TNull)) orelse
+                    (T.typeeq (b', T.TNull) andalso T.castable (a', T.TNull)) orelse
+                    (T.typeeq (a', b'))
+                 then T.Int
+                 else (ErrorMsg.error mark ("incorrect types for equality opexp:" ^ T.Print.pp_type a' ^ ", " ^ T.Print.pp_type b') ; raise ErrorMsg.Error ))
+       | A.OpExp (A.NEQ, el) => typeof (tds, funcs) vars mark (A.OpExp (A.EQ, el))
+       | A.OpExp (_, el) => (List.app
+                              (fn e =>
+                                (case (typeof (tds, funcs) vars mark e)
+                                 of T.Int => ()
+                                  | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error)))
+                              el ; T.Int)
+       | A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e)
+       | A.FuncCall (i, exps) =>
+         let
+           val func = (case Symbol.look funcs i
+                       of NONE => (ErrorMsg.error mark ("function `"^(Symbol.name i)^"' not declared") ; raise ErrorMsg.Error)
+                        | SOME f => f)
+           val funcmark = AU.Function.mark func
+           val (ftype, fparams) = (AU.Function.returntype func, AU.Function.params func)
+           val exptypes = List.map (fn znt => typeof (tds, funcs) vars mark znt) exps
+           val () = if (length exptypes = length fparams) then ()
+                    else (ErrorMsg.error mark ("call to function `"^(Symbol.name i)^"' has incorrect parameter count [you must construct additional tycons]") ; raise ErrorMsg.Error)
+           val () = List.app
+                      (fn (t, (i, t')) =>
+                        if not (T.castable (t', t))
+                        then (ErrorMsg.error mark ("parameter `"^(Symbol.name i)^"' in function call has wrong type [you must construct additional tycons]") ; raise ErrorMsg.Error)
+                        else ())
+                      (ListPair.zip (exptypes, fparams))
+         in
+           ftype
+         end
+       | A.Member (e, i) =>
+         let
+           val t = typeof (tds, funcs) vars mark e
+           val name = case t
+                      of (T.Typedef i) => i
+                       | _ => (ErrorMsg.error mark ("member operation only exists for struct types") ; raise ErrorMsg.Error)
+           val s = case Symbol.look tds name
+                   of SOME s => s
+                    | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
+           val (s, smark) = (T.defdata s, T.defmark s)
+           val vl = case s
+                    of T.Struct vl => vl
+                     | _ => raise ErrorMsg.InternalError "mark of marked typedef?"
+           val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl)
+                   of SOME (_, t) => t
+                    | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error)
+         in
+           t
+         end
+       | A.DerefMember (e, i) =>
+         let
+           val t = typeof (tds, funcs) vars mark e
+           val name = case t
+                      of (T.Pointer (T.Typedef i)) => i
+                       | _ => (ErrorMsg.error mark ("dereference and member operation only exists for struct pointer types") ; raise ErrorMsg.Error)
+           val s = case Symbol.look tds name
+                   of SOME s => s
+                    | NONE => (ErrorMsg.error mark ("undefined structure `"^(Symbol.name name)^"' in type") ; raise ErrorMsg.Error)
+           val (s, smark) = case s
+                            of T.Struct vl => (s, NONE)
+                             | T.MarkedTypedef m => (Mark.data m, Mark.ext m)
+           val vl = case s
+                    of T.Struct vl => vl
+                     | _ => raise ErrorMsg.InternalError "mark of marked typedef?"
+           val t = case (List.find (fn (i', t) => (Symbol.name i = Symbol.name i')) vl)
+                   of SOME (_, t) => t
+                    | NONE => (ErrorMsg.error mark ("undefined member `"^(Symbol.name i)^"' in struct") ; ErrorMsg.error smark ("struct `"^(Symbol.name name)^"' defined here") ; raise ErrorMsg.Error)
+         in
+           t
+         end
+       | A.Dereference e =>
+         (case typeof (tds, funcs) vars mark e
+          of (T.Pointer e') => e'
+           | _ => (ErrorMsg.error mark ("cannot deference non-pointer type") ; raise ErrorMsg.Error))
+       | A.ArrIndex (e, i) =>
+         (case (typeof (tds, funcs) vars mark e, typeof (tds, funcs) vars mark i)
+          of (T.Array e', T.Int) => e'
+           | (_, T.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error)
+           | _ => (ErrorMsg.error mark ("cannot index using non-int type") ; raise ErrorMsg.Error))
+       | A.New (t) => T.Pointer t
+       | A.NewArr (t, s) =>
+         (case typeof (tds, funcs) vars mark s
+          of T.Int => (T.Array t)
+           | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error))
+       | A.Null => T.TNull
+       | A.Conditional (q, e1, e2) =>
+         let
+           val _ = case typeof (tds, funcs) vars mark q
+                   of T.Int => ()
+                    | _ => (ErrorMsg.error mark ("ternary condition not of Int type") ; raise ErrorMsg.Error)
+           val t1 = typeof (tds, funcs) vars mark e1
+           val t2 = typeof (tds, funcs) vars mark e2
+         in
+           if (T.typeeq (t1, t2) orelse T.castable (t1, t2))
+           then t1
+           else if (T.castable (t2, t1))
+           then t2
+           else (ErrorMsg.error mark ("ternary types do not agree [you must construct additional tycons]") ; raise ErrorMsg.Error)
+         end
+    )
+  
+  datatype asn = ASSIGNED | UNASSIGNED

 
 

-  (* tc_exp : unit Symbol.table -> Ast.exp -> Mark.ext option -> unit *)
-  fun tc_exp env (A.Var(id)) ext =
-      (case Symbol.look env id
-       of NONE => ( ErrorMsg.error ext ("undefined variable `" ^ Symbol.name id ^ "'") ;
-                    raise ErrorMsg.Error )
-         | SOME _ => ())
-    | tc_exp env (A.ConstExp(c)) ext = ()
-    | tc_exp env (A.OpExp(oper,es)) ext =
-      (* Note: it is syntactically impossible in this language to
-       * apply an operator to an incorrect number of arguments
-       * so we only check each of the arguments
-       *)
-       List.app (fn e => tc_exp env e ext) es
-    | tc_exp env (A.Marked(marked_exp)) ext =
-        tc_exp env (Mark.data marked_exp) (Mark.ext marked_exp)
+  (* returncheck prog vars mark t l
+   * Determines if the statement list 'l' is guaranteed to return vtype 't'.
+   * If it ever does not return vtype 't', then raises an error.
+   * true if vtype 't' is always returned, or false if there is a possibility that vtype 't' will not be returned.
+   *)
+  fun returncheck prog vars mark t l =
+    let
+      fun returns' nil = false
+        | returns' (A.Assign _ :: stms) = returns' stms
+        | returns' (A.AsnOp _ :: stms) = returns' stms
+        | returns' (A.Effect _ :: stms) = returns' stms
+        | returns' (A.Return e :: stms) =
+            if (T.castable (t, typeof prog vars mark e))
+            then true
+            else (ErrorMsg.error mark ("return value of incorrect type for function") ; raise ErrorMsg.Error)
+        | returns' (A.Nop :: stms) = returns' stms
+        | returns' (A.Break :: stms) = true (* blah *)
+        | returns' (A.Continue :: stms) = true (* blah *)
+        | returns' (A.If (_, s1, NONE) :: stms) = returns' stms
+        | returns' (A.If (_, s1, SOME s2) :: stms) = (returns' s1 andalso returns' s2) orelse returns' stms
+        | returns' (A.For _ :: stms) = returns' stms
+        | returns' (A.While _ :: stms) = returns' stms
+        | returns' (A.MarkedStm m :: stms) = returncheck prog vars (Mark.ext m) t (Mark.kane m :: stms)
+    in
+      returns' l
+    end
+  
+  (* returns l
+   * true iff the statement list 'l' always returns.
+   *)
+  fun returns nil = false
+    | returns (A.Assign _ :: stms) = returns stms
+    | returns (A.AsnOp _ :: stms) = returns stms
+    | returns (A.Effect _ :: stms) = returns stms
+    | returns (A.Return e :: stms) = true
+    | returns (A.Nop :: stms) = returns stms
+    | returns (A.Break :: stms) = true (* blah *)
+    | returns (A.Continue :: stms) = true (* blah *)
+    | returns (A.If (_, s1, NONE) :: stms) = returns stms
+    | returns (A.If (_, s1, SOME s2) :: stms) = (returns s1 andalso returns s2) orelse returns stms
+    | returns (A.For _ :: stms) = returns stms
+    | returns (A.While _ :: stms) = returns stms
+    | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: stms)
+  
+  (* breakcheck l mark
+   * Throws an error exception if a break or continue ever occurs in an illegal context.
+   *)
+  fun breakcheck nil mark = ()
+    | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
+                                             raise ErrorMsg.Error )
+    | breakcheck (A.Continue :: stms) mark = ( ErrorMsg.error mark ("Illegal continue outside loop") ;
+                                                raise ErrorMsg.Error )
+    | breakcheck (A.If (_, s1, NONE) :: stms) mark =
+        ( breakcheck s1 mark;
+          breakcheck stms mark)
+    | breakcheck (A.If (_, s1, SOME s2) :: stms) mark =
+        ( breakcheck s1 mark;
+          breakcheck s2 mark;
+          breakcheck stms mark)
+    | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
+    | breakcheck (_ :: stms) mark = breakcheck stms mark
+  
+  (* varcheck_exp env exp mark
+   * Throws an error exception if a variable used in this excpression was unassigned or undefined in this context.
+   *)
+  fun varcheck_exp env (A.Var v) mark =
+        ( case Symbol.look env v
+          of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
+                       raise ErrorMsg.Error )
+           | SOME UNASSIGNED => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;
+                                  raise ErrorMsg.Error )
+           | SOME ASSIGNED => ())
+    | varcheck_exp env (A.ConstExp _) mark = ()
+    | varcheck_exp env (A.StringExp _) mark = ()
+    | varcheck_exp env (A.OpExp (_, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l
+    | varcheck_exp env (A.FuncCall (f, l)) mark = List.app (fn znt => varcheck_exp env znt mark) l
+    | varcheck_exp env (A.Marked m) mark = varcheck_exp env (Mark.kane m) (Mark.ext m)
+    | varcheck_exp env (A.Member (e, i)) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.DerefMember (e, i)) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.Dereference e) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.ArrIndex (e1, e2)) mark = (varcheck_exp env e1 mark ; varcheck_exp env e2 mark)
+    | varcheck_exp env (A.New _) mark = ()
+    | varcheck_exp env (A.NewArr (_, e)) mark = varcheck_exp env e mark
+    | varcheck_exp env (A.Null) mark = ()
+    | varcheck_exp env (A.Conditional (q, e1, e2)) mark = (varcheck_exp env q mark ; varcheck_exp env e1 mark ; varcheck_exp env e2 mark)
+  
+  (* computeassigns env exp
+   * Computes the assigned variables after expression exp has been executed with a starting context of env.
+   *)
+  fun computeassigns env nil = env
+    | computeassigns env (A.Assign (A.Var id,e) :: stms) =
+        computeassigns (Symbol.bind env (id, ASSIGNED)) stms
+    | computeassigns env (A.Assign (A.Marked a, e) :: stms) =
+        computeassigns env (A.Assign (Mark.data a, e) :: stms)
+    | computeassigns env (A.AsnOp (oper, a, e) :: stms) =
+        computeassigns env (A.Assign (a, a) :: stms)
+    | computeassigns env (A.Assign (_) :: stms) = computeassigns env stms
+    | computeassigns env (A.Effect _ :: stms) = computeassigns env stms
+    | computeassigns env (A.Return _ :: stms) = env
+    | computeassigns env (A.Nop :: stms) = computeassigns env stms
+    | computeassigns env (A.Break :: stms) = env
+    | computeassigns env (A.Continue :: stms) = env
+    | computeassigns env (A.If (e, s1, NONE) :: stms) = computeassigns env stms
+    | computeassigns env (A.If (e, s1, SOME s2) :: stms) =
+        let
+          val env1 = computeassigns env s1
+          val env2 = computeassigns env s2
+          val env' =
+            Symbol.intersect
+              (fn (ASSIGNED, ASSIGNED) => ASSIGNED
+                | _ => UNASSIGNED)
+              (env1, env2)
+          val env' =
+            if (returns s1) then env2
+            else if (returns s2) then env1
+            else env'
+        in
+          computeassigns env' stms
+        end
+    | computeassigns env (A.While (e, s1) :: stms) = computeassigns env stms
+    | computeassigns env (A.For (sbegin, e, sloop, inner) :: stms) =
+       let
+         val env' = case sbegin
+                    of SOME(s) => computeassigns env [s]
+                     | NONE => env
+       in
+         computeassigns env' stms
+       end
+    | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
+  
+  (* varcheck env l mark
+   * 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.
+   *)
+  fun varcheck env nil mark = nil
+    | varcheck env (A.Assign (A.Var id, e) :: stms) mark =
+        let
+          val sym = Symbol.look env id
+          val _ = if not (isSome sym)
+                  then (ErrorMsg.error mark ("assignment to undeclared variable " ^ (Symbol.name id)); raise ErrorMsg.Error)
+                  else ()
+          val t = valOf sym
+          val _ = varcheck_exp env e mark
+        in 
+          A.Assign (A.Var id, e) :: (varcheck (Symbol.bind env (id, ASSIGNED)) stms mark)
+        end
+    | varcheck env (A.Assign (A.Marked a, e) :: stms) mark = varcheck env (A.Assign (Mark.data a, e) :: stms) mark
+    | varcheck env ((a as A.Assign (A.Member (e', i), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.DerefMember (e', i), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.Dereference e', e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.ArrIndex (e', e''), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e'' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((a as A.Assign (A.NewArr (_, e'), e)) :: stms) mark =
+        (varcheck_exp env e' mark ;
+         varcheck_exp env e mark ;
+         a :: varcheck env stms mark)
+    | varcheck env ((A.Assign _) :: stms) mark = raise ErrorMsg.InternalError "assign to non lvalue"
+    | 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 )
+    | varcheck env ((a as A.Effect e) :: stms) mark = (varcheck_exp env e mark ; a :: varcheck env stms mark)
+    | varcheck env (A.Return (e) :: stms) mark =
+        ( varcheck_exp env e mark;
+          A.Return (e) :: nil )
+    | varcheck env (A.Nop :: stms) mark =
+        ( A.Nop :: (varcheck env stms mark))
+    | varcheck env (A.Break :: stms) mark =
+        ( A.Break :: nil )
+    | varcheck env (A.Continue :: stms) mark =
+        ( A.Continue :: nil )
+    | varcheck env (A.If (e, s1, NONE) :: stms) mark =
+        ( varcheck_exp env e mark ;
+          varcheck env s1 mark ;
+          A.If (e, s1, NONE) :: (varcheck env stms mark) )
+    | varcheck env ((i as A.If (e, s1, SOME s2)) :: stms) mark =
+        ( varcheck_exp env e mark ;
+          varcheck env s1 mark ; 
+          varcheck env s2 mark ;
+          A.If (e, s1, SOME s2) ::
+            (if (returns [i])
+             then nil
+             else varcheck (computeassigns env [i]) stms mark)  )
+    | varcheck env (A.While (e, s1) :: stms) mark =
+        ( varcheck_exp env e mark ;
+          varcheck env s1 mark ;
+          A.While (e, s1) :: (varcheck env stms mark) )
+    | varcheck env (A.For (sbegin, e, sloop, inner) :: stms) mark =
+        let
+          val sbegin = case sbegin
+                       of SOME(s) => SOME (hd (varcheck env [s] mark))
+                        | NONE => NONE
+          val env' = case sbegin
+                     of SOME(s) => computeassigns env [s]
+                      | NONE => env
+          val _ = varcheck_exp env' e mark
+          val inner = varcheck env' inner mark
+          val env'' = computeassigns env' inner
+          val sloop = case sloop
+                  of SOME(s) => SOME (hd (varcheck env'' [s] mark))
+                   | NONE => NONE
+        in
+          A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark)
+        end
+    | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.kane m) :: stms) (Mark.ext m)

 
 

-  (* tc_stms : unit Symbol.table -> Ast.program -> unit *)
-  fun tc_stms env nil = ()
-    | tc_stms env (A.Assign(id,e)::stms) =
-        ( tc_exp env e NONE ;
-         tc_stms (Symbol.bind env (id, ())) stms )
-    | tc_stms env (A.Return(e)::nil) =
-        tc_exp env e NONE
-    | tc_stms env (A.Return _ :: _) =
-        ( ErrorMsg.error NONE ("`return' not last statement") ;
-         raise ErrorMsg.Error )
+  fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,stat)) sym l
+  fun bindtypes sym l = foldr (fn ((i,t), s) => Symbol.bind s (i,t)) sym l

 
 

-  fun typecheck prog = tc_stms Symbol.empty prog
+  fun dupchk mark l src =
+        List.app
+          (fn (n, _) =>
+            let
+              val name = Symbol.name n
+              val all = List.filter (fn (n', _) => name = (Symbol.name n')) l
+              val count = length all
+            in
+              if count = 1
+              then ()
+              else ( ErrorMsg.error mark ("multiple definition of variable " ^ (Symbol.name n) ^ " in " ^ src);
+                     raise ErrorMsg.Error )
+            end) l
+  
+  fun check_lvalue prog vars mark (A.Marked m) = check_lvalue prog vars (Mark.ext m) (Mark.data m)
+    | check_lvalue prog vars mark (e as A.Var _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.Member _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.DerefMember _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.Dereference _) = typeof prog vars mark e
+    | check_lvalue prog vars mark (e as A.ArrIndex _) = typeof prog vars mark e
+    | check_lvalue prog vars mark _ = ( ErrorMsg.error mark ("invalid lvalue") ; raise ErrorMsg.Error )
+  fun typecheck_stm prog vars mark stm =
+    case stm
+    of A.Assign (e1, e2) =>
+         if not (T.castable (check_lvalue prog vars mark e1, typeof prog vars mark e2))
+         then (ErrorMsg.error mark "incompatible types in assignment" ; raise ErrorMsg.Error )
+         else if not (T.issmall (check_lvalue prog vars mark e1))
+         then (ErrorMsg.error mark "lvalue is not small" ; raise ErrorMsg.Error)
+         else ()
+     | A.AsnOp (oper, e1, e2) => typecheck_stm prog vars mark (A.Assign (e1, A.OpExp (oper, [e1, e2])))
+     | A.Effect e => 
+         if not (T.issmall (typeof prog vars mark e))
+         then (ErrorMsg.error mark "simple statement's value not small" ; raise ErrorMsg.Error )
+         else ()
+     | A.Return e => (typeof prog vars mark e ; ())
+     | A.Nop => ()
+     | A.Break => ()
+     | A.Continue => ()
+     | A.If (e, s, NONE) =>
+         if T.castable (T.Int, typeof prog vars mark e)
+         then (List.app (typecheck_stm prog vars mark) s)
+         else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
+     | A.If (e, s1, SOME s2) =>
+         if T.castable (T.Int, typeof prog vars mark e)
+         then (List.app (typecheck_stm prog vars mark) s1 ; List.app (typecheck_stm prog vars mark) s2)
+         else (ErrorMsg.error mark "conditional in if statement is not of int type" ; raise ErrorMsg.Error )
+     | A.For (sbegin, e, sloop, s) =>
+         if T.castable (T.Int, typeof prog vars mark e)
+         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))
+         else (ErrorMsg.error mark "conditional in for statement is not of int type" ; raise ErrorMsg.Error )
+     | A.While (e, s) =>
+         if T.castable (T.Int, typeof prog vars mark e)
+         then (List.app (typecheck_stm prog vars mark) s)
+         else (ErrorMsg.error mark "conditional in while statement is not of int type" ; raise ErrorMsg.Error )
+     | A.MarkedStm (m) => typecheck_stm prog vars (Mark.ext m) (Mark.data m)
+        
+  (* XXX does not check big vs. small types *)
+  fun typecheck_type (tds, funcs) mark T.Int = ()
+    | typecheck_type (tds, funcs) mark T.String = ()
+    | typecheck_type (tds, funcs) mark T.TNull = ()
+    | typecheck_type (tds, funcs) mark (T.Pointer t) = typecheck_type (tds, funcs) mark t
+    | typecheck_type (tds, funcs) mark (T.Array t) = typecheck_type (tds, funcs) mark t
+    | typecheck_type (tds, funcs) mark (T.Typedef t) =
+        case (Symbol.look tds t)
+        of SOME _ => ()
+         | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name t)^"' does not exist") ; raise ErrorMsg.Error)

 
 

+  fun typecheck_fn prog _ (id, A.MarkedFunction m) = typecheck_fn prog (Mark.ext m) (id, Mark.data m)
+    | typecheck_fn (prog as (tds, funcs)) mark (id, A.Extern (t, al)) =
+      (if (String.isPrefix "_l5_" (Symbol.name id))
+       then
+         let
+           val n = String.extract (Symbol.name id, 4, NONE)
+         in
+           if List.exists (fn (id, f) => case (AU.Function.data f) of A.Function _ => (Symbol.name id = n) | _ => false) (Symbol.elemsi funcs)
+           then (ErrorMsg.error mark ("you anus, extern " ^ Symbol.name id ^ " conflicts with local function"); raise ErrorMsg.Error)
+           else ()
+         end
+       else () ;
+       dupchk mark al ; 
+       List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) al) ;
+       A.Extern (t, al))
+    | typecheck_fn prog mark (id, A.Function (t, al, vl, sl)) =
+      let
+        val () = dupchk mark (al @ vl) ("function `"^Symbol.name id^"'")       (* Before we do any bindings, check for duplicate names. *)
+        val () = List.app (typecheck_type prog mark) (List.map (fn (_, t) => t) (al @ vl))
+        val env = Symbol.empty
+        val env = bindvars env ASSIGNED al
+        val env = bindvars env UNASSIGNED vl
+        val vars = Symbol.empty
+        val vars = bindtypes vars al
+        val vars = bindtypes vars vl
+        val () = breakcheck sl mark
+        val () = if not (returncheck prog vars NONE t sl)
+                 then ( ErrorMsg.error mark ("function `"^ Symbol.name id ^ "' does not return in all cases");
+                        raise ErrorMsg.Error )
+                 else ()
+        val () = List.app (
+                  fn (n, t) =>
+                    if (T.issmall t)
+                    then ()
+                    else ( ErrorMsg.error mark ("variable `"^(Symbol.name n)^"' in function `"^(Symbol.name id)^"' not small") ; raise ErrorMsg.Error))
+                 (al @ vl)
+        val () = List.app (typecheck_stm prog vars mark) sl
+      in
+        A.Function (t, al, vl, varcheck env sl NONE)
+      end
+
+  structure SymbolSet = ListSetFn (
+    struct
+      type ord_key = Symbol.symbol
+      val compare = Symbol.compare
+    end
+  )
+  
+  fun typecheck_structs (prog as (tds, funcs)) =
+    let
+      exception Yuq
+      
+      val all = SymbolSet.addList (SymbolSet.empty, Symbol.keys tds)
+      fun lookup mark sym =
+        let
+          val s = case Symbol.look tds sym
+                  of SOME a => a
+                   | NONE => (ErrorMsg.error mark ("typedef `"^(Symbol.name sym)^"' does not exist") ; raise ErrorMsg.Error)
+          val vl = case T.defdata s
+                   of T.Struct vl => vl
+                    | T.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type"
+        in
+          (vl, T.defmark s)
+        end
+      fun checksym mark sym stack k remaining =
+        if not (SymbolSet.member (remaining, sym))
+        then k remaining
+        else if (SymbolSet.member (stack, sym))
+        then ( ErrorMsg.error mark ("structure `"^ (Symbol.name sym) ^"' is involved in a recursive mess") ; raise Yuq)
+        else
+          let
+            val stack' = SymbolSet.add (stack, sym)
+            val (vl, mark') = lookup mark sym
+            val () = dupchk mark vl ("structure `"^(Symbol.name sym)^"'")
+            fun remove k remaining' = k (SymbolSet.delete (remaining', sym))
+            val newk = (* OH GOD D: *)
+              foldr
+                (fn ((_, T.Typedef s), k') => checksym mark' s stack' k'
+                  | (_, k') => k')
+                (remove k)
+                vl
+          in
+            newk remaining handle Yuq => (ErrorMsg.error mark' ("from structure `"^(Symbol.name sym)^"'") ; raise Yuq)
+          end
+      fun chooseone k set =
+        case (SymbolSet.listItems set)
+        of nil => k set
+         | (h::l) => checksym NONE h SymbolSet.empty (chooseone k) set
+    in
+      chooseone (fn _ => ()) all handle Yuq => raise ErrorMsg.Error
+    end
+  
+  fun typecheck (tds, funcs) =
+      let
+        val main = case (Symbol.look funcs (Symbol.symbol "main"))
+                   of NONE => ( ErrorMsg.error NONE ("no function named main");
+                                raise ErrorMsg.Error )
+                    | SOME m => m
+        val (main, mainp) = (AU.Function.data main, AU.Function.mark main)
+        val () = case main
+                 of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern");
+                                    raise ErrorMsg.Error )
+                  | A.Function (T.Int, nil, _, _) => ()
+                  | A.Function (T.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");
+                                                        raise ErrorMsg.Error )
+                  | A.Function (_, _, _, _) => ( ErrorMsg.error mainp ("main has incorrect return type");
+                                                 raise ErrorMsg.Error )
+                  | _ => raise ErrorMsg.InternalError "marked of marked disallowed"
+        val () = typecheck_structs (tds, funcs)
+      in
+        (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs)
+      end

 end
 end