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

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