Initial import of l4c

[snipe.git] / type / typechecker.sml

diff --git a/type/typechecker.sml b/type/typechecker.sml
index 63608bdb403628faaa4aed2d79e640a2e3476fee..35d2859e214068d1597be973148db5a31541830d 100644 (file)
--- a/type/typechecker.sml
+++ b/type/typechecker.sml
@@ -10,17 +10,150 @@ signature TYPE_CHECK =
 sig
   (* prints error message and raises ErrorMsg.error if error found *)
   val typecheck : Ast.program -> Ast.program
 sig
   (* prints error message and raises ErrorMsg.error if error found *)
   val typecheck : Ast.program -> Ast.program

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

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

+  structure AU = AstUtils
+  
+  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 _ => A.Int
+       | A.OpExp (A.EQ, [a, b]) =>
+           (case (typeof (tds, funcs) vars mark a, typeof (tds, funcs) vars mark b)
+            of (A.Int, A.Int) => A.Int (* You shall pass! *)
+             | (a', b') =>
+                 if (A.typeeq (a', A.TNull) andalso A.castable (b', A.TNull)) orelse
+                    (A.typeeq (b', A.TNull) andalso A.castable (a', A.TNull)) orelse
+                    (A.typeeq (a', b'))
+                 then A.Int
+                 else (ErrorMsg.error mark ("incorrect types for equality opexp: " ^ A.Print.pp_type a' ^ ", " ^ A.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 A.Int => ()
+                                  | _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error)))
+                              el ; A.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 (A.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 (A.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) = (AU.Typedef.data s, AU.Typedef.mark s)
+           val vl = case s
+                    of A.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 (A.Pointer (A.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 A.Struct vl => (s, NONE)
+                             | A.MarkedTypedef m => (Mark.data m, Mark.ext m)
+           val vl = case s
+                    of A.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 (A.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 (A.Array e', A.Int) => e'
+           | (_, A.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) => A.Pointer t
+       | A.NewArr (t, s) =>
+         (case typeof (tds, funcs) vars mark s
+          of A.Int => (A.Array t)
+           | _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error))
+       | A.Null => A.TNull
+    )

   
   datatype asn = ASSIGNED | UNASSIGNED
 
   
   datatype asn = ASSIGNED | UNASSIGNED
 

+  (* 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 (A.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
   fun returns nil = false
     | returns (A.Assign _ :: stms) = returns stms

-    | returns (A.Return _ :: stms) = true
+    | 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.Nop :: stms) = returns stms
     | returns (A.Break :: stms) = true (* blah *)
     | returns (A.Continue :: stms) = true (* blah *)


@@ -30,6 +163,9 @@ struct
     | returns (A.While _ :: stms) = returns stms
     | returns (A.MarkedStm m :: stms) = returns (Mark.kane m :: 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 )
   fun breakcheck nil mark = ()
     | breakcheck (A.Break :: stms) mark = ( ErrorMsg.error mark ("Illegal break outside loop") ;
                                              raise ErrorMsg.Error )


@@ -45,38 +181,40 @@ struct
     | breakcheck (A.MarkedStm m :: stms) mark = (breakcheck [(Mark.kane m)] (Mark.ext m); breakcheck stms mark)
     | breakcheck (_ :: stms) 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
   

-  fun varcheck_exp env fenv (A.Var v) mark : Ast.vtype =
+  (* 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 )
         ( case Symbol.look env v
           of NONE => ( ErrorMsg.error mark ("undefined variable `" ^ Symbol.name v ^ "'") ;
                        raise ErrorMsg.Error )

-           | SOME (t, UNASSIGNED) => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;
-                                       raise ErrorMsg.Error )
-           | SOME (t, ASSIGNED) => t)
-    | varcheck_exp env fenv (A.ConstExp _) mark = (A.Int)
-    | varcheck_exp env fenv (A.OpExp (_, l)) mark = (List.app (fn znt => (varcheck_exp env fenv znt mark; ())) l; A.Int)
-    | varcheck_exp env fenv (A.FuncCall (f, l)) mark =
-      let
-        val types = map (fn znt => varcheck_exp env fenv znt mark) l
-        val func = case Symbol.look fenv f
-                     of NONE => ( ErrorMsg.error mark ("undefined function `" ^ Symbol.name f ^ "'") ;
+           | SOME UNASSIGNED => ( ErrorMsg.error mark ("usage of unassigned variable `" ^ Symbol.name v ^ "'") ;

                                   raise ErrorMsg.Error )
                                   raise ErrorMsg.Error )

-                      | SOME a => a
-        val (rtype, params) = case func
-                               of A.Extern (rtype, _, params) => (rtype, params)
-                                | A.Function (rtype, _, params, _, _) => (rtype, params)
-        val paramtypes = map (fn (i, t) => t) params
-        val () = if not (types = paramtypes)
-                 then ( ErrorMsg.error mark ("incorrect parameters for function `" ^ Symbol.name f ^ "'") ;
-                        raise ErrorMsg.Error )
-                 else ()
-      in
-        rtype
-      end
-    | varcheck_exp env fenv (A.Marked m) mark = varcheck_exp env fenv (Mark.kane m) (Mark.ext m)
+           | SOME ASSIGNED => ())
+    | varcheck_exp env (A.ConstExp _) 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 = ()

   
   

+  (* computeassigns env exp
+   * Computes the assigned variables after expression exp has been executed with a starting context of env.
+   *)

   fun computeassigns env nil = env
   fun computeassigns env nil = env

-    | computeassigns env (A.Assign (id,e) :: stms) =
-        computeassigns (Symbol.bind env (id, (A.Int, ASSIGNED))) stms
+    | 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.Return _ :: stms) = env
     | computeassigns env (A.Nop :: stms) = computeassigns env stms
     | computeassigns env (A.Break :: stms) = env


@@ -88,8 +226,8 @@ struct
           val env2 = computeassigns env s2
           val env' =
             Symbol.intersect
           val env2 = computeassigns env s2
           val env' =
             Symbol.intersect

-              (fn ((t, ASSIGNED), (t', ASSIGNED)) => (t, ASSIGNED) (* XXX check types for equality *)
-                | ((t, _), (t', _)) => (t, UNASSIGNED))
+              (fn (ASSIGNED, ASSIGNED) => ASSIGNED
+                | _ => UNASSIGNED)

               (env1, env2)
           val env' =
             if (returns s1) then env2
               (env1, env2)
           val env' =
             if (returns s1) then env2


@@ -109,70 +247,94 @@ struct
        end
     | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
   
        end
     | computeassigns env (A.MarkedStm m :: stms) = computeassigns env ((Mark.kane m) :: stms)
   

-  fun varcheck env fenv nil mark = nil
-    | varcheck env fenv (A.Assign (id, e) :: stms) mark =
+  (* 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 ()
         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, a) = valOf sym
-          val t' = varcheck_exp env fenv e mark
+          val t = valOf sym
+          val _ = varcheck_exp env e mark

         in 
         in 

-          A.Assign (id, e) :: (varcheck (Symbol.bind env (id, (t, ASSIGNED))) fenv stms mark)
+          A.Assign (A.Var id, e) :: (varcheck (Symbol.bind env (id, ASSIGNED)) stms mark)

         end
         end

-    | varcheck env fenv (A.Return (e) :: stms) mark =
-        ( varcheck_exp env fenv e mark;
+    | 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 env [(A.Assign (e1, A.OpExp (oper, [e1, e2])))] ; 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 )
           A.Return (e) :: nil )

-    | varcheck env fenv (A.Nop :: stms) mark =
-        ( A.Nop :: (varcheck env fenv stms mark))
-    | varcheck env fenv (A.Break :: stms) mark =
+    | varcheck env (A.Nop :: stms) mark =
+        ( A.Nop :: (varcheck env stms mark))
+    | varcheck env (A.Break :: stms) mark =

         ( A.Break :: nil )
         ( A.Break :: nil )

-    | varcheck env fenv (A.Continue :: stms) mark =
+    | varcheck env (A.Continue :: stms) mark =

         ( A.Continue :: nil )
         ( A.Continue :: nil )

-    | varcheck env fenv (A.If (e, s1, NONE) :: stms) mark =
-        ( varcheck_exp env fenv e mark ;
-          varcheck env fenv s1 mark ;
-          A.If (e, s1, NONE) :: (varcheck env fenv stms mark) )
-    | varcheck env fenv ((i as A.If (e, s1, SOME s2)) :: stms) mark =
-        ( varcheck_exp env fenv e mark ;
-          varcheck env fenv s1 mark ; 
-          varcheck env fenv s2 mark ;
+    | 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
           A.If (e, s1, SOME s2) ::
             (if (returns [i])
              then nil

-             else varcheck (computeassigns env [i]) fenv stms mark)  )
-    | varcheck env fenv (A.While (e, s1) :: stms) mark =
-        ( varcheck_exp env fenv e mark ;
-          varcheck env fenv s1 mark ;
-          A.While (e, s1) :: (varcheck env fenv stms mark) )
-    | varcheck env fenv (A.For (sbegin, e, sloop, inner) :: stms) mark =
+             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
         let
           val sbegin = case sbegin

-                       of SOME(s) => SOME (hd (varcheck env fenv [s] mark))
+                       of SOME(s) => SOME (hd (varcheck env [s] mark))

                         | NONE => NONE
           val env' = case sbegin
                      of SOME(s) => computeassigns env [s]
                       | NONE => env
                         | NONE => NONE
           val env' = case sbegin
                      of SOME(s) => computeassigns env [s]
                       | NONE => env

-          val _ = varcheck_exp env' fenv e
-          val inner = varcheck env' fenv inner mark
+          val _ = varcheck_exp env' e
+          val inner = varcheck env' inner mark

           val env'' = computeassigns env' inner
           val sloop = case sloop
           val env'' = computeassigns env' inner
           val sloop = case sloop

-                  of SOME(s) => SOME (hd (varcheck env'' fenv [s] mark))
+                  of SOME(s) => SOME (hd (varcheck env'' [s] mark))

                    | NONE => NONE
         in
                    | NONE => NONE
         in

-          A.For (sbegin, e, sloop, inner) :: (varcheck env' fenv stms mark)
+          A.For (sbegin, e, sloop, inner) :: (varcheck env' stms mark)

         end
         end

-    | varcheck env fenv (A.MarkedStm m :: stms) mark = varcheck env fenv ((Mark.kane m) :: stms) (Mark.ext m)
+    | varcheck env (A.MarkedStm m :: stms) mark = varcheck env ((Mark.kane m) :: stms) (Mark.ext m)

 
 

-  fun bindvars sym stat l = foldr (fn ((i,t), s) => Symbol.bind s (i,(t, stat))) sym l
-  fun bindfuns sym l =
-    foldr
-      (fn (a as (A.Function (_, id, _, _, _)), s) => Symbol.bind s (id, a)
-        | (a as (A.Extern (_, id, _)), s) => Symbol.bind s (id, a))
-      sym l
+  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 dupchk l =
+  fun dupchk mark l src =

         List.app
           (fn (n, _) =>
             let
         List.app
           (fn (n, _) =>
             let


@@ -182,62 +344,172 @@ struct
             in
               if count = 1
               then ()
             in
               if count = 1
               then ()

-              else ( ErrorMsg.error NONE ("multiple definition of variable " ^ (Symbol.name n));
+              else ( ErrorMsg.error mark ("multiple definition of variable " ^ (Symbol.name n) ^ " in " ^ src);

                      raise ErrorMsg.Error )
             end) l
                      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 (A.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 (AU.Type.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 (AU.Type.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 A.castable (A.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 A.castable (A.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 A.castable (A.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 A.castable (A.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 A.Int = ()
+    | typecheck_type (tds, funcs) mark A.TNull = ()
+    | typecheck_type (tds, funcs) mark (A.Pointer t) = typecheck_type (tds, funcs) mark t
+    | typecheck_type (tds, funcs) mark (A.Array t) = typecheck_type (tds, funcs) mark t
+    | typecheck_type (tds, funcs) mark (A.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 p (e as (A.Extern (t, id, al))) = (dupchk al; e)
-    | typecheck_fn p (A.Function (t, id, al, vl, sl)) =
+  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 "_l4_" (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
       let

-        val () = breakcheck sl NONE
-        val () = if not (returns sl)
-                 then ( ErrorMsg.error NONE ("function `"^ Symbol.name id ^ "' does not return in all cases");
-                        raise ErrorMsg.Error )
-                 else ()
+        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 env = Symbol.empty
         val env = bindvars env ASSIGNED al
         val env = bindvars env UNASSIGNED vl

-        val fenv = bindfuns Symbol.empty p
-        val () = dupchk (al @ 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 (AU.Type.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
       in

-        A.Function (t, id, al, vl, varcheck env fenv sl NONE)
+        A.Function (t, al, vl, varcheck env sl NONE)

       end
       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 AU.Typedef.data s
+                   of A.Struct vl => vl
+                    | A.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type"
+        in
+          (vl, AU.Typedef.mark 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 ((_, A.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 p =
+  fun typecheck (tds, funcs) =

       let
       let

-        fun getFun n =
-          List.find (fn A.Extern (_, id, _) => ((Symbol.name id) = n)
-                      | A.Function (_, id, _, _, _) => ((Symbol.name id) = n))
-                    p
-        val main = case (getFun "main")
+        val main = case (Symbol.look funcs (Symbol.symbol "main"))

                    of NONE => ( ErrorMsg.error NONE ("no function named main");
                                 raise ErrorMsg.Error )
                     | SOME m => m
                    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
         val () = case main

-                 of A.Extern _ => ( ErrorMsg.error NONE ("you anus, main can't be an extern");
+                 of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern");

                                     raise ErrorMsg.Error )
                                     raise ErrorMsg.Error )

-                  | A.Function (A.Int, _, nil, _, _) => ()
-                  | A.Function (A.Int, _, _, _, _) => ( ErrorMsg.error NONE ("main should take no parameters");
+                  | A.Function (A.Int, nil, _, _) => ()
+                  | A.Function (A.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");

                                                         raise ErrorMsg.Error )
                                                         raise ErrorMsg.Error )

-        val () = List.app
-                   (fn a =>
-                      let
-                        val id = case a
-                          of A.Extern (_, id, _) => id
-                           | A.Function (_, id, _, _, _) => id
-                        val name = Symbol.name id
-                        val all = List.filter
-                          (fn A.Extern (_, id, _) => (Symbol.name id) = name
-                            | A.Function (_, id, _, _, _) => (Symbol.name id) = name)
-                          p
-                        val num = length all
-                      in
-                        if num = 1
-                        then ()
-                        else ( ErrorMsg.error NONE ("multiple definition of " ^ name);
-                               raise ErrorMsg.Error )
-                      end) p
+                  | 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
       in

-        List.map (typecheck_fn p) p
+        (tds, Symbol.mapi (typecheck_fn (tds, funcs) NONE) funcs)

       end
 end
       end
 end