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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 3407, Wed Nov 11 18:53:18 2015 UTC revision 3408, Wed Nov 11 20:26:18 2015 UTC
# Line 8  Line 8 
8    
9  structure CheckStmt : sig  structure CheckStmt : sig
10    
11      (* type check a statement *)
12      val check : Env.t * Env.context * ParseTree.stmt -> AST.stmt      val check : Env.t * Env.context * ParseTree.stmt -> AST.stmt
13    
14      (* type check a variable declaration *)
15        val checkVarDecl : Env.t * Env.context * Var.kind * ParseTree.var_dcl
16              -> (Atom.atom * Var.t * AST.expr option)
17    
18      (* check the creation of a new strand; either in a "new" statement or in the
19       * initial-strands creation code.
20       *)
21        val checkStrandCreate : Env.t * Env.context * Atom.atom * ParseTree.expr list -> AST.stmt
22    
23    end = struct    end = struct
24    
25      structure PT = ParseTree      structure PT = ParseTree
26      structure L = Literal      structure L = Literal
27      structure E = Env      structure E = Env
28      structure Ty = Types      structure Ty = Types
29        structure TU = TypeUtil
30      structure BV = BasisVars      structure BV = BasisVars
31    
32      val chkE = CheckExpr.check      val chkE = CheckExpr.check
33    
34    (* a statement to return when there is a type error *)    (* a statement to return when there is a type error *)
35      val bogusStm = AST.S_Block[]      fun bogusStm env = (AST.S_Block[], env)
36    
37      fun err arg = (TypeError.error arg; bogusStm)      val err = TypeError.error
38      val warn = TypeError.warning      val warn = TypeError.warning
39    
40      datatype token = datatype TypeError.token      datatype token = datatype TypeError.token
41    
42      (* mark a variable use with its location *)
43        fun useVar (cxt, x) = (x, Error.location cxt)
44    
45    (* typecheck a variable declaration *)    (* typecheck a variable declaration *)
46      fun checkVarDecl (env, cxt, kind, d) = (case d      fun checkVarDecl (env, cxt, kind, d) = (case d
47             of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)             of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)
48              | PT.VD_Decl(ty, {span, tree=x}, e) => let              | PT.VD_Decl(ty, {span, tree=x}, optExp) => let
49                  val ty = CheckType.check (cxt, ty)                  val ty = CheckType.check (env, cxt, ty)
50                  val x' = Var.new (x, Error.location(#1 cxt, span), kind, ty)                  val x' = Var.new (x, Error.location(#1 cxt, span), kind, ty)
                 val (e', ty') = chkE (env, cxt, e)  
51                  in                  in
52                    case coerceType (ty, ty', e')                    case optExp
53                     of SOME e' => (x, x', e')                     of SOME e => let
54                      | NONE => err(cxt, [                          val eTy = chkE (env, cxt, e)
55                            in
56                              case Util.coerceType (ty, eTy)
57                               of SOME(e', _) => (x, x', SOME e')
58                                | NONE => (
59                                    err(cxt, [
60                          S "type of variable ", A x,                          S "type of variable ", A x,
61                          S " does not match type of initializer\n",                          S " does not match type of initializer\n",
62                          S "  expected: ", TY ty, S "\n",                          S "  expected: ", TY ty, S "\n",
63                          S "  but found: ", TY ty'                                      S "  but found: ", TY(#2 eTy)
64                        ])                                    ]);
65                                    (x, x', NONE))
66                    (* end case *)                    (* end case *)
67                  end                  end
68                      | NONE => (x, x', NONE)
69                    end
70            (* end case *))            (* end case *))
71    
72      (* check the creation of a new strand; either in a "new" statement or in an "initially"
73       * block.
74       *)
75        fun checkStrandCreate (env, cxt, strand, args) = let
76              val argsAndTys' = List.map (fn e => CheckExpr.check(env, cxt, e)) args
77              val (args', tys') = ListPair.unzip argsAndTys'
78              in
79              (* check that strand is defined and that the argument types match *)
80                case Env.findStrand (env, strand)
81                 of SOME sEnv => let
82                      val paramTys = StrandEnv.paramTys sEnv
83                      in
84                        case Unify.matchArgs (paramTys, args', tys')
85                         of SOME args' => AST.S_New(StrandEnv.strandName sEnv, args')
86                          | NONE => (
87                              err (cxt, [
88                                  S "type error in new ", A strand, S "\n",
89                                  S "  expected:  ", TYS paramTys, S "\n",
90                                  S "  but found: ", TYS tys'
91                                ]);
92                              AST.S_Block[])
93                        (* end case *)
94                      end
95                  | NONE => (err (cxt, [S "unknown strand ", A strand]); AST.S_Block[])
96                (* end case *)
97              end
98    
99    (* check for unreachable code and non-return statements in the tail position of a function.    (* check for unreachable code and non-return statements in the tail position of a function.
100     * Note that unreachable code is typechecked and included in the AST.  It is pruned away     * Note that unreachable code is typechecked and included in the AST.  It is pruned away
101     * by simplify.     * by simplify.
# Line 141  Line 189 
189    
190    (* check the type of a statement *)    (* check the type of a statement *)
191      fun chk (env, cxt, e) = (case e      fun chk (env, cxt, e) = (case e
192             of PT.S_Mark m => check (withEnvAndContext (env, cxt, m))             of PT.S_Mark m => chk (E.withEnvAndContext (env, cxt, m))
193              | PT.S_Block stms => let              | PT.S_Block stms => let
194                  fun chk (_, [], stms) = AST.S_Block(List.rev stms)                  fun chk' (_, [], stms) = AST.S_Block(List.rev stms)
195                    | chk (env, s::ss, stms) = let                    | chk' (env, s::ss, stms) = let
196                        val (s', env') = chkStmt (env, cxt, s)                        val (s', env') = chk (env, cxt, s)
197                        in                        in
198                          chk (env', ss, s'::stms)                          chk' (env', ss, s'::stms)
199                        end                        end
200                  in                  in
201                    (chk (Env.blockScope env, stms, []), env)                    (chk' (Env.blockScope env, stms, []), env)
202                  end                  end
203              | PT.S_IfThen(e, s) => let              | PT.S_IfThen(e, s) => let
204                  val (e', ty) = chkE (env, cxt, e)                  val (e', ty) = chkE (env, cxt, e)
205                  val (s', _) = chkStmt (env, cxt, s)                  val (s', _) = chk (env, cxt, s)
206                  in                  in
207                  (* check that condition has bool type *)                  (* check that condition has bool type *)
208                    case ty                    case ty
# Line 165  Line 213 
213                  end                  end
214              | PT.S_IfThenElse(e, s1, s2) => let              | PT.S_IfThenElse(e, s1, s2) => let
215                  val (e', ty) = chkE (env, cxt, e)                  val (e', ty) = chkE (env, cxt, e)
216                  val (s1', _) = chkStmt (env, cxt, s1)                  val (s1', _) = chk (env, cxt, s1)
217                  val (s2', _) = chkStmt (env, cxt, s2)                  val (s2', _) = chk (env, cxt, s2)
218                  in                  in
219                  (* check that condition has bool type *)                  (* check that condition has bool type *)
220                    case ty                    case ty
# Line 175  Line 223 
223                    (* end case *);                    (* end case *);
224                    (AST.S_IfThenElse(e', s1', s2'), env)                    (AST.S_IfThenElse(e', s1', s2'), env)
225                  end                  end
226              | PT.S_Foreach(iter, body) => ??              | PT.S_Foreach(iter, body) => raise Fail "FIXME"
227              | PT.S_Print args => let              | PT.S_Print args => let
228                  fun chkArg e = let                  fun chkArg e = let
229                        val (e', ty) = chkE (env, cxt, e)                        val (e', ty) = chkE (env, cxt, e)
# Line 193  Line 241 
241                  end                  end
242              | PT.S_New(strand, args) => let              | PT.S_New(strand, args) => let
243                (* note that scope has already been checked in chkCtlFlow *)                (* note that scope has already been checked in chkCtlFlow *)
244                  val (strand, args, env) = checkStrandCreate (env, cxt, strand, args)                  val stm = checkStrandCreate (env, cxt, strand, args)
245                  in                  in
246                    Env.recordProp (#env env, StrandUtil.NewStrands);                    Env.recordProp (env, StrandUtil.NewStrands);
247                    (AST.S_New(strand, args), env)                    (stm, env)
248                  end                  end
249              | PT.S_Stabilize => (* note that scope has already been checked in chkCtlFlow *)              | PT.S_Stabilize => (* note that scope has already been checked in chkCtlFlow *)
250                  (AST.S_Stabilize, env)                  (AST.S_Stabilize, env)
251              | PT.S_Die => (              | PT.S_Die => (
252                (* note that scope has already been checked in chkCtlFlow *)                (* note that scope has already been checked in chkCtlFlow *)
253                  Env.recordProp (#env env, StrandUtil.StrandsMayDie);                  Env.recordProp (env, StrandUtil.StrandsMayDie);
254                  (AST.S_Die, env))                  (AST.S_Die, env))
255              | PT.S_Continue => (* note that scope has already been checked in chkCtlFlow *)              | PT.S_Continue => (* note that scope has already been checked in chkCtlFlow *)
256                  (AST.S_Continue, env)                  (AST.S_Continue, env)
257              | PT.S_Return e => let              | PT.S_Return e => let
258                  val (e', ty) = chkE (env, cxt, e)                  val eTy = chkE (env, cxt, e)
259                  in                  in
260                    case #scope env                    case E.currentScope env
261                     of FunctionScope(ty', f) => (case coerceType(ty', ty, e')                     of E.FunctionScope(ty', f) => (case Util.coerceType(ty', eTy)
262                           of SOME e' => (AST.S_Return e', env)                           of SOME(e', _) => (AST.S_Return e', env)
263                            | NONE => err(cxt, [                            | NONE => (
264                                  err (cxt, [
265                                  S "type of return expression does not match return type of function ",                                  S "type of return expression does not match return type of function ",
266                                  A f, S "\n",                                  A f, S "\n",
267                                  S "  expected: ", TY ty', S "\n",                                  S "  expected: ", TY ty', S "\n",
268                                  S "  but found: ", TY ty                                    S "  but found: ", TY(#2 eTy)
269                                ])                                  ]);
270                                  bogusStm env)
271                          (* end case *))                          (* end case *))
272                      | _ => (AST.S_Return e', env) (* this error condition has already been checked *)                      | _ => (AST.S_Return(#1 eTy), env) (* this error condition has already been reported *)
273                    (* end case *)                    (* end case *)
274                  end                  end
275              | PT.S_Decl vd => let              | PT.S_Decl vd => let
276                  val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)                  val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)
277                  in                  in
278                    checkForRedef (env, cxt, x);                    E.checkForRedef (env, cxt, x);
279                    (AST.S_Decl(AST.VD_Decl(x', e)), insertLocal(env, cxt, x, x'))                    (AST.S_Decl(x', e), 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)  
280                        end                        end
281                    | NONE => err(cxt, [S "undeclared variable ", A x, S " on lhs of ", A rator])              | PT.S_Assign({span, tree=x}, rator, e) => (case Env.findVar (env, x)
282                  (* end case *))                   of NONE => (
283              | PT.S_OpAssign(x, e) => (case Env.findVar (#env env, x)                        err (cxt, [S "undefined variable '", A x, S "' on lhs of assignment"]);
284                   of NONE => err(cxt, [                        bogusStm env)
                         S "undefined variable '", A x, S "' on lhs of assignment"  
                       ])  
285                    | SOME x' => let                    | SOME x' => let
286                        val ([], ty) = Var.typeOf x'                        val ([], ty) = Var.typeOf x'
287                        val eTy = chkE (env, cxt, e)                        val eTy = chkE (env, cxt, e)
288                        fun illegalAssign kind = err(cxt, [                        fun illegalAssign kind = (
289                                err (cxt, [
290                                S "assignment to ", S kind, S " '", A x,                                S "assignment to ", S kind, S " '", A x,
291                                S "' in ", S(E.scopeToString(#scope env))                                  S "' in ", S(E.scopeToString(E.currentScope env))
292                              ])                                ]);
293                                bogusStm env)
294                      (* check for assignment to variables that are immutable because of their type *)                      (* check for assignment to variables that are immutable because of their type *)
295                        fun chkAssign () = (case Var.typeOf x'                        fun chkAssign () = (case Var.monoTypeOf x'
296                               of (Ty.T_Field _) => illegalAssign "field-valued variable"                               of (Ty.T_Field _) => illegalAssign "field-valued variable"
297                                | (Ty.T_Image _) => illegalAssign "image-valued variable"                                | (Ty.T_Image _) => illegalAssign "image-valued variable"
298                                | (Ty.T_Kernel _) => illegalAssign "kernel-valued variable"                                | (Ty.T_Kernel _) => illegalAssign "kernel-valued variable"
299                                | ty => let                                | ty => let
300                                      val x' = useVar((#1 cxt, span), x')
301                                  (* check for promotion *)                                  (* check for promotion *)
302                                    val e' = (case Util.coerceType(ty, eTy)                                    val (e', ty') = (case Util.coerceType(ty, eTy)
303                                           of SOME(e', _) => e'                                           of SOME eTy' => eTy'
304                                            | NONE => err(cxt, [                                            | NONE => (
305                                                  err(cxt, [
306                                                  S "type of assigned variable ", A x,                                                  S "type of assigned variable ", A x,
307                                                  S " does not match type of rhs\n",                                                  S " does not match type of rhs\n",
308                                                  S "  expected: ", TY ty, S "\n",                                                  S "  expected: ", TY ty, S "\n",
309                                                  S "  but found: ", TY ty'                                                    S "  but found: ", TY(#2 eTy)
310                                                ])                                                  ]);
311                                                  eTy)
312                                          (* end case *))                                          (* end case *))
313                                    in                                    in
314                                      (AST.S_Assign(x', e'), env)                                      case rator
315                                         of NONE => (AST.S_Assign(x', e'), env)
316                                          | SOME rator => let
317                                              val e1' = AST.E_Var x'
318                                              val Env.PrimFun ovldList = Env.findFunc (env, rator)
319                                              val (rhs, _) = CheckExpr.resolveOverload (
320                                                    cxt, rator, [ty, ty'], [e1', e'], ovldList)
321                                              in
322                                                (AST.S_Assign(x', rhs), env)
323                                              end
324                                        (* end case *)
325                                    end                                    end
326                              (* end case *))                              (* end case *))
327                      (* check that assignment to global variables is allowed in the current scope *)                      (* check that assignment to global variables is allowed in the current scope *)
# Line 308  Line 351 
351                  chk (env, cxt, stm))                  chk (env, cxt, stm))
352            (* end case *))            (* end case *))
353    
354      fun check arg = (chkCtlFlow arg; chk arg)      fun check (env, cxt, stm) = (
355              chkCtlFlow (cxt, E.currentScope env, stm);
356              #1 (chk (env, cxt, stm)))
357    
358    end    end

Legend:
Removed from v.3407  
changed lines
  Added in v.3408

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