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
+ val typeof : Ast.program -> Type.vtype Symbol.table -> Mark.ext option -> Ast.exp -> Type.vtype
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 _ => A.Int
+ | A.ConstExp _ => T.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! *)
+ of (T.Int, T.Int) => T.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 ))
+ 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 A.Int => ()
+ of T.Int => ()
| _ => (ErrorMsg.error mark ("incorrect type for opexp; needed int") ; raise ErrorMsg.Error)))
- el ; A.Int)
+ el ; T.Int)
| A.Marked e => typeof (tds, funcs) vars (Mark.ext e) (Mark.data e)
| A.FuncCall (i, exps) =>
let
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))
+ 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))
let
val t = typeof (tds, funcs) vars mark e
val name = case t
- of (A.Typedef i) => i
+ 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) = (AU.Typedef.data s, AU.Typedef.mark s)
+ val (s, smark) = (T.defdata s, T.defmark s)
val vl = case s
- of A.Struct vl => vl
+ 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
let
val t = typeof (tds, funcs) vars mark e
val name = case t
- of (A.Pointer (A.Typedef i)) => i
+ 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 A.Struct vl => (s, NONE)
- | A.MarkedTypedef m => (Mark.data m, Mark.ext m)
+ of T.Struct vl => (s, NONE)
+ | T.MarkedTypedef m => (Mark.data m, Mark.ext m)
val vl = case s
- of A.Struct vl => vl
+ 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
end
| A.Dereference e =>
(case typeof (tds, funcs) vars mark e
- of (A.Pointer e') => 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 (A.Array e', A.Int) => e'
- | (_, A.Int) => (ErrorMsg.error mark ("cannot index non-array type") ; raise ErrorMsg.Error)
+ 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) => A.Pointer t
+ | A.New (t) => T.Pointer t
| A.NewArr (t, s) =>
(case typeof (tds, funcs) vars mark s
- of A.Int => (A.Array t)
+ of T.Int => (T.Array t)
| _ => (ErrorMsg.error mark ("cannot specify non-int array dimension") ; raise ErrorMsg.Error))
- | A.Null => A.TNull
+ | 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
| 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))
+ 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
| 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.
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.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;
val env' = case sbegin
of SOME(s) => computeassigns env [s]
| NONE => env
- val _ = varcheck_exp env' e
+ val _ = varcheck_exp env' e mark
val inner = varcheck env' inner mark
val env'' = computeassigns env' inner
val sloop = case sloop
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))
+ 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 (AU.Type.issmall (check_lvalue prog vars mark e1))
+ 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 (AU.Type.issmall (typeof prog vars mark 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.Break => ()
| A.Continue => ()
| A.If (e, s, NONE) =>
- if A.castable (A.Int, typeof prog vars mark e)
+ 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 A.castable (A.Int, typeof prog vars mark e)
+ 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 A.castable (A.Int, typeof prog vars mark e)
+ 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 A.castable (A.Int, typeof prog vars mark e)
+ 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 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) =
+ fun typecheck_type (tds, funcs) mark T.Int = ()
+ | 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 "_l4_" (Symbol.name id))
+ (if (String.isPrefix "_l5_" (Symbol.name id))
then
let
val n = String.extract (Symbol.name id, 4, NONE)
else ()
val () = List.app (
fn (n, t) =>
- if (AU.Type.issmall 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 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"
+ val vl = case T.defdata s
+ of T.Struct vl => vl
+ | T.MarkedTypedef v => raise ErrorMsg.InternalError "data returned marked type"
in
- (vl, AU.Typedef.mark s)
+ (vl, T.defmark s)
end
fun checksym mark sym stack k remaining =
if not (SymbolSet.member (remaining, 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'
+ (fn ((_, T.Typedef s), k') => checksym mark' s stack' k'
| (_, k') => k')
(remove k)
vl
val () = case main
of A.Extern _ => ( ErrorMsg.error mainp ("you anus, main can't be an extern");
raise ErrorMsg.Error )
- | A.Function (A.Int, nil, _, _) => ()
- | A.Function (A.Int, _, _, _) => ( ErrorMsg.error mainp ("main should take no parameters");
+ | 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 )
git.joshuawise.com / snipe.git / blobdiff