X-Git-Url: http://git.joshuawise.com/snipe.git/blobdiff_plain/1144856ba9d6018d9922c6ede7e97779a0fe6373..HEAD:/type/typechecker.sml diff --git a/type/typechecker.sml b/type/typechecker.sml index 35d2859..06c6d89 100644 --- a/type/typechecker.sml +++ b/type/typechecker.sml @@ -10,36 +10,37 @@ signature TYPE_CHECK = 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 @@ -53,7 +54,7 @@ struct 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)) @@ -64,14 +65,14 @@ struct 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 @@ -83,16 +84,16 @@ struct 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 @@ -102,19 +103,33 @@ struct 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 @@ -131,7 +146,7 @@ struct | 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 @@ -202,6 +217,7 @@ struct | 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. @@ -285,7 +301,7 @@ struct 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; @@ -320,7 +336,7 @@ struct 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 @@ -358,14 +374,14 @@ struct 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 ; ()) @@ -373,36 +389,36 @@ struct | 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) @@ -432,7 +448,7 @@ struct 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) @@ -458,11 +474,11 @@ struct 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)) @@ -477,7 +493,7 @@ struct 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 @@ -502,8 +518,8 @@ struct 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 )