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 3407 - (download) (annotate)
Wed Nov 11 18:53:18 2015 UTC (4 years, 1 month ago) by jhr
File size: 12395 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.t * Env.context * ParseTree.stmt -> AST.stmt

  end = struct

    structure PT = ParseTree
    structure L = Literal
    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.S_Block[]

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

    datatype token = datatype TypeError.token

  (* 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, {span, tree=x}, e) => let
                val ty = CheckType.check (cxt, ty)
                val x' = Var.new (x, Error.location(#1 cxt, span), kind, ty)
                val (e', ty') = chkE (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 E.FunctionScope(_, f) => (true, false, Atom.toString f)
                  | E.MethodScope StrandUtil.Initially => (false, true, "")
                  | E.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) = chkE (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) = chkE (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) = chkE (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) = chkE (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) = chkE(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(E.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, S "' on lhs of assignment"
		      ])
		  | SOME x' => let
		      val ([], ty) = Var.typeOf x'
		      val eTy = chkE (env, cxt, e)
		      fun illegalAssign kind = err(cxt, [
			      S "assignment to ", S kind, S " '", A x,
			      S "' in ", S(E.scopeToString(#scope env))
			    ])
		    (* check for assignment to variables that are immutable because of their type *)
		      fun chkAssign () = (case Var.typeOf x'
			     of (Ty.T_Field _) => illegalAssign "field-valued variable"
			      | (Ty.T_Image _) => illegalAssign "image-valued variable"
			      | (Ty.T_Kernel _) => illegalAssign "kernel-valued variable"
			      | ty => let
				(* check for promotion *)
				  val e' = (case Util.coerceType(ty, eTy)
					 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
				    (AST.S_Assign(x', e'), env)
				  end
			    (* end case *))
		    (* check that assignment to global variables is allowed in the current scope *)
		      fun chkGlobalAssign () = (case E.currentScope env
			     of E.FunctionScope _ => illegalAssign "global variable"
			      | E.MethodScope _ => illegalAssign "global variable"
			      | E.InitScope => chkAssign()
			      | E.UpdateScope => chkAssign()
			      | _ => raise Fail "impossible scope"
			    (* end case *))
		      in
		      (* check that assigning to x' is okay *)
			case Var.kindOf x'
			 of Var.BasisVar => illegalAssign "builtin function"
			  | Var.ConstVar => illegalAssign "constant variable"
			  | Var.InputVar => chkGlobalAssign ()
			  | Var.GlobalVar => chkGlobalAssign ()
			  | Var.FunVar => illegalAssign "function"
			  | Var.FunParam => illegalAssign "function parameter"
			  | Var.StrandParam => illegalAssign "strand parameter"
			  | _ => chkAssign ()
			(* end case *)
		      end
		(* end case *))
	    | PT.S_Deprecate(msg, stm) => (
		warn (cxt, [S msg]);
		chk (env, cxt, stm))
	  (* end case *))

    fun check arg = (chkCtlFlow arg; chk arg)

  end

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