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 3412 - (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 :     fun useVar (cxt, x) = (x, Error.location cxt)
44 :    
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 :     | _ => err(cxt, [S "condition not boolean type"])
223 :     (* end case *);
224 :     (AST.S_IfThenElse(e', s1', s2'), env)
225 :     end
226 : jhr 3412 | PT.S_Foreach(iter, body) => let
227 :     fun checkIter (env, cxt, PT.I_Mark m) = checkIter (E.withEnvAndContext (env, cxt, m))
228 :     | checkIter (env, cxt, PT.I_Iterator({span, tree=x}, e)) = (
229 :     case CheckExpr.check (env, cxt, e)
230 :     of (e', ty as Ty.T_Sequence(elemTy, _)) => let
231 :     val x' = Var.new(x, Error.location(#1 cxt, span), Var.LocalVar, elemTy)
232 :     in
233 :     AST.S_Foreach((x', e'),
234 :     #1 (chk (E.insertLocal(env, cxt, x, x'), cxt, body)))
235 :     end
236 :     | (e', ty) => let
237 :     val x' = Var.new(x, Error.UNKNOWN, Var.IterVar, Ty.T_Error)
238 :     in
239 :     TypeError.error (cxt, [
240 :     S "expected sequence type in iteration, but found '", TY ty, S "'"
241 :     ]);
242 :     #1 (chk (E.insertLocal(env, cxt, x, x'), cxt, body))
243 :     end
244 :     (* end case *))
245 :     in
246 :     (checkIter (E.blockScope env, cxt, iter), env)
247 :     end
248 : jhr 3398 | PT.S_Print args => let
249 :     fun chkArg e = let
250 : jhr 3407 val (e', ty) = chkE (env, cxt, e)
251 : jhr 3398 in
252 :     if TU.isValueType ty
253 :     then ()
254 :     else err(cxt, [
255 :     S "expected value type in print, but found ", TY ty
256 :     ]);
257 :     e'
258 :     end
259 :     val args' = List.map chkArg args
260 :     in
261 :     (AST.S_Print args', env)
262 :     end
263 :     | PT.S_New(strand, args) => let
264 :     (* note that scope has already been checked in chkCtlFlow *)
265 : jhr 3408 val stm = checkStrandCreate (env, cxt, strand, args)
266 : jhr 3398 in
267 : jhr 3408 Env.recordProp (env, StrandUtil.NewStrands);
268 :     (stm, env)
269 : jhr 3398 end
270 :     | PT.S_Stabilize => (* note that scope has already been checked in chkCtlFlow *)
271 :     (AST.S_Stabilize, env)
272 :     | PT.S_Die => (
273 :     (* note that scope has already been checked in chkCtlFlow *)
274 : jhr 3408 Env.recordProp (env, StrandUtil.StrandsMayDie);
275 : jhr 3398 (AST.S_Die, env))
276 :     | PT.S_Continue => (* note that scope has already been checked in chkCtlFlow *)
277 :     (AST.S_Continue, env)
278 :     | PT.S_Return e => let
279 : jhr 3408 val eTy = chkE (env, cxt, e)
280 : jhr 3398 in
281 : jhr 3408 case E.currentScope env
282 :     of E.FunctionScope(ty', f) => (case Util.coerceType(ty', eTy)
283 : jhr 3410 of SOME e' => (AST.S_Return e', env)
284 : jhr 3408 | NONE => (
285 :     err (cxt, [
286 :     S "type of return expression does not match return type of function ",
287 :     A f, S "\n",
288 :     S " expected: ", TY ty', S "\n",
289 :     S " but found: ", TY(#2 eTy)
290 :     ]);
291 :     bogusStm env)
292 : jhr 3398 (* end case *))
293 : jhr 3408 | _ => (AST.S_Return(#1 eTy), env) (* this error condition has already been reported *)
294 : jhr 3398 (* end case *)
295 :     end
296 :     | PT.S_Decl vd => let
297 :     val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)
298 :     in
299 : jhr 3408 E.checkForRedef (env, cxt, x);
300 :     (AST.S_Decl(x', e), E.insertLocal(env, cxt, x, x'))
301 : jhr 3398 end
302 : jhr 3408 | PT.S_Assign({span, tree=x}, rator, e) => (case Env.findVar (env, x)
303 :     of NONE => (
304 :     err (cxt, [S "undefined variable '", A x, S "' on lhs of assignment"]);
305 :     bogusStm env)
306 : jhr 3398 | SOME x' => let
307 :     val ([], ty) = Var.typeOf x'
308 : jhr 3407 val eTy = chkE (env, cxt, e)
309 : jhr 3408 fun illegalAssign kind = (
310 :     err (cxt, [
311 :     S "assignment to ", S kind, S " '", A x,
312 :     S "' in ", S(E.scopeToString(E.currentScope env))
313 :     ]);
314 :     bogusStm env)
315 : jhr 3407 (* check for assignment to variables that are immutable because of their type *)
316 : jhr 3408 fun chkAssign () = (case Var.monoTypeOf x'
317 : jhr 3407 of (Ty.T_Field _) => illegalAssign "field-valued variable"
318 :     | (Ty.T_Image _) => illegalAssign "image-valued variable"
319 :     | (Ty.T_Kernel _) => illegalAssign "kernel-valued variable"
320 :     | ty => let
321 : jhr 3408 val x' = useVar((#1 cxt, span), x')
322 : jhr 3407 (* check for promotion *)
323 : jhr 3408 val (e', ty') = (case Util.coerceType(ty, eTy)
324 : jhr 3410 of SOME e' => (e', ty)
325 : jhr 3408 | NONE => (
326 :     err(cxt, [
327 :     S "type of assigned variable ", A x,
328 :     S " does not match type of rhs\n",
329 :     S " expected: ", TY ty, S "\n",
330 :     S " but found: ", TY(#2 eTy)
331 :     ]);
332 :     eTy)
333 : jhr 3407 (* end case *))
334 :     in
335 : jhr 3408 case rator
336 :     of NONE => (AST.S_Assign(x', e'), env)
337 :     | SOME rator => let
338 :     val e1' = AST.E_Var x'
339 :     val Env.PrimFun ovldList = Env.findFunc (env, rator)
340 :     val (rhs, _) = CheckExpr.resolveOverload (
341 :     cxt, rator, [ty, ty'], [e1', e'], ovldList)
342 :     in
343 :     (AST.S_Assign(x', rhs), env)
344 :     end
345 :     (* end case *)
346 : jhr 3407 end
347 : jhr 3398 (* end case *))
348 : jhr 3407 (* check that assignment to global variables is allowed in the current scope *)
349 :     fun chkGlobalAssign () = (case E.currentScope env
350 :     of E.FunctionScope _ => illegalAssign "global variable"
351 :     | E.MethodScope _ => illegalAssign "global variable"
352 :     | E.InitScope => chkAssign()
353 :     | E.UpdateScope => chkAssign()
354 :     | _ => raise Fail "impossible scope"
355 :     (* end case *))
356 : jhr 3398 in
357 : jhr 3407 (* check that assigning to x' is okay *)
358 : jhr 3398 case Var.kindOf x'
359 : jhr 3407 of Var.BasisVar => illegalAssign "builtin function"
360 :     | Var.ConstVar => illegalAssign "constant variable"
361 :     | Var.InputVar => chkGlobalAssign ()
362 :     | Var.GlobalVar => chkGlobalAssign ()
363 :     | Var.FunVar => illegalAssign "function"
364 :     | Var.FunParam => illegalAssign "function parameter"
365 :     | Var.StrandParam => illegalAssign "strand parameter"
366 : jhr 3412 | Var.IterVar => illegalAssign "iteration variable"
367 : jhr 3407 | _ => chkAssign ()
368 :     (* end case *)
369 : jhr 3398 end
370 :     (* end case *))
371 :     | PT.S_Deprecate(msg, stm) => (
372 :     warn (cxt, [S msg]);
373 :     chk (env, cxt, stm))
374 :     (* end case *))
375 :    
376 : jhr 3408 fun check (env, cxt, stm) = (
377 :     chkCtlFlow (cxt, E.currentScope env, stm);
378 :     #1 (chk (env, cxt, stm)))
379 : jhr 3398
380 :     end

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