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

SCM Repository

[diderot] Diff of /trunk/src/compiler/typechecker/typechecker.sml
ViewVC logotype

Diff of /trunk/src/compiler/typechecker/typechecker.sml

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

trunk/src/typechecker/typechecker.sml revision 71, Sat May 22 22:16:04 2010 UTC trunk/src/compiler/typechecker/typechecker.sml revision 475, Thu Nov 4 18:57:11 2010 UTC
# Line 1  Line 1 
1  (* typechecker.sml  (* typechecker.sml
2   *   *
3   * COPYRIGHT (c) 2010 The Diderot Project (http://diderot.cs.uchicago.edu)   * COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4   * All rights reserved.   * All rights reserved.
5     *
6   *)   *)
7    
8  structure Typechecker : sig  structure Typechecker : sig
9    
10      val check : ParseTree.program -> AST.program      exception Error
11    
12        val check : Error.err_stream -> ParseTree.program -> AST.program
13    
14    end = struct    end = struct
15    
16      structure PT = ParseTree      structure PT = ParseTree
17      structure Ty = Types      structure Ty = Types
18        structure TU = TypeUtil
19        structure U = Util
20    
21        datatype scope = GlobalScope | ActorScope | MethodScope | InitScope
22    
23        type env = {scope : scope, env : Env.env}
24    
25        fun actorScope {scope, env} = {scope=ActorScope, env=env}
26        fun methodScope {scope, env} = {scope=MethodScope, env=env}
27        fun initScope {scope, env} = {scope=InitScope, env=env}
28    
29        fun inActor {scope=ActorScope, env} = true
30          | inActor {scope=MethodScope, ...} = true
31          | inActor _ = false
32    
33        fun insertLocal ({scope, env}, x, x') = {scope=scope, env=Env.insertLocal(env, x, x')}
34        fun insertGlobal ({scope, env}, x, x') = {scope=scope, env=Env.insertGlobal(env, x, x')}
35    
36        exception Error
37    
38        type context = Error.err_stream * Error.span
39    
40        fun withContext ((errStrm, _), {span, tree}) =
41              ((errStrm, span), tree)
42        fun withEnvAndContext (env, (errStrm, _), {span, tree}) =
43              (env, (errStrm, span), tree)
44    
45        fun error ((errStrm, span), msg) = (
46              Error.errorAt(errStrm, span, msg);
47              raise Error)
48    
49        datatype token
50          = S of string | A of Atom.atom
51          | V of AST.var | TY of Types.ty | TYS of Types.ty list
52    
53        fun err (cxt, toks) = let
54              fun tok2str (S s) = s
55                | tok2str (A a) = Atom.toString a
56                | tok2str (V x) = Var.nameOf x
57                | tok2str (TY ty) = TU.toString ty
58                | tok2str (TYS []) = "()"
59                | tok2str (TYS[ty]) = TU.toString ty
60                | tok2str (TYS tys) = String.concat[
61                      "(", String.concatWith " * " (List.map TU.toString tys), ")"
62                    ]
63              in
64                error(cxt, List.map tok2str toks)
65              end
66    
67        val realZero = AST.E_Lit(Literal.Float(FloatLit.zero true))
68    
69    (* check a differentiation level, which muse be >= 0 *)    (* check a differentiation level, which muse be >= 0 *)
70      fun checkDiff (cxt, k) =      fun checkDiff (cxt, k) =
71            if (k < 0)            if (k < 0)
72              then raise Fail "differentiation must be >= 0"              then raise Fail "differentiation must be >= 0"
73              else Ty.NatConst(IntInf.toInt k)              else Ty.DiffConst(IntInf.toInt k)
74    
75    (* check a dimension, which must be 2 or 3 *)    (* check a dimension, which must be 2 or 3 *)
76      fun checkDim (cxt, d) =      fun checkDim (cxt, d) =
77            if (d < 2) orelse (3 < d)            if (d <= 0)
78              then raise Fail "invalid dimension; must be 2 or 3"              then raise Fail "invalid dimension; must be > 0"
79              else Ty.NatConst(IntInf.toInt d)              else Ty.DimConst(IntInf.toInt d)
80    
81    (* check a shape *)    (* check a shape *)
82      fun checkShape (cxt, shape) = let      fun checkShape (cxt, shape) = let
83            fun chkDim d = if (d < 1)            fun chkDim d = if (d < 1)
84                  then raise Fail "invalid shape dimension; must be >= 1"                  then raise Fail "invalid shape dimension; must be >= 1"
85                  else Ty.NatConst(IntInf.toInt d)                  else Ty.DimConst(IntInf.toInt d)
86            in            in
87              Ty.Shape(List.map chkDim shape)              Ty.Shape(List.map chkDim shape)
88            end            end
89    
90    (* check the well-formedness of a type and translate it to an AST type *)    (* check the well-formedness of a type and translate it to an AST type *)
91      fun checkTy (cxt, ty) = (case ty      fun checkTy (cxt, ty) = (case ty
92             of PT.T_Mark m => checkTy(#span m, #tree m)             of PT.T_Mark m => checkTy(withContext(cxt, m))
93              | PT.T_Bool => Ty.T_Bool              | PT.T_Bool => Ty.T_Bool
94              | PT.T_Int => Ty.T_Int              | PT.T_Int => Ty.T_Int
95              | PT.T_Real => Ty.realTy              | PT.T_Real => Ty.realTy
# Line 54  Line 107 
107                    dim = checkDim (cxt, dim),                    dim = checkDim (cxt, dim),
108                    shape = checkShape (cxt, shape)                    shape = checkShape (cxt, shape)
109                  }                  }
110              | PT.T_Array(ty, dims) => raise Fail "Array type"              | PT.T_Array(ty, dims) => raise Fail "Array type not supported"
111            (* end case *))            (* end case *))
112    
113      fun checkLit lit = (case lit      fun checkLit lit = (case lit
# Line 64  Line 117 
117              | (Literal.Bool _) => (AST.E_Lit lit, Ty.T_Bool)              | (Literal.Bool _) => (AST.E_Lit lit, Ty.T_Bool)
118            (* end case *))            (* end case *))
119    
120  (*    (* resolve overloading: we use a simple scheme that selects the first operator in the
121       * list that matches the argument types.
122       *)
123        fun resolveOverload (cxt, rator, argTys, args, candidates) = let
124              fun tryCandidates [] = err(cxt, [
125                      S "unable to resolve overloaded operator \"", A rator, S "\"\n",
126                      S "  argument type is: ", TYS argTys, S "\n"
127                    ])
128                | tryCandidates (x::xs) = let
129                    val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf x)
130                    in
131                      if U.tryMatchTypes(domTy, argTys)
132                        then (AST.E_Apply(x, tyArgs, args, rngTy), rngTy)
133                        else tryCandidates xs
134                    end
135              in
136                tryCandidates candidates
137              end
138    
139    (* typecheck an expression and translate it to AST *)    (* typecheck an expression and translate it to AST *)
140      fun checkExpr (env, cxt, e) = (case e      fun checkExpr (env : env, cxt, e) = (case e
141             of PT.E_Mark m => checkExpr (env, #span m, #tree m)             of PT.E_Mark m => checkExpr (withEnvAndContext (env, cxt, m))
142              | PT.E_Var x => (case Env.findVar (env, x)              | PT.E_Var x => (case Env.findVar (#env env, x)
143                   of SOME x' => (case Var.typeOf x'                   of SOME x' => (AST.E_Var x', Var.monoTypeOf x')
144                         of ([], ty) => (E_Var x', ty)                    | NONE => err(cxt, [S "undeclared variable ", A x])
                         | (tvs, ty) => raise Fail "unimplemented"  
                       (* end case *))  
                   | NONE => raise Fail "undefined variable"  
145                  (* end case *))                  (* end case *))
146              | PT.E_Lit lit => checkLit lit              | PT.E_Lit lit => checkLit lit
147              | PT.E_BinOp of expr * var * expr              | PT.E_OrElse(e1, e2) => let
148              | PT.E_UnaryOp of var * expr                  val (e1', ty1) = checkExpr(env, cxt, e1)
149              | PT.E_Tuple of expr list                  val (e2', ty2) = checkExpr(env, cxt, e2)
150              | PT.E_Apply of var * expr list                  in
151              | PT.E_Cons of ty * expr list                    case (ty1, ty2)
152              | PT.E_Diff of expr                     of (Ty.T_Bool, Ty.T_Bool) =>
153              | PT.E_Norm of expr                          (AST.E_Cond(e1', AST.E_Lit(Literal.Bool true), e2', Ty.T_Bool), Ty.T_Bool)
154                        | _ => err (cxt, [S "arguments to \"||\" must have bool type"])
155                      (* end case *)
156                    end
157                | PT.E_AndAlso(e1, e2) => let
158                    val (e1', ty1) = checkExpr(env, cxt, e1)
159                    val (e2', ty2) = checkExpr(env, cxt, e2)
160                    in
161                      case (ty1, ty2)
162                       of (Ty.T_Bool, Ty.T_Bool) =>
163                            (AST.E_Cond(e1', e2', AST.E_Lit(Literal.Bool false), Ty.T_Bool), Ty.T_Bool)
164                        | _ => err (cxt, [S "arguments to \"&&\" must have bool type"])
165                      (* end case *)
166                    end
167                | PT.E_Cond(e1, cond, e2) => let
168                    val (e1', ty1) = checkExpr(env, cxt, e1)
169                    val (e2', ty2) = checkExpr(env, cxt, e2)
170                    in
171                      case checkExpr(env, cxt, cond)
172                       of (cond', Ty.T_Bool) =>
173                            if U.matchType(ty1, ty2)
174                              then (AST.E_Cond(cond', e1', e2', ty1), ty1)
175                              else err (cxt, [
176                                  S "type do not match in conditional expression\n",
177                                  S "  true branch:  ", TY ty1,
178                                  S "  false branch: ", TY ty2
179                                ])
180                        | (_, ty') => err (cxt, [S "expected bool type, but found ", TY ty'])
181                      (* end case *)
182                    end
183                | PT.E_BinOp(e1, rator, e2) => let
184                    val (e1', ty1) = checkExpr(env, cxt, e1)
185                    val (e2', ty2) = checkExpr(env, cxt, e2)
186                    in
187                      case Basis.findOp rator
188                       of [rator] => let
189                            val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf rator)
190                            in
191                              if U.matchTypes(domTy, [ty1, ty2])
192                                then (AST.E_Apply(rator, tyArgs, [e1', e2'], rngTy), rngTy)
193                                else err (cxt, [
194                                    S "type error for binary operator \"", V rator, S "\"\n",
195                                    S "  expected:  ", TYS domTy, S "\n",
196                                    S "  but found: ", TYS[ty1, ty2], S "\n"
197                                  ])
198                            end
199                        | ovldList => resolveOverload (cxt, rator, [ty1, ty2], [e1', e2'], ovldList)
200                      (* end case *)
201                    end
202                | PT.E_UnaryOp(rator, e) => let
203                    val (e', ty) = checkExpr(env, cxt, e)
204                    in
205                      case Basis.findOp rator
206                       of [rator] => let
207                            val (tyArgs, Ty.T_Fun([domTy], rngTy)) = U.instantiate(Var.typeOf rator)
208                            in
209                              if U.matchType(domTy, ty)
210                                then (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)
211                                else err (cxt, [
212                                    S "type error for unary operator \"", V rator, S "\"\n",
213                                    S "  expected:  ", TY domTy, S "\n",
214                                    S "  but found: ", TY ty, S "\n"
215                                  ])
216                            end
217                        | ovldList => resolveOverload (cxt, rator, [ty], [e'], ovldList)
218                      (* end case *)
219                    end
220                | PT.E_Slice(e, indices) => let
221                    val (e', ty) = checkExpr (env, cxt, e)
222                    fun checkIndex NONE = NONE
223                      | checkIndex (SOME e) = let
224                          val (e', ty) = checkExpr (env, cxt, e)
225                          in
226                            if U.matchType(ty, Ty.T_Int)
227                              then (SOME e')
228                              else err (cxt, [
229                                  S "type error in index expression\n",
230                                  S "  expected int, but found: ", TY ty, S "\n"
231                                ])
232                          end
233                    val indices' = List.map checkIndex indices
234                    val order = List.length indices'
235                    val expectedTy = TU.mkTensorTy order
236                    val resultTy = TU.slice(expectedTy, List.map Option.isSome indices')
237                    in
238                      if U.matchType(ty, expectedTy)
239                        then ()
240                        else err (cxt, [
241                            S "type error in slice operation\n",
242                            S "  expected:  ", S(Int.toString order), S "-order tensor\n",
243                            S "  but found: ", TY ty, S "\n"
244                          ]);
245                      (AST.E_Slice(e', indices', resultTy), resultTy)
246                    end
247                | PT.E_Tuple args => let
248                    val (args, tys) = checkExprList (env, cxt, args)
249                    in
250                      raise Fail "E_Tuple not yet implemented"
251                    end
252                | PT.E_Apply(f, args) => let
253                    val (args, tys) = checkExprList (env, cxt, args)
254                    in
255                      case Env.findFunc (#env env, f)
256                       of SOME f =>
257                            if (inActor env) andalso (Basis.isRestricted f)
258                              then err(cxt, [S "use of restricted operation ", V f, S " in actor body"])
259                              else (case Util.instantiate(Var.typeOf f)
260                                 of (tyArgs, Ty.T_Fun(domTy, rngTy)) =>
261                                      if U.matchTypes(domTy, tys)
262                                        then (AST.E_Apply(f, tyArgs, args, rngTy), rngTy)
263                                        else err(cxt, [
264                                            S "type error in application of ", V f, S "\n",
265                                            S "  expected:  ", TYS domTy, S "\n",
266                                            S "  but found: ", TYS tys, S "\n"
267                                          ])
268                                  | _ => err(cxt, [S "application of non-function ", V f])
269                                (* end case *))
270                        | NONE => err(cxt, [S "unknown function ", A f])
271                      (* end case *)
272                    end
273                | PT.E_Cons args => let
274                    val (args, ty::tys) = checkExprList (env, cxt, args)
275                    in
276                      case TU.pruneHead ty
277                       of ty as Ty.T_Tensor shape => let
278                            val Ty.Shape dd = TU.pruneShape shape (* NOTE: this may fail if we allow user polymorphism *)
279                            fun chkTy ty' = U.matchType(ty, ty')
280                            val resTy = Ty.T_Tensor(Ty.Shape(Ty.DimConst(List.length args) :: dd))
281                            in
282                              if List.all chkTy tys
283                                then (AST.E_Cons args, resTy)
284                                else err(cxt, [S "arguments of tensor construction must have same type"])
285                            end
286                        | _ => err(cxt, [S "Invalid argument type for tensor construction"])
287                      (* end case *)
288                    end
289                | PT.E_Real e => (case checkExpr (env, cxt, e)
290                     of (e', Ty.T_Int) =>
291                          (AST.E_Apply(BasisVars.i2r, [], [e'], Ty.realTy), Ty.realTy)
292                      | _ => err(cxt, [S "argument of real conversion must be int"])
293                    (* end case *))
294              (* end case *))
295    
296      (* typecheck a list of expressions returning a list of AST expressions and a list
297       * of types of the expressions.
298       *)
299        and checkExprList (env, cxt, exprs) = let
300              fun chk (e, (es, tys)) = let
301                    val (e, ty) = checkExpr (env, cxt, e)
302                    in
303                      (e::es, ty::tys)
304                    end
305              in
306                List.foldr chk ([], []) exprs
307              end
308    
309        fun checkVarDecl (env, cxt, kind, d) = (case d
310               of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)
311                | PT.VD_Decl(ty, x, e) => let
312                    val ty = checkTy (cxt, ty)
313                    val x' = Var.new (x, kind, ty)
314                    val (e', ty') = checkExpr (env, cxt, e)
315                    in
316    (* FIXME: this check is not flexible enough; should allow lhs type to support
317     * fewer levels of differentiation than rhs provides.
318     *)
319                      if U.matchType(ty, ty')
320                        then (x, x', e')
321                        else err(cxt, [
322                            S "type of variable ", A x,
323                            S " does not match type of initializer\n",
324                            S "  expected: ", TY ty, S "\n",
325                            S "  but found: ", TY ty', S "\n"
326                          ])
327                    end
328            (* end case *))            (* end case *))
329    
330    (* typecheck a statement and translate it to AST *)    (* typecheck a statement and translate it to AST *)
331      fun checkStmt (env, cxt, s) = (case s      fun checkStmt (env, cxt, s) = (case s
332             of PT.S_Mark m => checkStmt (env, #span m, #tree m)             of PT.S_Mark m => checkStmt (withEnvAndContext (env, cxt, m))
333              | PT.S_Block of stmt list              | PT.S_Block stms => let
334              | PT.S_Decl of var_decl                  fun chk (_, [], stms) = AST.S_Block(List.rev stms)
335              | PT.S_IfThen of expr * stmt                    | chk (env, s::ss, stms) = let
336              | PT.S_IfThenElse of expr * stmt * stmt                        val (s', env') = checkStmt (env, cxt, s)
337              | PT.S_Assign of var * expr                        in
338              | PT.S_New of var * expr list                          chk (env', ss, s'::stms)
339              | PT.S_Die                        end
340              | PT.S_Stabilize                  in
341                      (chk (env, stms, []), env)
342                    end
343                | PT.S_Decl vd => let
344                    val (x, x', e) = checkVarDecl (methodScope env, cxt, Var.LocalVar, vd)
345                    in
346                      (AST.S_Decl(AST.VD_Decl(x', e)), insertLocal(env, x, x'))
347                    end
348                | PT.S_IfThen(e, s) => let
349                    val (e', ty) = checkExpr (env, cxt, e)
350                    val (s', _) = checkStmt (env, cxt, s)
351                    in
352                    (* check that condition has bool type *)
353                      case ty
354                       of Ty.T_Bool => ()
355                        | _ => err(cxt, [S "condition not boolean type"])
356                      (* end case *);
357                      (AST.S_IfThenElse(e', s', AST.S_Block[]), env)
358                    end
359                | PT.S_IfThenElse(e, s1, s2) => let
360                    val (e', ty) = checkExpr (env, cxt, e)
361                    val (s1', _) = checkStmt (env, cxt, s1)
362                    val (s2', _) = checkStmt (env, cxt, s2)
363                    in
364                    (* check that condition has bool type *)
365                      case ty
366                       of Ty.T_Bool => ()
367                        | _ => err(cxt, [S "condition not boolean type"])
368                      (* end case *);
369                      (AST.S_IfThenElse(e', s1', s2'), env)
370                    end
371                | PT.S_Assign(x, e) => (case Env.findVar (#env env, x)
372                     of NONE => err(cxt, [
373                            S "undefined variable ", A x
374                          ])
375                      | SOME x' => let
376    (* FIXME: check for polymorphic variables *)
377                          val ([], ty) = Var.typeOf x'
378                          val (e', ty') = checkExpr (env, cxt, e)
379                          in
380                            if U.matchType(ty, ty')
381                              then (x, x', e')
382                              else err(cxt, [
383                                  S "type of assigned variable ", A x,
384                                  S " does not match type of rhs\n",
385                                  S "  expected: ", TY ty, S "\n",
386                                  S "  but found: ", TY ty', S "\n"
387                                ]);
388                          (* check that x' is mutable *)
389                            case Var.kindOf x'
390                             of Var.ActorStateVar => ()
391                              | Var.ActorOutputVar => ()
392                              | Var.LocalVar => ()
393                              | _ => err(cxt, [
394                                    S "assignment to immutable variable ", A x
395                                  ])
396                            (* end case *);
397                            (AST.S_Assign(x', e'), env)
398                          end
399                    (* end case *))
400                | PT.S_New(actor, args) => let
401                    val argsAndTys' = List.map (fn e => checkExpr(env, cxt, e)) args
402                    val (args', tys') = ListPair.unzip argsAndTys'
403                    in
404                      case #scope env
405                       of MethodScope => ()
406                        | InitScope => ()
407                        | _ => err(cxt, [S "invalid scope for new actor"])
408                      (* end case *);
409    (* FIXME: check that actor is defined and has the argument types match *)
410                      (AST.S_New(actor, args'), env)
411                    end
412                | PT.S_Die => (
413                    case #scope env
414                     of MethodScope => ()
415                      | _ => err(cxt, [S "\"die\" statment outside of method"])
416                    (* end case *);
417                    (AST.S_Die, env))
418                | PT.S_Stabilize => (
419                    case #scope env
420                     of MethodScope => ()
421                      | _ => err(cxt, [S "\"stabilize\" statment outside of method"])
422                    (* end case *);
423                    (AST.S_Stabilize, env))
424            (* end case *))            (* end case *))
425    
426        fun checkParams (env, cxt, params) = let
427              fun chkParam (env, cxt, param) = (case param
428                     of PT.P_Mark m => chkParam (withEnvAndContext (env, cxt, m))
429                      | PT.P_Param(ty, x) => let
430                          val x' = Var.new(x, AST.ActorParam, checkTy (cxt, ty))
431                          in
432                            (x', insertLocal(env, x, x'))
433                          end
434                    (* end case *))
435              fun chk (param, (xs, env)) = let
436                    val (x, env) = chkParam (env, cxt, param)
437                    in
438                      (x::xs, env)
439                    end
440              in
441    (* FIXME: need to check for multiple occurences of the same parameter name! *)
442                List.foldr chk ([], env) params
443              end
444    
445        fun checkMethod (env, cxt, meth) = (case meth
446               of PT.M_Mark m => checkMethod (withEnvAndContext (env, cxt, m))
447                | PT.M_Method(name, body) => let
448                    val (body, _) = checkStmt(methodScope env, cxt, body)
449                    in
450                      AST.M_Method(name, body)
451                    end
452              (* end case *))
453    
454        fun checkActor (env, cxt, {name, params, state, methods}) = let
455            (* check the actor parameters *)
456              val (params, env) = checkParams (env, cxt, params)
457            (* check the actor state variable definitions *)
458              val (vds, env) = let
459                    fun checkStateVar ((isOut, vd), (vds, env)) = let
460                          val kind = if isOut then AST.ActorOutputVar else AST.ActorStateVar
461                          val (x, x', e') = checkVarDecl (env, cxt, kind, vd)
462                          in
463                          (* check that output variables have value types *)
464                            if isOut andalso not(TU.isValueType(Var.monoTypeOf x'))
465                              then err(cxt, [
466                                  S "output variable ", V x', S " has non-value type ",
467                                  TY(Var.monoTypeOf x')
468                                ])
469                              else ();
470                            (AST.VD_Decl(x', e')::vds, insertLocal(env, x, x'))
471                          end
472                    val (vds, env) = List.foldl checkStateVar ([], env) state
473                    in
474                      (List.rev vds, env)
475                    end
476            (* check the actor methods *)
477              val methods = List.map (fn m => checkMethod (env, cxt, m)) methods
478              in
479                AST.D_Actor{name = name, params = params, state = vds, methods = methods}
480              end
481    
482        fun checkCreate (env, cxt, PT.C_Mark m) = checkCreate (withEnvAndContext (env, cxt, m))
483          | checkCreate (env, cxt, PT.C_Create(actor, args)) = let
484              val (args, tys) = checkExprList (env, cxt, args)
485              in
486    (* FIXME: check against actor definition *)
487                AST.C_Create(actor, args)
488              end
489    
490        fun checkIter (env, cxt, PT.I_Mark m) = checkIter (withEnvAndContext (env, cxt, m))
491          | checkIter (env, cxt, PT.I_Range(x, e1, e2)) = let
492              val (e1', ty1) = checkExpr (env, cxt, e1)
493              val (e2', ty2) = checkExpr (env, cxt, e2)
494              val x' = Var.new(x, Var.LocalVar, Ty.T_Int)
495              val env' = insertLocal(env, x, x')
496              in
497                case (ty1, ty2)
498                 of (Ty.T_Int, Ty.T_Int) => (AST.I_Range(x', e1', e2'), env')
499                  | _ => err(cxt, [
500                        S "range expressions must have integer type\n",
501                        S "  but found: ", TY ty1, S " .. ", TY ty2, S "\n"
502                      ])
503                (* end case *)
504              end
505    
506        fun checkIters (env, cxt, iters) = let
507              fun chk (env, [], iters) = (List.rev iters, env)
508                | chk (env, iter::rest, iters) = let
509                    val (iter, env) = checkIter (env, cxt, iter)
510                    in
511                      chk (env, rest, iter::iters)
512                    end
513              in
514                chk (env, iters, [])
515              end
516    
517      fun checkDecl (env, cxt, d) = (case d      fun checkDecl (env, cxt, d) = (case d
518             of PT.D_Mark m => checkDecl (env, #span m, #tree m)             of PT.D_Mark m => checkDecl (withEnvAndContext (env, cxt, m))
519              | PT.D_Input(ty, x, optExp) = let              | PT.D_Input(ty, x, optExp) => let
520                  val ty = checkTy(cxt, ty)                  val ty = checkTy(cxt, ty)
521                  val x' = Var.new(x, Var.InputVar, ty)                  val x' = Var.new(x, Var.InputVar, ty)
522                  val dcl = (case optExp                  val dcl = (case optExp
# Line 108  Line 524 
524                          | SOME e => let                          | SOME e => let
525                              val (e', ty') = checkExpr (env, cxt, e)                              val (e', ty') = checkExpr (env, cxt, e)
526                              in                              in
527  (* FIXME: check types *)                                if U.matchType (ty, ty')
528                                AST.D_Input(x', SOME e')                                  then AST.D_Input(x', SOME e')
529                                    else err(cxt, [
530                                        S "definition of ", V x', S " has wrong type\n",
531                                        S "  expected:  ", TY ty, S "\n",
532                                        S "  but found: ", TY ty', S "\n"
533                                      ])
534                              end                              end
535                        (* end case *))                        (* end case *))
536                  in                  in
537                    (dcl, Env.insertGlobal(env, x, x'))                  (* check that input variables have value types *)
538                      if not(TU.isValueType ty)
539                        then err(cxt, [S "input variable ", V x', S " has non-value type ", TY ty])
540                        else ();
541                      (dcl, insertGlobal(env, x, x'))
542                    end
543                | PT.D_Var vd => let
544                    val (x, x', e') = checkVarDecl (env, cxt, Var.GlobalVar, vd)
545                    in
546                      (AST.D_Var(AST.VD_Decl(x', e')), insertGlobal(env, x, x'))
547                    end
548                | PT.D_Actor arg => (checkActor(actorScope env, cxt, arg), env)
549                | PT.D_InitialArray(create, iterators) => let
550                    val env = initScope env
551                    val (iterators, env') = checkIters (env, cxt, iterators)
552                    val create = checkCreate (env', cxt, create)
553                    in
554                      (AST.D_InitialArray(create, iterators), env)
555                    end
556                | PT.D_InitialCollection(create, iterators) => let
557                    val env = initScope env
558                    val (iterators, env') = checkIters (env, cxt, iterators)
559                    val create = checkCreate (env', cxt, create)
560                    in
561                      (AST.D_InitialCollection(create, iterators), env)
562                  end                  end
             | PT.D_Var of var_decl                      (* global variable decl *)  
             | PT.D_Actor of {                           (* actor decl *)  
                   name : var,  
                   params : param list,  
                   state : var_decl list,  
                   methods : method list  
                 }  
             | PT.D_InitialArray of create * iter list  
             | PT.D_InitialCollection of create * iter list  
563            (* end case *))            (* end case *))
 *)  
564    
565      fun check (PT.Program dcls) = AST.Program[]      fun check errStrm (PT.Program{span, tree}) = let
566              val cxt = (errStrm, span)
567              fun chk (env, [], dcls') = AST.Program(List.rev dcls')
568                | chk (env, dcl::dcls, dcls') = let
569                    val (dcl', env) = checkDecl (env, cxt, dcl)
570                    in
571                      chk (env, dcls, dcl'::dcls')
572                    end
573              in
574                chk ({scope=GlobalScope, env=Basis.env}, tree, [])
575              end
576    
577    end    end

Legend:
Removed from v.71  
changed lines
  Added in v.475

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