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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3428 - (view) (download)

1 : jhr 3398 (* check-stmt.sml
2 :     *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2015 The University of Chicago
6 :     * All rights reserved.
7 :     *)
8 :    
9 :     structure CheckStmt : sig
10 :    
11 : jhr 3408 (* type check a statement *)
12 : jhr 3407 val check : Env.t * Env.context * ParseTree.stmt -> AST.stmt
13 : jhr 3398
14 : jhr 3408 (* 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 : jhr 3398 end = struct
24 :    
25 :     structure PT = ParseTree
26 : jhr 3407 structure L = Literal
27 : jhr 3398 structure E = Env
28 :     structure Ty = Types
29 : jhr 3408 structure TU = TypeUtil
30 : jhr 3398 structure BV = BasisVars
31 :    
32 :     val chkE = CheckExpr.check
33 :    
34 :     (* a statement to return when there is a type error *)
35 : jhr 3408 fun bogusStm env = (AST.S_Block[], env)
36 : jhr 3398
37 : jhr 3408 val err = TypeError.error
38 : jhr 3398 val warn = TypeError.warning
39 :    
40 : jhr 3402 datatype token = datatype TypeError.token
41 : jhr 3398
42 : jhr 3408 (* mark a variable use with its location *)
43 : jhr 3413 fun useVar (cxt : Env.context, x) = (x, #2 cxt)
44 : jhr 3408
45 : jhr 3398 (* typecheck a variable declaration *)
46 :     fun checkVarDecl (env, cxt, kind, d) = (case d
47 :     of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)
48 : jhr 3408 | PT.VD_Decl(ty, {span, tree=x}, optExp) => let
49 :     val ty = CheckType.check (env, cxt, ty)
50 : jhr 3407 val x' = Var.new (x, Error.location(#1 cxt, span), kind, ty)
51 : jhr 3408 in
52 :     case optExp
53 :     of SOME e => let
54 :     val eTy = chkE (env, cxt, e)
55 :     in
56 :     case Util.coerceType (ty, eTy)
57 : jhr 3410 of SOME e' => (x, x', SOME e')
58 : jhr 3408 | NONE => (
59 :     err(cxt, [
60 :     S "type of variable ", A x,
61 :     S " does not match type of initializer\n",
62 :     S " expected: ", TY ty, S "\n",
63 :     S " but found: ", TY(#2 eTy)
64 :     ]);
65 :     (x, x', NONE))
66 :     (* end case *)
67 :     end
68 :     | NONE => (x, x', NONE)
69 :     end
70 : jhr 3398 (* end case *))
71 :    
72 : jhr 3408 (* 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 : jhr 3398 (* 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
101 :     * by simplify.
102 :     *)
103 :     fun chkCtlFlow (cxt, scope, stm) = let
104 :     val (inFun, inInitOrUpdate, funName) = (case scope
105 : jhr 3407 of E.FunctionScope(_, f) => (true, false, Atom.toString f)
106 :     | E.MethodScope StrandUtil.Initially => (false, true, "")
107 :     | E.MethodScope StrandUtil.Update => (false, true, "")
108 : jhr 3398 | _ => (false, false, "")
109 :     (* end case *))
110 :     (* checks a statement for correct control flow; it returns false if control may
111 :     * flow from the statement to the next in a sequence and true if control cannot
112 :     * flow to the next statement.
113 :     *)
114 :     fun chk ((errStrm, _), hasSucc, isJoin, unreachable, PT.S_Mark{span, tree}) =
115 :     chk((errStrm, span), hasSucc, isJoin, unreachable, tree)
116 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Block(stms as _::_)) = let
117 :     fun chk' ([], escapes) = escapes
118 :     | chk' ([stm], escapes) =
119 :     chk(cxt, hasSucc, isJoin, escapes orelse unreachable, stm) orelse escapes
120 :     | chk' (stm::stms, escapes) = let
121 :     val escapes = chk(cxt, true, false, escapes orelse unreachable, stm) orelse escapes
122 :     in
123 :     chk'(stms, escapes)
124 :     end
125 :     in
126 :     chk' (stms, false)
127 :     end
128 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_IfThen(_, stm)) = (
129 :     if inFun andalso not hasSucc andalso not unreachable
130 :     then err(cxt, [
131 :     S "Missing return statement in tail position of function ", S funName
132 :     ])
133 :     else ();
134 :     ignore (chk (cxt, hasSucc, true, unreachable, stm));
135 :     false)
136 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_IfThenElse(_, stm1, stm2)) = let
137 :     val escapes = chk (cxt, hasSucc, true, unreachable, stm1)
138 :     val escapes = chk (cxt, hasSucc, true, unreachable, stm2) andalso escapes
139 :     in
140 :     if escapes andalso hasSucc andalso not unreachable
141 :     then (
142 :     warn(cxt, [S "unreachable statements after \"if-then-else\" statement"]);
143 :     true)
144 :     else escapes
145 :     end
146 :     | chk (cxt, _, _, _, PT.S_New _) = (
147 :     if not inInitOrUpdate
148 :     then err(cxt, [S "\"new\" statement outside of initially/update method"])
149 :     else ();
150 :     false)
151 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Die) = (
152 :     if not inInitOrUpdate
153 :     then err(cxt, [S "\"die\" statment outside of initially/update method"])
154 :     else if hasSucc andalso not isJoin andalso not unreachable
155 :     then warn(cxt, [S "statements following \"die\" statment are unreachable"])
156 :     else ();
157 :     true)
158 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Continue) = (
159 :     if not inInitOrUpdate
160 :     then err(cxt, [S "\"continue\" statment outside of initially/update method"])
161 :     else if hasSucc andalso not isJoin andalso not unreachable
162 :     then warn(cxt, [S "statements following \"continue\" statment are unreachable"])
163 :     else ();
164 :     true)
165 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Stabilize) = (
166 :     if not inInitOrUpdate
167 :     then err(cxt, [S "\"stabilize\" statment outside of initially/update method"])
168 :     else if hasSucc andalso not isJoin andalso not unreachable
169 :     then warn(cxt, [S "statements following \"stabilize\" statment are unreachable"])
170 :     else ();
171 :     true)
172 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Return _) = (
173 :     if not inFun
174 :     then err(cxt, [S "\"return\" statment outside of function body"])
175 :     else if hasSucc andalso not isJoin andalso not unreachable
176 :     then warn(cxt, [S "statements following \"return\" statment are unreachable"])
177 :     else ();
178 :     true)
179 :     | chk (cxt, hasSucc, isJoin, unreachable, _) = (
180 :     if inFun andalso not hasSucc andalso not unreachable
181 :     then err(cxt, [
182 :     S "Missing return statement in tail position of function ", S funName
183 :     ])
184 :     else ();
185 :     false)
186 :     in
187 :     ignore (chk (cxt, false, false, false, stm))
188 :     end
189 :    
190 :     (* check the type of a statement *)
191 :     fun chk (env, cxt, e) = (case e
192 : jhr 3408 of PT.S_Mark m => chk (E.withEnvAndContext (env, cxt, m))
193 : jhr 3398 | PT.S_Block stms => let
194 : jhr 3408 fun chk' (_, [], stms) = AST.S_Block(List.rev stms)
195 :     | chk' (env, s::ss, stms) = let
196 :     val (s', env') = chk (env, cxt, s)
197 : jhr 3398 in
198 : jhr 3408 chk' (env', ss, s'::stms)
199 : jhr 3398 end
200 :     in
201 : jhr 3408 (chk' (Env.blockScope env, stms, []), env)
202 : jhr 3398 end
203 :     | PT.S_IfThen(e, s) => let
204 : jhr 3407 val (e', ty) = chkE (env, cxt, e)
205 : jhr 3408 val (s', _) = chk (env, cxt, s)
206 : jhr 3398 in
207 :     (* check that condition has bool type *)
208 :     case ty
209 :     of Ty.T_Bool => ()
210 :     | _ => err(cxt, [S "condition not boolean type"])
211 :     (* end case *);
212 :     (AST.S_IfThenElse(e', s', AST.S_Block[]), env)
213 :     end
214 :     | PT.S_IfThenElse(e, s1, s2) => let
215 : jhr 3407 val (e', ty) = chkE (env, cxt, e)
216 : jhr 3408 val (s1', _) = chk (env, cxt, s1)
217 :     val (s2', _) = chk (env, cxt, s2)
218 : jhr 3398 in
219 :     (* check that condition has bool type *)
220 :     case ty
221 :     of Ty.T_Bool => ()
222 : jhr 3428 | _ => err (cxt, [S "expected type 'bool' for condition, but found ", TY ty])
223 : jhr 3398 (* end case *);
224 :     (AST.S_IfThenElse(e', s1', s2'), env)
225 :     end
226 : jhr 3428 | PT.S_Foreach(ty, iter, body) => let
227 :     val ty = CheckType.check (env, cxt, ty)
228 : jhr 3424 val ((x', e'), env') = CheckExpr.checkIter (E.blockScope env, cxt, iter)
229 : jhr 3412 in
230 : jhr 3428 if Unify.equalType(ty, Var.monoTypeOf x')
231 :     then ()
232 :     else err (cxt, [
233 :     S "type mismatch in iterator\n",
234 :     S " declared element type: ", TY ty, S "\n",
235 :     S " actual element type: ", TY(Var.monoTypeOf x')
236 :     ]);
237 : jhr 3424 (AST.S_Foreach((x', e'), #1 (chk (env', cxt, body))), env)
238 : jhr 3412 end
239 : jhr 3398 | PT.S_Print args => let
240 :     fun chkArg e = let
241 : jhr 3407 val (e', ty) = chkE (env, cxt, e)
242 : jhr 3398 in
243 :     if TU.isValueType ty
244 :     then ()
245 : jhr 3428 else err (cxt, [
246 : jhr 3398 S "expected value type in print, but found ", TY ty
247 :     ]);
248 :     e'
249 :     end
250 :     val args' = List.map chkArg args
251 :     in
252 :     (AST.S_Print args', env)
253 :     end
254 :     | PT.S_New(strand, args) => let
255 :     (* note that scope has already been checked in chkCtlFlow *)
256 : jhr 3408 val stm = checkStrandCreate (env, cxt, strand, args)
257 : jhr 3398 in
258 : jhr 3408 Env.recordProp (env, StrandUtil.NewStrands);
259 :     (stm, env)
260 : jhr 3398 end
261 :     | PT.S_Stabilize => (* note that scope has already been checked in chkCtlFlow *)
262 :     (AST.S_Stabilize, env)
263 :     | PT.S_Die => (
264 :     (* note that scope has already been checked in chkCtlFlow *)
265 : jhr 3408 Env.recordProp (env, StrandUtil.StrandsMayDie);
266 : jhr 3398 (AST.S_Die, env))
267 :     | PT.S_Continue => (* note that scope has already been checked in chkCtlFlow *)
268 :     (AST.S_Continue, env)
269 :     | PT.S_Return e => let
270 : jhr 3408 val eTy = chkE (env, cxt, e)
271 : jhr 3398 in
272 : jhr 3408 case E.currentScope env
273 :     of E.FunctionScope(ty', f) => (case Util.coerceType(ty', eTy)
274 : jhr 3410 of SOME e' => (AST.S_Return e', env)
275 : jhr 3408 | NONE => (
276 :     err (cxt, [
277 :     S "type of return expression does not match return type of function ",
278 :     A f, S "\n",
279 :     S " expected: ", TY ty', S "\n",
280 :     S " but found: ", TY(#2 eTy)
281 :     ]);
282 :     bogusStm env)
283 : jhr 3398 (* end case *))
284 : jhr 3408 | _ => (AST.S_Return(#1 eTy), env) (* this error condition has already been reported *)
285 : jhr 3398 (* end case *)
286 :     end
287 :     | PT.S_Decl vd => let
288 :     val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)
289 :     in
290 : jhr 3408 E.checkForRedef (env, cxt, x);
291 :     (AST.S_Decl(x', e), E.insertLocal(env, cxt, x, x'))
292 : jhr 3398 end
293 : jhr 3408 | PT.S_Assign({span, tree=x}, rator, e) => (case Env.findVar (env, x)
294 :     of NONE => (
295 : jhr 3419 err (cxt, [S "undefined variable ", A x, S " on lhs of assignment"]);
296 : jhr 3408 bogusStm env)
297 : jhr 3398 | SOME x' => let
298 :     val ([], ty) = Var.typeOf x'
299 : jhr 3407 val eTy = chkE (env, cxt, e)
300 : jhr 3408 fun illegalAssign kind = (
301 :     err (cxt, [
302 : jhr 3421 S "illegal assignment to ", S kind, S " ", A x,
303 : jhr 3419 S " in ", S(E.scopeToString(E.currentScope env))
304 : jhr 3408 ]);
305 :     bogusStm env)
306 : jhr 3407 (* check for assignment to variables that are immutable because of their type *)
307 : jhr 3408 fun chkAssign () = (case Var.monoTypeOf x'
308 : jhr 3407 of (Ty.T_Field _) => illegalAssign "field-valued variable"
309 :     | (Ty.T_Image _) => illegalAssign "image-valued variable"
310 :     | (Ty.T_Kernel _) => illegalAssign "kernel-valued variable"
311 :     | ty => let
312 : jhr 3408 val x' = useVar((#1 cxt, span), x')
313 : jhr 3407 (* check for promotion *)
314 : jhr 3408 val (e', ty') = (case Util.coerceType(ty, eTy)
315 : jhr 3410 of SOME e' => (e', ty)
316 : jhr 3408 | NONE => (
317 :     err(cxt, [
318 :     S "type of assigned variable ", A x,
319 :     S " does not match type of rhs\n",
320 :     S " expected: ", TY ty, S "\n",
321 :     S " but found: ", TY(#2 eTy)
322 :     ]);
323 :     eTy)
324 : jhr 3407 (* end case *))
325 :     in
326 : jhr 3408 case rator
327 :     of NONE => (AST.S_Assign(x', e'), env)
328 :     | SOME rator => let
329 :     val e1' = AST.E_Var x'
330 :     val Env.PrimFun ovldList = Env.findFunc (env, rator)
331 :     val (rhs, _) = CheckExpr.resolveOverload (
332 :     cxt, rator, [ty, ty'], [e1', e'], ovldList)
333 :     in
334 :     (AST.S_Assign(x', rhs), env)
335 :     end
336 :     (* end case *)
337 : jhr 3407 end
338 : jhr 3398 (* end case *))
339 : jhr 3407 (* check that assignment to global variables is allowed in the current scope *)
340 :     fun chkGlobalAssign () = (case E.currentScope env
341 :     of E.FunctionScope _ => illegalAssign "global variable"
342 :     | E.MethodScope _ => illegalAssign "global variable"
343 :     | E.InitScope => chkAssign()
344 :     | E.UpdateScope => chkAssign()
345 :     | _ => raise Fail "impossible scope"
346 :     (* end case *))
347 : jhr 3398 in
348 : jhr 3407 (* check that assigning to x' is okay *)
349 : jhr 3398 case Var.kindOf x'
350 : jhr 3407 of Var.BasisVar => illegalAssign "builtin function"
351 :     | Var.ConstVar => illegalAssign "constant variable"
352 :     | Var.InputVar => chkGlobalAssign ()
353 :     | Var.GlobalVar => chkGlobalAssign ()
354 :     | Var.FunVar => illegalAssign "function"
355 :     | Var.FunParam => illegalAssign "function parameter"
356 :     | Var.StrandParam => illegalAssign "strand parameter"
357 : jhr 3412 | Var.IterVar => illegalAssign "iteration variable"
358 : jhr 3407 | _ => chkAssign ()
359 :     (* end case *)
360 : jhr 3398 end
361 :     (* end case *))
362 :     | PT.S_Deprecate(msg, stm) => (
363 :     warn (cxt, [S msg]);
364 :     chk (env, cxt, stm))
365 :     (* end case *))
366 :    
367 : jhr 3408 fun check (env, cxt, stm) = (
368 :     chkCtlFlow (cxt, E.currentScope env, stm);
369 :     #1 (chk (env, cxt, stm)))
370 : jhr 3398
371 :     end

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