Initial import of l2c

[snipe.git] / type / typechecker.sml

(* L1 Compiler
 * TypeChecker
 * Author: Alex Vaynberg <alv@andrew.cmu.edu>
 * Modified: Frank Pfenning <fp@cs.cmu.edu>
 *
 * Simple typechecker that is based on a unit Symbol.table
 * This is all that is needed since there is only an integer type present
 *) 

signature TYPE_CHECK =
sig
  (* prints error message and raises ErrorMsg.error if error found *)
  val typecheck : Ast.program -> Ast.program
end;

structure TypeChecker :> TYPE_CHECK = 
struct
  structure A = Ast

  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