X-Git-Url: http://git.joshuawise.com/snipe.git/blobdiff_plain/12aa4087bee3e70f170d7457794921de4e385227..0a24e44d4e9f82f8d3d83de8e58c83c8cf2868b6:/type/typechecker.sml diff --git a/type/typechecker.sml b/type/typechecker.sml index 699d15a..32f80a1 100644 --- a/type/typechecker.sml +++ b/type/typechecker.sml @@ -10,40 +10,131 @@ 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 end; structure TypeChecker :> TYPE_CHECK = struct structure A = Ast - (* 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) - - (* 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 typecheck prog = tc_stms Symbol.empty prog + fun returns nil = false + | returns (A.Assign _ :: stms) = returns stms + | returns (A.Return _ :: 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.data m :: stms) + + 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.data m)] (Mark.ext m); breakcheck stms mark) + | breakcheck (_ :: stms) mark = breakcheck stms mark + + 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 _ => ()) + | 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.Marked m) mark = varcheck_exp env (Mark.data m) (Mark.ext m) + + fun computeassigns env nil = env + | computeassigns env (A.Assign (id,e) :: stms) = + computeassigns (Symbol.bind env (id, ())) 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 (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.data m) :: stms) + + fun varcheck env nil mark = nil + | varcheck env (A.Assign (id, e) :: stms) mark = + ( varcheck_exp env e mark ; + A.Assign (id, e) :: (varcheck (Symbol.bind env (id, ())) 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 + 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.data m) :: stms) (Mark.ext m) + fun typecheck prog = + ( breakcheck prog NONE ; + if not (returns prog) + then (ErrorMsg.error NONE ("program does not return in all cases"); raise ErrorMsg.Error) + else varcheck Symbol.empty prog NONE) end