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
git.joshuawise.com / snipe.git / blobdiff