Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] View of /branches/vis15/src/compiler/typechecker/check-stmt.sml
ViewVC logotype

View of /branches/vis15/src/compiler/typechecker/check-stmt.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3398 - (download) (annotate)
Wed Nov 11 01:17:58 2015 UTC (4 years ago) by jhr
File size: 11294 byte(s)
working on merge
(* check-stmt.sml
 *
 * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
 *
 * COPYRIGHT (c) 2015 The University of Chicago
 * All rights reserved.
 *)

structure CheckStmt : sig

    val check : Env.env * Env.context * ParseTree.stmt -> AST.stmt

  end = struct

    structure PT = ParseTree
    structure E = Env
    structure Ty = Types
    structure BV = BasisVars

    val chkE = CheckExpr.check

  (* a statement to return when there is a type error *)
    val bogusStm = (AST.E_Lit(L.Int 0), Ty.T_Error)

    fun err arg = (TypeError.error arg; bogusExp)
    val warn = TypeError.warning

    datatype tokens = datatype TypeError.tokens

  (* typecheck a variable declaration *)
    fun checkVarDecl (env, cxt, kind, d) = (case d
           of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)
            | PT.VD_Decl(ty, x, e) => let
                val ty = checkTy (cxt, ty)
                val x' = Var.new (x, kind, ty)
                val (e', ty') = checkExpr (env, cxt, e)
                in
                  case coerceType (ty, ty', e')
                   of SOME e' => (x, x', e')
                    | NONE => err(cxt, [
                        S "type of variable ", A x,
                        S " does not match type of initializer\n",
                        S "  expected: ", TY ty, S "\n",
                        S "  but found: ", TY ty'
                      ])
                  (* end case *)
                end
          (* end case *))

  (* check for unreachable code and non-return statements in the tail position of a function.
   * Note that unreachable code is typechecked and included in the AST.  It is pruned away
   * by simplify.
   *)
    fun chkCtlFlow (cxt, scope, stm) = let
          val (inFun, inInitOrUpdate, funName) = (case scope
                 of FunctionScope(_, f) => (true, false, Atom.toString f)
                  | MethodScope StrandUtil.Initially => (false, true, "")
                  | MethodScope StrandUtil.Update => (false, true, "")
                  | _ => (false, false, "")
                (* end case *))
        (* checks a statement for correct control flow; it returns false if control may
         * flow from the statement to the next in a sequence and true if control cannot
         * flow to the next statement.
         *)
          fun chk ((errStrm, _), hasSucc, isJoin, unreachable, PT.S_Mark{span, tree}) =
                chk((errStrm, span), hasSucc, isJoin, unreachable, tree)
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Block(stms as _::_)) = let
                fun chk' ([], escapes) = escapes
                  | chk' ([stm], escapes) =
                      chk(cxt, hasSucc, isJoin, escapes orelse unreachable, stm) orelse escapes
                  | chk' (stm::stms, escapes) = let
                      val escapes = chk(cxt, true, false, escapes orelse unreachable, stm) orelse escapes
                      in
                        chk'(stms, escapes)
                      end
                in
                  chk' (stms, false)
                end
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_IfThen(_, stm)) = (
                if inFun andalso not hasSucc andalso not unreachable
                  then err(cxt, [
                        S "Missing return statement in tail position of function ", S funName
                    ])
                  else ();
                ignore (chk (cxt, hasSucc, true, unreachable, stm));
                false)
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_IfThenElse(_, stm1, stm2)) = let
                val escapes = chk (cxt, hasSucc, true, unreachable, stm1)
                val escapes = chk (cxt, hasSucc, true, unreachable, stm2) andalso escapes
                in
                  if escapes andalso hasSucc andalso not unreachable
                    then (
                      warn(cxt, [S "unreachable statements after \"if-then-else\" statement"]);
                      true)
                    else escapes
                end
            | chk (cxt, _, _, _, PT.S_New _) = (
                if not inInitOrUpdate
                  then err(cxt, [S "\"new\" statement outside of initially/update method"])
                  else ();
                false)
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Die) = (
                if not inInitOrUpdate
                  then err(cxt, [S "\"die\" statment outside of initially/update method"])
                else if hasSucc andalso not isJoin andalso not unreachable
                  then warn(cxt, [S "statements following \"die\" statment are unreachable"])
                  else ();
                true)
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Continue) = (
                if not inInitOrUpdate
                  then err(cxt, [S "\"continue\" statment outside of initially/update method"])
                else if hasSucc andalso not isJoin andalso not unreachable
                  then warn(cxt, [S "statements following \"continue\" statment are unreachable"])
                  else ();
                true)
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Stabilize) = (
                if not inInitOrUpdate
                  then err(cxt, [S "\"stabilize\" statment outside of initially/update method"])
                else if hasSucc andalso not isJoin andalso not unreachable
                  then warn(cxt, [S "statements following \"stabilize\" statment are unreachable"])
                  else ();
                true)
            | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Return _) = (
                if not inFun
                  then err(cxt, [S "\"return\" statment outside of function body"])
                else if hasSucc andalso not isJoin andalso not unreachable
                  then warn(cxt, [S "statements following \"return\" statment are unreachable"])
                  else ();
                true)
            | chk (cxt, hasSucc, isJoin, unreachable, _) = (
                if inFun andalso not hasSucc andalso not unreachable
                  then err(cxt, [
                        S "Missing return statement in tail position of function ", S funName
                    ])
                  else ();
                false)
          in
            ignore (chk (cxt, false, false, false, stm))
          end

  (* check the type of a statement *)
    fun chk (env, cxt, e) = (case e
	   of PT.S_Mark m => check (withEnvAndContext (env, cxt, m))
	    | PT.S_Block stms => let
		fun chk (_, [], stms) = AST.S_Block(List.rev stms)
		  | chk (env, s::ss, stms) = let
		      val (s', env') = chkStmt (env, cxt, s)
		      in
			chk (env', ss, s'::stms)
		      end
		in
		  (chk (Env.blockScope env, stms, []), env)
		end
	    | PT.S_IfThen(e, s) => let
		val (e', ty) = checkExpr (env, cxt, e)
		val (s', _) = chkStmt (env, cxt, s)
		in
		(* check that condition has bool type *)
		  case ty
		   of Ty.T_Bool => ()
		    | _ => err(cxt, [S "condition not boolean type"])
		  (* end case *);
		  (AST.S_IfThenElse(e', s', AST.S_Block[]), env)
		end
	    | PT.S_IfThenElse(e, s1, s2) => let
		val (e', ty) = checkExpr (env, cxt, e)
		val (s1', _) = chkStmt (env, cxt, s1)
		val (s2', _) = chkStmt (env, cxt, s2)
		in
		(* check that condition has bool type *)
		  case ty
		   of Ty.T_Bool => ()
		    | _ => err(cxt, [S "condition not boolean type"])
		  (* end case *);
		  (AST.S_IfThenElse(e', s1', s2'), env)
		end
	    | PT.S_Foreach(iter, body) => ??
	    | PT.S_Print args => let
		fun chkArg e = let
		      val (e', ty) = checkExpr (env, cxt, e)
		      in
			if TU.isValueType ty
			  then ()
			  else err(cxt, [
			      S "expected value type in print, but found ", TY ty
			   ]);
			e'
		      end
		val args' = List.map chkArg args
		in
		  (AST.S_Print args', env)
		end
	    | PT.S_New(strand, args) => let
	      (* note that scope has already been checked in chkCtlFlow *)
		val (strand, args, env) = checkStrandCreate (env, cxt, strand, args)
		in
		  Env.recordProp (#env env, StrandUtil.NewStrands);
		  (AST.S_New(strand, args), env)
		end
	    | PT.S_Stabilize => (* note that scope has already been checked in chkCtlFlow *)
		(AST.S_Stabilize, env)
	    | PT.S_Die => (
	      (* note that scope has already been checked in chkCtlFlow *)
		Env.recordProp (#env env, StrandUtil.StrandsMayDie);
		(AST.S_Die, env))
	    | PT.S_Continue => (* note that scope has already been checked in chkCtlFlow *)
		(AST.S_Continue, env)
	    | PT.S_Return e => let
		val (e', ty) = checkExpr (env, cxt, e)
		in
		  case #scope env
		   of FunctionScope(ty', f) => (case coerceType(ty', ty, e')
			 of SOME e' => (AST.S_Return e', env)
			  | NONE => err(cxt, [
				S "type of return expression does not match return type of function ",
				A f, S "\n",
				S "  expected: ", TY ty', S "\n",
				S "  but found: ", TY ty
			      ])
			(* end case *))
		    | _ => (AST.S_Return e', env) (* this error condition has already been checked *)
		  (* end case *)
		end
	    | PT.S_Decl vd => let
		val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)
		in
		  checkForRedef (env, cxt, x);
		  (AST.S_Decl(AST.VD_Decl(x', e)), insertLocal(env, cxt, x, x'))
		end
	    | PT.S_Assign(x, rator, e) => (case Env.findVar (#env env, x)
		 of SOME x' => let
		      val e1' = AST.E_Var x'
		      val ty1 = Var.monoTypeOf x'
		      val (e2', ty2) = checkExpr(env, cxt, e)
		      val Env.PrimFun ovldList = Env.findFunc (#env env, rator)
		      val (rhs, _) = resolveOverload (cxt, rator, [ty1, ty2], [e1', e2'], ovldList)
		      in
		      (* check that x' is mutable *)
			case Var.kindOf x'
			 of Var.StrandStateVar => ()
			  | Var.StrandOutputVar => markUsed (x', true)
			  | Var.LocalVar => ()
			  | _ => err(cxt, [
				S "assignment to immutable variable ", A x,
				S " in ", S(scopeToString(#scope env))
			      ])
			(* end case *);
			(AST.S_Assign(x', rhs), env)
		      end
		  | NONE => err(cxt, [S "undeclared variable ", A x, S " on lhs of ", A rator])
		(* end case *))
	    | PT.S_OpAssign(x, e) => (case Env.findVar (#env env, x)
		 of NONE => err(cxt, [
			S "undefined variable ", A x
		      ])
		  | SOME x' => let
(* FIXME: check for polymorphic variables *)
		      val ([], ty) = Var.typeOf x'
		      val (e', ty') = checkExpr (env, cxt, e)
		    (* check for promotion *)
		      val e' = (case coerceType(ty, ty', e')
			     of SOME e' => e'
			      | NONE => err(cxt, [
				    S "type of assigned variable ", A x,
				    S " does not match type of rhs\n",
				    S "  expected: ", TY ty, S "\n",
				    S "  but found: ", TY ty'
				  ])
			    (* end case *))
		      in
		      (* check that x' is mutable *)
			case Var.kindOf x'
			 of Var.StrandStateVar => ()
			  | Var.StrandOutputVar => markUsed (x', true)
			  | Var.LocalVar => ()
			  | _ => err(cxt, [
				S "assignment to immutable variable ", A x,
				S " in ", S(scopeToString(#scope env))
			      ])
			(* end case *);
			(AST.S_Assign(x', e'), env)
		      end
		(* end case *))
	    | PT.S_Deprecate(msg, stm) => (
		warn (cxt, [S msg]);
		chk (env, cxt, stm))
	  (* end case *))

    fun check () = (
	  chkCtlFlow (cxt, scope, stm);
	  chk (cxt, scope, stm))

  end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0