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 86, Wed May 26 22:23:17 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        exception Error
11    
12      val check : Error.err_stream -> ParseTree.program -> AST.program      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      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      type context = Error.err_stream * Error.span
39    
40      fun withContext ((errStrm, _), {span, tree}) =      fun withContext ((errStrm, _), {span, tree}) =
# Line 21  Line 42 
42      fun withEnvAndContext (env, (errStrm, _), {span, tree}) =      fun withEnvAndContext (env, (errStrm, _), {span, tree}) =
43            (env, (errStrm, span), tree)            (env, (errStrm, span), tree)
44    
45      fun error ((errStrm, span), msg) = Error.errorAt(errStrm, span, msg)      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))      val realZero = AST.E_Lit(Literal.Float(FloatLit.zero true))
68    
# Line 66  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 79  Line 120 
120    (* resolve overloading: we use a simple scheme that selects the first operator in the    (* resolve overloading: we use a simple scheme that selects the first operator in the
121     * list that matches the argument types.     * list that matches the argument types.
122     *)     *)
123      fun resolveOverload (rator, argTys, args, candidates) = let      fun resolveOverload (cxt, rator, argTys, args, candidates) = let
124            fun tryCandidates [] = raise Fail(concat[            fun tryCandidates [] = err(cxt, [
125                    "unable to resolve overloaded operator \"", Atom.toString rator, "\""                    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              | tryCandidates (x::xs) = let
129                  val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf x)                  val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf x)
# Line 95  Line 137 
137            end            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 (withEnvAndContext (env, cxt, 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' => let                   of SOME x' => (AST.E_Var x', Var.monoTypeOf x')
144                        val (args, ty) = Util.instantiate(Var.typeOf x')                    | NONE => err(cxt, [S "undeclared variable ", A x])
                       in  
                         (AST.E_Var(x', args, ty), ty)  
                       end  
                   | 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_OrElse(e1, e2) => let              | PT.E_OrElse(e1, e2) => let
# Line 112  Line 150 
150                  in                  in
151                    case (ty1, ty2)                    case (ty1, ty2)
152                     of (Ty.T_Bool, Ty.T_Bool) =>                     of (Ty.T_Bool, Ty.T_Bool) =>
153                          (AST.E_Cond(e1', AST.E_Lit(Literal.Bool true), e2'), Ty.T_Bool)                          (AST.E_Cond(e1', AST.E_Lit(Literal.Bool true), e2', Ty.T_Bool), Ty.T_Bool)
154                      | _ => raise Fail "arguments to \"||\" must have bool type"                      | _ => err (cxt, [S "arguments to \"||\" must have bool type"])
155                    (* end case *)                    (* end case *)
156                  end                  end
157              | PT.E_AndAlso(e1, e2) => let              | PT.E_AndAlso(e1, e2) => let
# Line 122  Line 160 
160                  in                  in
161                    case (ty1, ty2)                    case (ty1, ty2)
162                     of (Ty.T_Bool, Ty.T_Bool) =>                     of (Ty.T_Bool, Ty.T_Bool) =>
163                          (AST.E_Cond(e1', e2', AST.E_Lit(Literal.Bool false)), Ty.T_Bool)                          (AST.E_Cond(e1', e2', AST.E_Lit(Literal.Bool false), Ty.T_Bool), Ty.T_Bool)
164                      | _ => raise Fail "arguments to \"||\" must have bool type"                      | _ => 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 *)                    (* end case *)
182                  end                  end
183              | PT.E_BinOp(e1, rator, e2) => let              | PT.E_BinOp(e1, rator, e2) => let
# Line 136  Line 190 
190                          in                          in
191                            if U.matchTypes(domTy, [ty1, ty2])                            if U.matchTypes(domTy, [ty1, ty2])
192                              then (AST.E_Apply(rator, tyArgs, [e1', e2'], rngTy), rngTy)                              then (AST.E_Apply(rator, tyArgs, [e1', e2'], rngTy), rngTy)
193                              else raise Fail(concat[                              else err (cxt, [
194                                  "type error for binary operator \"", Var.nameOf rator, "\""                                  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                          end
199                      | ovldList => resolveOverload (rator, [ty1, ty2], [e1', e2'], ovldList)                      | ovldList => resolveOverload (cxt, rator, [ty1, ty2], [e1', e2'], ovldList)
200                    (* end case *)                    (* end case *)
201                  end                  end
202              | PT.E_UnaryOp(rator, e) => let              | PT.E_UnaryOp(rator, e) => let
# Line 148  Line 204 
204                  in                  in
205                    case Basis.findOp rator                    case Basis.findOp rator
206                     of [rator] => let                     of [rator] => let
207                          val (tyArgs, Ty.T_Fun([domTy], rngTy)) = Util.instantiate(Var.typeOf rator)                          val (tyArgs, Ty.T_Fun([domTy], rngTy)) = U.instantiate(Var.typeOf rator)
208                          in                          in
209                            if U.matchType(domTy, ty)                            if U.matchType(domTy, ty)
210                              then (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)                              then (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)
211                              else raise Fail(concat[                              else err (cxt, [
212                                  "type error for unary operator \"", Var.nameOf rator, "\""                                  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                          end
217                      | ovldList => resolveOverload (rator, [ty], [e'], ovldList)                      | ovldList => resolveOverload (cxt, rator, [ty], [e'], ovldList)
218                    (* end case *)                    (* end case *)
219                  end                  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              | PT.E_Tuple args => let
248                  val (args, tys) = checkExprList (env, cxt, args)                  val (args, tys) = checkExprList (env, cxt, args)
249                  in                  in
# Line 167  Line 252 
252              | PT.E_Apply(f, args) => let              | PT.E_Apply(f, args) => let
253                  val (args, tys) = checkExprList (env, cxt, args)                  val (args, tys) = checkExprList (env, cxt, args)
254                  in                  in
255                    case Env.findVar (env, f)                    case Env.findFunc (#env env, f)
256                     of SOME f => (case Util.instantiate(Var.typeOf f)                     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)) =>                           of (tyArgs, Ty.T_Fun(domTy, rngTy)) =>
261                                if U.matchTypes(domTy, tys)                                if U.matchTypes(domTy, tys)
262                                  then (AST.E_Apply(f, tyArgs, args, rngTy), rngTy)                                  then (AST.E_Apply(f, tyArgs, args, rngTy), rngTy)
263                                  else raise Fail "type error for application"                                      else err(cxt, [
264                            | _ => raise Fail "application of non-function"                                          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 *))                          (* end case *))
270                      | NONE => raise Fail "unknown function"                      | NONE => err(cxt, [S "unknown function ", A f])
271                    (* end case *)                    (* end case *)
272                  end                  end
273              | PT.E_Cons args => let              | PT.E_Cons args => let
274                  val (args, ty::tys) = checkExprList (env, cxt, args)                  val (args, ty::tys) = checkExprList (env, cxt, args)
275                  in                  in
276                    case Util.prune ty                    case TU.pruneHead ty
277                     of Ty.T_Tensor shape => let                     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')                          fun chkTy ty' = U.matchType(ty, ty')
280                          val resTy = Ty.T_Tensor(Ty.shapeExt(shape, Ty.DimConst(List.length args)))                          val resTy = Ty.T_Tensor(Ty.Shape(Ty.DimConst(List.length args) :: dd))
281                          in                          in
282                            if List.all chkTy tys                            if List.all chkTy tys
283                              then (AST.E_Cons args, resTy)                              then (AST.E_Cons args, resTy)
284                              else raise Fail "arguments of tensor construction must have same type"                              else err(cxt, [S "arguments of tensor construction must have same type"])
285                          end                          end
286                      | _ => raise Fail "Invalid argument type for tensor construction"                      | _ => err(cxt, [S "Invalid argument type for tensor construction"])
287                    (* end case *)                    (* end case *)
288                  end                  end
289              | PT.E_Real e => (case checkExpr (env, cxt, e)              | PT.E_Real e => (case checkExpr (env, cxt, e)
290                   of (e', Ty.T_Int) =>                   of (e', Ty.T_Int) =>
291                        (AST.E_Apply(BasisVars.i2r, [], [e'], Ty.realTy), Ty.realTy)                        (AST.E_Apply(BasisVars.i2r, [], [e'], Ty.realTy), Ty.realTy)
292                    | _ => raise Fail "argument of real conversion must be int"                    | _ => err(cxt, [S "argument of real conversion must be int"])
293                  (* end case *))                  (* end case *))
294            (* end case *))            (* end case *))
295    
# Line 220  Line 313 
313                  val x' = Var.new (x, kind, ty)                  val x' = Var.new (x, kind, ty)
314                  val (e', ty') = checkExpr (env, cxt, e)                  val (e', ty') = checkExpr (env, cxt, e)
315                  in                  in
316  (* FIXME: check types *)  (* FIXME: this check is not flexible enough; should allow lhs type to support
317                    (x, x', e')   * 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                  end
328            (* end case *))            (* end case *))
329    
# Line 239  Line 341 
341                    (chk (env, stms, []), env)                    (chk (env, stms, []), env)
342                  end                  end
343              | PT.S_Decl vd => let              | PT.S_Decl vd => let
344                  val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)                  val (x, x', e) = checkVarDecl (methodScope env, cxt, Var.LocalVar, vd)
345                  in                  in
346                    (AST.S_Decl(AST.VD_Decl(x', e)), Env.insertLocal(env, x, x'))                    (AST.S_Decl(AST.VD_Decl(x', e)), insertLocal(env, x, x'))
347                  end                  end
348              | PT.S_IfThen(e, s) => let              | PT.S_IfThen(e, s) => let
349                  val (e', ty) = checkExpr (env, cxt, e)                  val (e', ty) = checkExpr (env, cxt, e)
# Line 250  Line 352 
352                  (* check that condition has bool type *)                  (* check that condition has bool type *)
353                    case ty                    case ty
354                     of Ty.T_Bool => ()                     of Ty.T_Bool => ()
355                      | _ => raise Fail "condition not boolean type"                      | _ => err(cxt, [S "condition not boolean type"])
356                    (* end case *);                    (* end case *);
357                    (AST.S_IfThenElse(e', s', AST.S_Block[]), env)                    (AST.S_IfThenElse(e', s', AST.S_Block[]), env)
358                  end                  end
# Line 262  Line 364 
364                  (* check that condition has bool type *)                  (* check that condition has bool type *)
365                    case ty                    case ty
366                     of Ty.T_Bool => ()                     of Ty.T_Bool => ()
367                      | _ => raise Fail "condition not boolean type"                      | _ => err(cxt, [S "condition not boolean type"])
368                    (* end case *);                    (* end case *);
369                    (AST.S_IfThenElse(e', s1', s2'), env)                    (AST.S_IfThenElse(e', s1', s2'), env)
370                  end                  end
371              | PT.S_Assign(x, e) => (case Env.findVar (env, x)              | PT.S_Assign(x, e) => (case Env.findVar (#env env, x)
372                   of NONE => raise Fail "undefined variable"                   of NONE => err(cxt, [
373                            S "undefined variable ", A x
374                          ])
375                    | SOME x' => let                    | SOME x' => let
376                        val (e', ty) = checkExpr (env, cxt, e)  (* FIXME: check for polymorphic variables *)
377                          val ([], ty) = Var.typeOf x'
378                          val (e', ty') = checkExpr (env, cxt, e)
379                        in                        in
380  (* FIXME: check types *)                          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 *)                        (* check that x' is mutable *)
389                          case Var.kindOf x'                          case Var.kindOf x'
390                           of Var.ActorStateVar => ()                           of Var.ActorStateVar => ()
391                              | Var.ActorOutputVar => ()
392                            | Var.LocalVar => ()                            | Var.LocalVar => ()
393                            | _ => raise Fail "assignment to immutable variable"                            | _ => err(cxt, [
394                                    S "assignment to immutable variable ", A x
395                                  ])
396                          (* end case *);                          (* end case *);
397                          (AST.S_Assign(x', e'), env)                          (AST.S_Assign(x', e'), env)
398                        end                        end
# Line 285  Line 401 
401                  val argsAndTys' = List.map (fn e => checkExpr(env, cxt, e)) args                  val argsAndTys' = List.map (fn e => checkExpr(env, cxt, e)) args
402                  val (args', tys') = ListPair.unzip argsAndTys'                  val (args', tys') = ListPair.unzip argsAndTys'
403                  in                  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 *)  (* FIXME: check that actor is defined and has the argument types match *)
410                    (AST.S_New(actor, args'), env)                    (AST.S_New(actor, args'), env)
411                  end                  end
412              | PT.S_Die => (AST.S_Die, env)              | PT.S_Die => (
413              | PT.S_Stabilize => (AST.S_Stabilize, env)                  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      fun checkParams (env, cxt, params) = let
# Line 298  Line 429 
429                    | PT.P_Param(ty, x) => let                    | PT.P_Param(ty, x) => let
430                        val x' = Var.new(x, AST.ActorParam, checkTy (cxt, ty))                        val x' = Var.new(x, AST.ActorParam, checkTy (cxt, ty))
431                        in                        in
432                          (x', Env.insertLocal(env, x, x'))                          (x', insertLocal(env, x, x'))
433                        end                        end
434                  (* end case *))                  (* end case *))
435            fun chk (param, (xs, env)) = let            fun chk (param, (xs, env)) = let
# Line 314  Line 445 
445      fun checkMethod (env, cxt, meth) = (case meth      fun checkMethod (env, cxt, meth) = (case meth
446             of PT.M_Mark m => checkMethod (withEnvAndContext (env, cxt, m))             of PT.M_Mark m => checkMethod (withEnvAndContext (env, cxt, m))
447              | PT.M_Method(name, body) => let              | PT.M_Method(name, body) => let
448                  val (body, _) = checkStmt(env, cxt, body)                  val (body, _) = checkStmt(methodScope env, cxt, body)
449                  in                  in
450                    AST.M_Method(name, body)                    AST.M_Method(name, body)
451                  end                  end
# Line 325  Line 456 
456            val (params, env) = checkParams (env, cxt, params)            val (params, env) = checkParams (env, cxt, params)
457          (* check the actor state variable definitions *)          (* check the actor state variable definitions *)
458            val (vds, env) = let            val (vds, env) = let
459                  fun checkStateVar (vd, (vds, env)) = let                  fun checkStateVar ((isOut, vd), (vds, env)) = let
460                        val (x, x', e') = checkVarDecl (env, cxt, AST.ActorStateVar, vd)                        val kind = if isOut then AST.ActorOutputVar else AST.ActorStateVar
461                        in                        val (x, x', e') = checkVarDecl (env, cxt, kind, vd)
462                          (AST.VD_Decl(x', e')::vds, Env.insertLocal(env, x, x'))                        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                        end
472                  val (vds, env) = List.foldl checkStateVar ([], env) state                  val (vds, env) = List.foldl checkStateVar ([], env) state
473                  in                  in
# Line 340  Line 479 
479              AST.D_Actor{name = name, params = params, state = vds, methods = methods}              AST.D_Actor{name = name, params = params, state = vds, methods = methods}
480            end            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 (withEnvAndContext (env, cxt, 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
# Line 350  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                  end
543              | PT.D_Var vd => let              | PT.D_Var vd => let
544                  val (x, x', e') = checkVarDecl (env, cxt, Var.GlobalVar, vd)                  val (x, x', e') = checkVarDecl (env, cxt, Var.GlobalVar, vd)
545                  in                  in
546                    (AST.D_Var(AST.VD_Decl(x', e')), Env.insertGlobal(env, x, x'))                    (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_Actor arg => (checkActor(env, cxt, arg), env)  
             | PT.D_InitialArray(bindings, iterators) => raise Fail "unimplemented" (* FIXME *)  
             | PT.D_InitialCollection(bindings, iterators) => raise Fail "unimplemented" (* FIXME *)  
563            (* end case *))            (* end case *))
564    
565      fun check errStrm (PT.Program{span, tree}) = let      fun check errStrm (PT.Program{span, tree}) = let
# Line 376  Line 571 
571                    chk (env, dcls, dcl'::dcls')                    chk (env, dcls, dcl'::dcls')
572                  end                  end
573            in            in
574              chk (Basis.env, tree, [])              chk ({scope=GlobalScope, env=Basis.env}, tree, [])
575            end            end
576    
577    end    end

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

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