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-expr.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3405 - (view) (download)

1 : jhr 3396 (* check-expr.sml
2 :     *
3 :     * The typechecker for expressions.
4 :     *
5 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
6 :     *
7 :     * COPYRIGHT (c) 2015 The University of Chicago
8 :     * All rights reserved.
9 :     *)
10 :    
11 :     structure CheckExpr : sig
12 :    
13 :     val check : Env.env * Env.context * ParseTree.expr -> (AST.expr * Types.ty)
14 :    
15 :     end = struct
16 :    
17 :     structure PT = ParseTree
18 :     structure L = Literal
19 :     structure E = Env
20 :     structure Ty = Types
21 :     structure BV = BasisVars
22 : jhr 3405 structure TU = TypeUtil
23 : jhr 3396
24 :     (* an expression to return when there is a type error *)
25 : jhr 3405 val bogusExp = AST.E_Lit(L.Int 0)
26 :     val bogusExpTy = (bogusExp, Ty.T_Error)
27 : jhr 3396
28 : jhr 3405 fun err arg = (TypeError.error arg; bogusExpTy)
29 : jhr 3396 val warn = TypeError.warning
30 :    
31 : jhr 3402 datatype token = datatype TypeError.token
32 : jhr 3396
33 :     (* check the type of a literal *)
34 :     fun checkLit lit = (case lit
35 :     of (L.Int _) => (AST.E_Lit lit, Ty.T_Int)
36 :     | (L.Real _) => (AST.E_Lit lit, Ty.realTy)
37 :     | (L.String s) => (AST.E_Lit lit, Ty.T_String)
38 :     | (L.Bool _) => (AST.E_Lit lit, Ty.T_Bool)
39 :     (* end case *))
40 :    
41 : jhr 3405 (* check a tensor shape *)
42 :     fun checkShape (cxt, shape) = let
43 :     fun checkDim d = (
44 :     if (d <= 1)
45 :     then TypeError.error (cxt, [S "invalid tensor-shape dimension; must be > 1"])
46 :     else ();
47 :     Ty.DimConst(IntInf.toInt d))
48 :     in
49 :     Ty.Shape(List.map checkDim shape)
50 :     end
51 :    
52 :     (* type check a dot product, which has the constraint:
53 :     * ALL[sigma1, d1, sigma2] . tensor[sigma1, d1] * tensor[d1, sigma2] -> tensor[sigma1, sigma2]
54 :     * and similarly for fields.
55 :     *)
56 :     fun chkInnerProduct (cxt, e1, ty1, e2, ty2) = let
57 :     (* check the shape of the two arguments to verify that the inner constraint matches *)
58 :     fun chkShape (Ty.Shape(dd1 as _::_), Ty.Shape(d2::dd2)) = let
59 :     val (dd1, d1) = let
60 :     fun splitLast (prefix, [d]) = (List.rev prefix, d)
61 :     | splitLast (prefix, d::dd) = splitLast (d::prefix, dd)
62 :     | splitLast (_, []) = raise Fail "impossible"
63 :     in
64 :     splitLast ([], dd1)
65 :     end
66 :     in
67 :     if Unify.equalDim(d1, d2)
68 :     then SOME(Ty.Shape(dd1@dd2))
69 :     else NONE
70 :     end
71 :     | chkShape _ = NONE
72 :     fun error () = err (cxt, [
73 :     S "type error for arguments of binary operator '•'\n",
74 :     S " found: ", TYS[ty1, ty2], S "\n"
75 :     ])
76 :     in
77 :     case (TU.prune ty1, TU.prune ty2)
78 :     (* tensor * tensor inner product *)
79 :     of (Ty.T_Tensor s1, Ty.T_Tensor s2) => (case chkShape(s1, s2)
80 :     of SOME shp => let
81 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_inner_tt)
82 :     val resTy = Ty.T_Tensor shp
83 :     in
84 :     if Unify.equalTypes(domTy, [ty1, ty2]) andalso Unify.equalType(rngTy, resTy)
85 :     then (AST.E_Apply(BV.op_inner_tt, tyArgs, [e1, e2], rngTy), rngTy)
86 :     else error()
87 :     end
88 :     | NONE => error()
89 :     (* end case *))
90 :     (* tensor * field inner product *)
91 :     | (Ty.T_Tensor s1, Ty.T_Field{diff, dim, shape=s2}) => (case chkShape(s1, s2)
92 :     of SOME shp => let
93 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_inner_tf)
94 :     val resTy = Ty.T_Field{diff=diff, dim=dim, shape=shp}
95 :     in
96 :     if Unify.equalTypes(domTy, [ty1, ty2])
97 :     andalso Unify.equalType(rngTy, resTy)
98 :     then (AST.E_Apply(BV.op_inner_tf, tyArgs, [e1, e2], rngTy), rngTy)
99 :     else error()
100 :     end
101 :     | NONE => error()
102 :     (* end case *))
103 :     (* field * tensor inner product *)
104 :     | (Ty.T_Field{diff, dim, shape=s1}, Ty.T_Tensor s2) => (case chkShape(s1, s2)
105 :     of SOME shp => let
106 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_inner_ft)
107 :     val resTy = Ty.T_Field{diff=diff, dim=dim, shape=shp}
108 :     in
109 :     if Unify.equalTypes(domTy, [ty1, ty2])
110 :     andalso Unify.equalType(rngTy, resTy)
111 :     then (AST.E_Apply(BV.op_inner_ft, tyArgs, [e1, e2], rngTy), rngTy)
112 :     else error()
113 :     end
114 :     | NONE => error()
115 :     (* end case *))
116 :     (* field * field inner product *)
117 :     | (Ty.T_Field{diff=k1, dim=dim1, shape=s1}, Ty.T_Field{diff=k2, dim=dim2, shape=s2}) => (
118 :     case chkShape(s1, s2)
119 :     of SOME shp => let
120 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_inner_ff)
121 :     val resTy = Ty.T_Field{diff=k1, dim=dim1, shape=shp}
122 :     in
123 :     (* FIXME: the resulting differentiation should be the minimum of k1 and k2 *)
124 :     if Unify.equalDim(dim1, dim2)
125 :     andalso Unify.equalTypes(domTy, [ty1, ty2])
126 :     andalso Unify.equalType(rngTy, resTy)
127 :     then (AST.E_Apply(BV.op_inner_ff, tyArgs, [e1, e2], rngTy), rngTy)
128 :     else error()
129 :     end
130 :     | NONE => error()
131 :     (* end case *))
132 :     | (ty1, ty2) => error()
133 :     (* end case *)
134 :     end
135 :    
136 :     (* type check a colon product, which has the constraint:
137 :     * ALL[sigma1, d1, d2, sigma2] . tensor[sigma1, d1, d2] * tensor[d2, d1, sigma2] -> tensor[sigma1, sigma2]
138 :     * and similarly for fields.
139 :     *)
140 :     fun chkColonProduct (cxt, e1, ty1, e2, ty2) = let
141 :     (* check the shape of the two arguments to verify that the inner constraint matches *)
142 :     fun chkShape (Ty.Shape(dd1 as _::_::_), Ty.Shape(d21::d22::dd2)) = let
143 :     val (dd1, d11, d12) = let
144 :     fun splitLast2 (prefix, [d1, d2]) = (List.rev prefix, d1, d2)
145 :     | splitLast2 (prefix, d::dd) = splitLast2 (d::prefix, dd)
146 :     | splitLast2 (_, []) = raise Fail "impossible"
147 :     in
148 :     splitLast2 ([], dd1)
149 :     end
150 :     in
151 :     if Unify.equalDim(d11, d21) andalso Unify.equalDim(d12, d22)
152 :     then SOME(Ty.Shape(dd1@dd2))
153 :     else NONE
154 :     end
155 :     | chkShape _ = NONE
156 :     fun error () = err (cxt, [
157 :     S "type error for arguments of binary operator \":\"\n",
158 :     S " found: ", TYS[ty1, ty2], S "\n"
159 :     ])
160 :     in
161 :     case (TU.prune ty1, TU.prune ty2)
162 :     (* tensor * tensor colon product *)
163 :     of (Ty.T_Tensor s1, Ty.T_Tensor s2) => (case chkShape(s1, s2)
164 :     of SOME shp => let
165 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_colon_tt)
166 :     val resTy = Ty.T_Tensor shp
167 :     in
168 :     if Unify.equalTypes(domTy, [ty1, ty2])
169 :     andalso Unify.equalType(rngTy, resTy)
170 :     then (AST.E_Apply(BV.op_colon_tt, tyArgs, [e1, e2], rngTy), rngTy)
171 :     else error()
172 :     end
173 :     | NONE => error()
174 :     (* end case *))
175 :     (* field * tensor colon product *)
176 :     | (Ty.T_Field{diff, dim, shape=s1}, Ty.T_Tensor s2) => (case chkShape(s1, s2)
177 :     of SOME shp => let
178 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_colon_ft)
179 :     val resTy = Ty.T_Field{diff=diff, dim=dim, shape=shp}
180 :     in
181 :     if Unify.equalTypes(domTy, [ty1, ty2]) andalso Unify.equalType(rngTy, resTy)
182 :     then (AST.E_Apply(BV.op_colon_ft, tyArgs, [e1, e2], rngTy), rngTy)
183 :     else error()
184 :     end
185 :     | NONE => error()
186 :     (* end case *))
187 :     (* tensor * field colon product *)
188 :     | (Ty.T_Tensor s1, Ty.T_Field{diff=diff, dim=dim, shape=s2}) => (case chkShape(s1, s2)
189 :     of SOME shp => let
190 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_colon_tf)
191 :     val resTy = Ty.T_Field{diff=diff, dim=dim, shape=shp}
192 :     in
193 :     if Unify.equalTypes(domTy, [ty1, ty2]) andalso Unify.equalType(rngTy, resTy)
194 :     then (AST.E_Apply(BV.op_colon_tf, tyArgs, [e1, e2], rngTy), rngTy)
195 :     else error()
196 :     end
197 :     | NONE => error()
198 :     (* end case *))
199 :     (* field * field colon product *)
200 :     | (Ty.T_Field{diff=k1, dim=dim1, shape=s1}, Ty.T_Field{diff=k2, dim=dim2, shape=s2}) => (
201 :     case chkShape(s1, s2)
202 :     of SOME shp => let
203 :     val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf BV.op_colon_ff)
204 :     val resTy = Ty.T_Field{diff=k1, dim=dim1, shape=shp}
205 :     in
206 :     (* FIXME: the resulting differentiation should be the minimum of k1 and k2 *)
207 :     if Unify.equalDim(dim1, dim2)
208 :     andalso Unify.equalTypes(domTy, [ty1, ty2])
209 :     andalso Unify.equalType(rngTy, resTy)
210 :     then (AST.E_Apply(BV.op_colon_ff, tyArgs, [e1, e2], rngTy), rngTy)
211 :     else error()
212 :     end
213 :     | NONE => error()
214 :     (* end case *))
215 :     | (ty1, ty2) => error()
216 :     (* end case *)
217 :     end
218 :    
219 : jhr 3396 (* check the type of an expression *)
220 :     fun check (env, cxt, e) = (case e
221 : jhr 3405 of PT.E_Mark m => check (E.withEnvAndContext (env, cxt, m))
222 : jhr 3396 | PT.E_Cond(e1, cond, e2) => let
223 :     val eTy1 = check (env, cxt, e1)
224 :     val eTy2 = check (env, cxt, e2)
225 :     in
226 : jhr 3402 case check(env, cxt, cond)
227 : jhr 3396 of (cond', Ty.T_Bool) => (case Util.coerceType2(eTy1, eTy2)
228 : jhr 3405 of SOME(e1', e2', ty) => (AST.E_Cond(cond', e1', e2', ty), ty)
229 : jhr 3396 | NONE => err (cxt, [
230 :     S "types do not match in conditional expression\n",
231 :     S " true branch: ", TY(#2 eTy1), S "\n",
232 :     S " false branch: ", TY(#2 eTy2)
233 :     ])
234 : jhr 3398 (* end case *))
235 : jhr 3396 | (_, ty') => err (cxt, [S "expected bool type, but found ", TY ty'])
236 :     (* end case *)
237 :     end
238 :     | PT.E_Range(e1, e2) => (case (check (env, cxt, e1), check (env, cxt, e2))
239 :     of ((e1', Ty.T_Int), (e2', Ty.T_Int)) => let
240 : jhr 3398 val resTy = Ty.T_Sequence(Ty.T_Int, NONE)
241 : jhr 3396 in
242 :     (AST.E_Apply(BV.range, [], [e1', e2'], resTy), resTy)
243 :     end
244 :     | ((_, Ty.T_Int), (_, ty2)) =>
245 :     err (cxt, [S "expected type 'int' on rhs of '..', but found ", TY ty2])
246 :     | ((_, ty1), (_, Ty.T_Int)) =>
247 :     err (cxt, [S "expected type 'int' on lhs of '..', but found ", TY ty1])
248 :     | ((_, ty1), (_, ty2)) => err (cxt, [
249 :     S "arguments of '..' must have type 'int', found ",
250 :     TY ty1, S " and ", TY ty2
251 :     ])
252 :     (* end case *))
253 :     | PT.E_OrElse(e1, e2) =>
254 :     checkCondOp (env, cxt, e1, "||", e2,
255 :     fn (e1', e2') => AST.E_Cond(e1', AST.E_Lit(L.Bool true), e2', Ty.T_Bool))
256 :     | PT.E_AndAlso(e1, e2) =>
257 :     checkCondOp (env, cxt, e1, "&&", e2,
258 :     fn (e1', e2') => AST.E_Cond(e1', e2', AST.E_Lit(L.Bool false), Ty.T_Bool))
259 :     | PT.E_BinOp(e1, rator, e2) => let
260 :     val (e1', ty1) = check (env, cxt, e1)
261 :     val (e2', ty2) = check (env, cxt, e2)
262 :     in
263 :     if Atom.same(rator, BasisNames.op_dot)
264 : jhr 3405 then chkInnerProduct (cxt, e1', ty1, e2', ty2)
265 : jhr 3396 else if Atom.same(rator, BasisNames.op_colon)
266 : jhr 3405 then chkColonProduct (cxt, e1', ty1, e2', ty2)
267 :     else (case Env.findFunc (env, rator)
268 : jhr 3396 of Env.PrimFun[rator] => let
269 : jhr 3405 val (tyArgs, Ty.T_Fun(domTy, rngTy)) = TU.instantiate(Var.typeOf rator)
270 : jhr 3396 in
271 : jhr 3402 case Unify.matchArgs(domTy, [e1', e2'], [ty1, ty2])
272 : jhr 3396 of SOME args => (AST.E_Apply(rator, tyArgs, args, rngTy), rngTy)
273 :     | NONE => err (cxt, [
274 :     S "type error for binary operator '", V rator, S "'\n",
275 :     S " expected: ", TYS domTy, S "\n",
276 :     S " but found: ", TYS[ty1, ty2]
277 :     ])
278 :     (* end case *)
279 :     end
280 :     | Env.PrimFun ovldList =>
281 :     resolveOverload (cxt, rator, [ty1, ty2], [e1', e2'], ovldList)
282 :     | _ => raise Fail "impossible"
283 :     (* end case *))
284 :     end
285 : jhr 3398 | PT.E_UnaryOp(rator, e) => let
286 : jhr 3405 val eTy = check(env, cxt, e)
287 : jhr 3398 in
288 : jhr 3405 case Env.findFunc (env, rator)
289 : jhr 3398 of Env.PrimFun[rator] => let
290 : jhr 3405 val (tyArgs, Ty.T_Fun([domTy], rngTy)) = TU.instantiate(Var.typeOf rator)
291 : jhr 3398 in
292 : jhr 3405 case Util.coerceType (domTy, eTy)
293 :     of SOME(e', ty) => (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)
294 : jhr 3398 | NONE => err (cxt, [
295 :     S "type error for unary operator \"", V rator, S "\"\n",
296 :     S " expected: ", TY domTy, S "\n",
297 : jhr 3405 S " but found: ", TY (#2 eTy)
298 : jhr 3398 ])
299 :     (* end case *)
300 :     end
301 : jhr 3405 | Env.PrimFun ovldList => resolveOverload (cxt, rator, [#2 eTy], [#1 eTy], ovldList)
302 : jhr 3398 | _ => raise Fail "impossible"
303 :     (* end case *)
304 :     end
305 :     | PT.E_Apply(e, args) => raise Fail "FIXME"
306 :     | PT.E_Subscript(e, indices) => (case (check(env, cxt, e), indices)
307 :     of ((e', Ty.T_Sequence(elemTy, _)), [SOME e2]) => raise Fail "FIXME"
308 :     | ((e', Ty.T_Tensor shape), _) => raise Fail "FIXME"
309 :     | ((_, ty), _) => err(cxt, [
310 :     S "expected sequence or tensor type for object of subscripting, but found",
311 :     TY ty
312 :     ])
313 :     (* end case *))
314 :     | PT.E_Select(e, field) => (case check(env, cxt, e)
315 : jhr 3405 of (e', Ty.T_Named strand) => (case Env.findStrand(env, strand)
316 :     of SOME sEnv => (case StrandEnv.findStateVar(sEnv, field)
317 :     of SOME x' => let
318 :     val ty = Var.monoTypeOf x'
319 :     in
320 :     (AST.E_Select(e', x'), ty)
321 :     end
322 :     | NONE => err(cxt, [
323 :     S "strand '", A strand,
324 :     S "' does not have state variable '", A field, S "'"
325 :     ])
326 :     (* end case *))
327 :     | NONE => err(cxt, [S "unknown strand '", A strand, S "'"])
328 : jhr 3398 (* end case *))
329 :     | (_, ty) => err (cxt, [
330 :     S "expected strand type, but found ", TY ty,
331 : jhr 3405 S " in selection of '", A field, S "'"
332 : jhr 3398 ])
333 :     (* end case *))
334 : jhr 3396 | PT.E_Real e => (case check (env, cxt, e)
335 :     of (e', Ty.T_Int) =>
336 :     (AST.E_Apply(BV.i2r, [], [e'], Ty.realTy), Ty.realTy)
337 :     | (_, ty) => err(cxt, [
338 :     S "argument of 'real' must have type 'int', but found ",
339 :     TY ty
340 :     ])
341 :     (* end case *))
342 :     | PT.E_Load nrrd => let
343 : jhr 3405 val (tyArgs, Ty.T_Fun(_, rngTy)) = TU.instantiate(Var.typeOf(BV.fn_image))
344 : jhr 3396 in
345 :     (AST.E_LoadNrrd(tyArgs, nrrd, rngTy), rngTy)
346 :     end
347 :     | PT.E_Image nrrd => let
348 : jhr 3405 val (tyArgs, Ty.T_Fun(_, rngTy)) = TU.instantiate(Var.typeOf(BV.fn_load))
349 : jhr 3396 in
350 :     (AST.E_LoadNrrd(tyArgs, nrrd, rngTy), rngTy)
351 :     end
352 : jhr 3405 | PT.E_Var x => (case E.findVar (env, x)
353 : jhr 3396 of SOME x' => (
354 :     markUsed (x', true);
355 :     (AST.E_Var x', Var.monoTypeOf x'))
356 :     | NONE => err(cxt, [S "undeclared variable ", A x])
357 :     (* end case *))
358 : jhr 3398 | PT.E_Kernel(kern, dim) => raise Fail "FIXME"
359 : jhr 3396 | PT.E_Lit lit => checkLit lit
360 :     | PT.E_Id d => let
361 :     val (tyArgs, Ty.T_Fun(_, rngTy)) =
362 : jhr 3405 TU.instantiate(Var.typeOf(BV.identity))
363 : jhr 3396 in
364 : jhr 3402 if Unify.equalType(Ty.T_Tensor(checkShape(cxt, [d,d])), rngTy)
365 : jhr 3396 then (AST.E_Apply(BV.identity, tyArgs, [], rngTy), rngTy)
366 :     else raise Fail "impossible"
367 :     end
368 :     | PT.E_Zero dd => let
369 :     val (tyArgs, Ty.T_Fun(_, rngTy)) =
370 : jhr 3405 TU.instantiate(Var.typeOf(BV.zero))
371 : jhr 3396 in
372 : jhr 3402 if Unify.equalType(Ty.T_Tensor(checkShape(cxt, dd)), rngTy)
373 : jhr 3396 then (AST.E_Apply(BV.zero, tyArgs, [], rngTy), rngTy)
374 :     else raise Fail "impossible"
375 :     end
376 :     | PT.E_NaN dd => let
377 :     val (tyArgs, Ty.T_Fun(_, rngTy)) =
378 : jhr 3405 TU.instantiate(Var.typeOf(BV.nan))
379 : jhr 3396 in
380 : jhr 3402 if Unify.equalType(Ty.T_Tensor(checkShape(cxt, dd)), rngTy)
381 : jhr 3396 then (AST.E_Apply(BV.nan, tyArgs, [], rngTy), rngTy)
382 :     else raise Fail "impossible"
383 :     end
384 : jhr 3398 | PT.E_Sequence exps => raise Fail "FIXME"
385 :     | PT.E_SeqComp comp => raise Fail "FIXME"
386 : jhr 3396 | PT.E_Cons args => let
387 :     (* Note that we are guaranteed that args is non-empty *)
388 :     val (args, tys) = checkList (env, cxt, args)
389 :     (* extract the first non-error type in tys *)
390 :     val ty = (case List.find (fn Ty.T_Error => false | _ => true) tys
391 :     of NONE => Ty.T_Error
392 :     | SOME ty => ty
393 :     (* end case *))
394 : jhr 3405 (* process the arguments checking that they all have the expected type *)
395 :     fun chkArgs (ty, shape) = let
396 :     val Ty.Shape dd = TU.pruneShape shape (* NOTE: this may fail if we allow user polymorphism *)
397 :     val resTy = Ty.T_Tensor(Ty.Shape(Ty.DimConst(List.length args) :: dd))
398 :     fun chkArgs (arg::args, argTy::tys, args') = (
399 :     case Util.coerceType(ty, (arg, argTy))
400 :     of SOME arg' => chkArgs (args, tys, arg'::args')
401 :     | NONE => (
402 :     TypeError.error(cxt, [
403 :     S "arguments of tensor construction must have same type"
404 :     ]);
405 :     chkArgs (args, tys, bogusExp::args'))
406 :     (* end case *))
407 :     | chkArgs ([], [], args') = (AST.E_Cons(List.rev args', resTy), resTy)
408 :     in
409 :     chkArgs (args, tys, [])
410 :     end
411 : jhr 3396 in
412 : jhr 3405 case TU.pruneHead ty
413 :     of Ty.T_Int => chkArgs(Ty.realTy, []) (* coerce integers to reals *)
414 :     | ty as Ty.T_Tensor shape => chkArgs(ty, shape)
415 : jhr 3396 | _ => err(cxt, [S "Invalid argument type for tensor construction"])
416 :     (* end case *)
417 :     end
418 :     | PT.E_Deprecate(msg, e) => (
419 :     warn (cxt, [S msg]);
420 : jhr 3402 check (env, cxt, e))
421 : jhr 3396 (* end case *))
422 :    
423 :     (* check a conditional operator (e.g., || or &&) *)
424 :     and checkCondOp (env, cxt, e1, rator, e2, mk) = (
425 :     case (check(env, cxt, e1), check(env, cxt, e2))
426 :     of ((e1', Ty.T_Bool), (e2', Ty.T_Bool)) => (mk(e1', e2'), Ty.T_Bool)
427 :     | ((_, Ty.T_Bool), (_, ty2)) =>
428 : jhr 3405 err (cxt, [S "expected type 'bool' on rhs of '", S rator, S "', but found ", TY ty2])
429 : jhr 3396 | ((_, ty1), (_, Ty.T_Bool)) =>
430 : jhr 3405 err (cxt, [S "expected type 'bool' on lhs of '", S rator, S "', but found ", TY ty1])
431 : jhr 3396 | ((_, ty1), (_, ty2)) => err (cxt, [
432 : jhr 3405 S "arguments of '", S rator, S "' must have type 'bool', but found ",
433 : jhr 3396 TY ty1, S " and ", TY ty2
434 :     ])
435 :     (* end case *))
436 :    
437 :     (* typecheck a list of expressions returning a list of AST expressions and a list
438 :     * of the types of the expressions.
439 :     *)
440 :     and checkList (env, cxt, exprs) = let
441 :     fun chk (e, (es, tys)) = let
442 : jhr 3402 val (e, ty) = check (env, cxt, e)
443 : jhr 3396 in
444 :     (e::es, ty::tys)
445 :     end
446 :     in
447 :     List.foldr chk ([], []) exprs
448 :     end
449 :    
450 :     end

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