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

SCM Repository

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

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

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

revision 80, Tue May 25 03:05:33 2010 UTC revision 85, Wed May 26 19:51:10 2010 UTC
# Line 12  Line 12 
12    
13      structure PT = ParseTree      structure PT = ParseTree
14      structure Ty = Types      structure Ty = Types
15        structure U = Util
16    
17        val realZero = AST.E_Lit(Literal.Float(FloatLit.zero true))
18    
19    (* check a differentiation level, which muse be >= 0 *)    (* check a differentiation level, which muse be >= 0 *)
20      fun checkDiff (cxt, k) =      fun checkDiff (cxt, k) =
# Line 21  Line 24 
24    
25    (* check a dimension, which must be 2 or 3 *)    (* check a dimension, which must be 2 or 3 *)
26      fun checkDim (cxt, d) =      fun checkDim (cxt, d) =
27            if (d < 2) orelse (3 < d)            if (d <= 0)
28              then raise Fail "invalid dimension; must be 2 or 3"              then raise Fail "invalid dimension; must be > 0"
29              else Ty.DimConst(IntInf.toInt d)              else Ty.DimConst(IntInf.toInt d)
30    
31    (* check a shape *)    (* check a shape *)
# Line 64  Line 67 
67              | (Literal.Bool _) => (AST.E_Lit lit, Ty.T_Bool)              | (Literal.Bool _) => (AST.E_Lit lit, Ty.T_Bool)
68            (* end case *))            (* end case *))
69    
70  (*    (* resolve overloading: we use a simple scheme that selects the first operator in the
71       * list that matches the argument types.
72       *)
73        fun resolveOverload (rator, argTys, args, candidates) = let
74              fun tryCandidates [] = raise Fail(concat[
75                      "unable to resolve overloaded operator \"", Atom.toString rator, "\""
76                    ])
77                | tryCandidates (x::xs) = let
78                    val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf x)
79                    in
80                      if U.tryMatchTypes(domTy, argTys)
81                        then (AST.E_Apply(x, tyArgs, args, rngTy), rngTy)
82                        else tryCandidates xs
83                    end
84              in
85                tryCandidates candidates
86              end
87    
88    (* typecheck an expression and translate it to AST *)    (* typecheck an expression and translate it to AST *)
89      fun checkExpr (env, cxt, e) = (case e      fun checkExpr (env, cxt, e) = (case e
90             of PT.E_Mark m => checkExpr (env, #span m, #tree m)             of PT.E_Mark m => checkExpr (env, #span m, #tree m)
91              | PT.E_Var x => (case Env.findVar (env, x)              | PT.E_Var x => (case Env.findVar (env, x)
92                   of SOME x' => (case Var.typeOf x'                   of SOME x' => let
93                         of ([], ty) => (AST.E_Var x', ty)                        val (args, ty) = Util.instantiate(Var.typeOf x')
                         | scheme => let  
                             val (args, ty) = Util.instantiate scheme  
94                              in                              in
95                                (AST.E_VarInst(x', args, ty), ty)                          (AST.E_Var(x', args, ty), ty)
96                              end                              end
                       (* end case *))  
97                    | NONE => raise Fail "undefined variable"                    | NONE => raise Fail "undefined variable"
98                  (* end case *))                  (* end case *))
99              | PT.E_Lit lit => checkLit lit              | PT.E_Lit lit => checkLit lit
100              | PT.E_BinOp of expr * var * expr              | PT.E_OrElse(e1, e2) => let
101              | PT.E_UnaryOp of var * expr                  val (e1', ty1) = checkExpr(env, cxt, e1)
102              | PT.E_Tuple of expr list                  val (e2', ty2) = checkExpr(env, cxt, e2)
103              | PT.E_Apply of var * expr list                  in
104              | PT.E_Cons of ty * expr list                    case (ty1, ty2)
105                       of (Ty.T_Bool, Ty.T_Bool) =>
106                            (AST.E_Cond(e1', AST.E_Lit(Literal.Bool true), e2'), Ty.T_Bool)
107                        | _ => raise Fail "arguments to \"||\" must have bool type"
108                      (* end case *)
109                    end
110                | PT.E_AndAlso(e1, e2) => let
111                    val (e1', ty1) = checkExpr(env, cxt, e1)
112                    val (e2', ty2) = checkExpr(env, cxt, e2)
113                    in
114                      case (ty1, ty2)
115                       of (Ty.T_Bool, Ty.T_Bool) =>
116                            (AST.E_Cond(e1', e2', AST.E_Lit(Literal.Bool false)), Ty.T_Bool)
117                        | _ => raise Fail "arguments to \"||\" must have bool type"
118                      (* end case *)
119                    end
120                | PT.E_BinOp(e1, rator, e2) => let
121                    val (e1', ty1) = checkExpr(env, cxt, e1)
122                    val (e2', ty2) = checkExpr(env, cxt, e2)
123                    in
124                      case Basis.findOp rator
125                       of [rator] => let
126                            val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf rator)
127                            in
128                              if U.matchTypes(domTy, [ty1, ty2])
129                                then (AST.E_Apply(rator, tyArgs, [e1', e2'], rngTy), rngTy)
130                                else raise Fail(concat[
131                                    "type error for binary operator \"", Var.nameOf rator, "\""
132                                  ])
133                            end
134                        | ovldList => resolveOverload (rator, [ty1, ty2], [e1', e2'], ovldList)
135                      (* end case *)
136                    end
137                | PT.E_UnaryOp(rator, e) => let
138                    val (e', ty) = checkExpr(env, cxt, e)
139                    in
140                      case Basis.findOp rator
141                       of [rator] => let
142                            val (tyArgs, Ty.T_Fun([domTy], rngTy)) = Util.instantiate(Var.typeOf rator)
143                            in
144                              if U.matchType(domTy, ty)
145                                then (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)
146                                else raise Fail(concat[
147                                    "type error for unary operator \"", Var.nameOf rator, "\""
148                                  ])
149                            end
150                        | ovldList => resolveOverload (rator, [ty], [e'], ovldList)
151                      (* end case *)
152                    end
153                | PT.E_Tuple args => let
154                    val (args, tys) = checkExprList (env, cxt, args)
155                    in
156                      raise Fail "E_Tuple not yet implemented"
157                    end
158                | PT.E_Apply(f, args) => let
159                    val (args, tys) = checkExprList (env, cxt, args)
160                    in
161                      case Env.findVar (env, f)
162                       of SOME f => (case Util.instantiate(Var.typeOf f)
163                             of (tyArgs, Ty.T_Fun(domTy, rngTy)) =>
164                                  if U.matchTypes(domTy, tys)
165                                    then (AST.E_Apply(f, tyArgs, args, rngTy), rngTy)
166                                    else raise Fail "type error for application"
167                              | _ => raise Fail "application of non-function"
168            (* end case *))            (* end case *))
169                        | NONE => raise Fail "unknown function"
170                      (* end case *)
171                    end
172                | PT.E_Cons(ty, args) => let
173                    val ty = checkTy(cxt, ty)
174                    val (args, tys) = checkExprList (env, cxt, args)
175                    in
176                      case (ty, tys)
177                       of (Ty.T_Tensor(Ty.Shape[]), [Ty.T_Int]) => (* int to real conversion *)
178                            (AST.E_Apply(BasisVars.i2r, [], args, ty), ty)
179                        | (Ty.T_Tensor(Ty.Shape[]), _) => raise Fail "invalid \"real\" conversion"
180                        | (Ty.T_Tensor(Ty.Shape dims), _) => let
181                            fun getDim (Ty.DimConst k) = k
182                              | getDim _ = raise Fail "unexpected dimension variable"
183                            val resultArity = List.foldl (fn (dim, a) => getDim dim * a) 1 dims
184                            val argArity = List.length args
185                            in
186                              if (resultArity = argArity)
187                                then (AST.E_Cons(ty, args), ty)
188                              else if (resultArity > argArity)
189                                then let
190                                  val xArgs = List.tabulate (resultArity-argArity, fn _ => realZero)
191                                  in
192                                    (AST.E_Cons(ty, args@xArgs), ty)
193                                  end
194                              else raise Fail "arity mismatch in tensor construction"
195                            end
196                      (* end case *)
197                    end
198              (* end case *))
199    
200      (* typecheck a list of expressions returning a list of AST expressions and a list
201       * of types of the expressions.
202       *)
203        and checkExprList (env, cxt, exprs) = let
204              fun chk (e, (es, tys)) = let
205                    val (e, ty) = checkExpr (env, cxt, e)
206                    in
207                      (e::es, ty::tys)
208                    end
209              in
210                List.foldr chk ([], []) exprs
211              end
212    
213      fun checkVarDecl (env, cxt, kind, d) = (case d      fun checkVarDecl (env, cxt, kind, d) = (case d
214             of PT.VD_Mark m => checkVarDecl (env, #span m, kind, #tree m)             of PT.VD_Mark m => checkVarDecl (env, #span m, kind, #tree m)
215              | PT.VD_Decl(ty, x, e) => let              | PT.VD_Decl(ty, x, e) => let
216                  val ty = checkType ty                  val ty = checkTy (cxt, ty)
217                  val x' = Var.new (x, kind, ty)                  val x' = Var.new (x, kind, ty)
218                  val (e', ty') = checkExpr (env, cxt, e)                  val (e', ty') = checkExpr (env, cxt, e)
219                  in                  in
220  (* FIXME: check types *)  (* FIXME: check types *)
221                    AST.VD_Decl(x', e')                    (x, x', e')
222                  end                  end
223            (* end case *))            (* end case *))
224    
# Line 107  Line 230 
230                    | chk (env, s::ss, stms) = let                    | chk (env, s::ss, stms) = let
231                        val (s', env') = checkStmt (env, cxt, s)                        val (s', env') = checkStmt (env, cxt, s)
232                        in                        in
233                          chk (env', ss, s'::ss)                          chk (env', ss, s'::stms)
234                        end                        end
235                  in                  in
236                    (chk (env, stms, []), env)                    (chk (env, stms, []), env)
237                  end                  end
238              | PT.S_Decl vd => let              | PT.S_Decl vd => let
239                  val vd as AST.VD_Decl(x, _) = checkVarDecl (env, cxt, Var.LocalVar, vd)                  val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)
240                  in                  in
241                    (AST.S_Decl vd, Env.insertLocal(env, x, x'))                    (AST.S_Decl(AST.VD_Decl(x', e)), Env.insertLocal(env, x, x'))
242                  end                  end
243              | PT.S_IfThen(e, s) => let              | PT.S_IfThen(e, s) => let
244                  val (e', ty) = checkExpr (env, cxt, e)                  val (e', ty) = checkExpr (env, cxt, e)
245                  val s' = checkStmt (env, cxt, s)                  val (s', _) = checkStmt (env, cxt, s)
246                  in                  in
247                  (* check that condition has bool type *)                  (* check that condition has bool type *)
248                    case ty                    case ty
# Line 130  Line 253 
253                  end                  end
254              | PT.S_IfThenElse(e, s1, s2) => let              | PT.S_IfThenElse(e, s1, s2) => let
255                  val (e', ty) = checkExpr (env, cxt, e)                  val (e', ty) = checkExpr (env, cxt, e)
256                  val s1' = checkStmt (env, cxt, s1)                  val (s1', _) = checkStmt (env, cxt, s1)
257                  val s2' = checkStmt (env, cxt, s2)                  val (s2', _) = checkStmt (env, cxt, s2)
258                  in                  in
259                  (* check that condition has bool type *)                  (* check that condition has bool type *)
260                    case ty                    case ty
# Line 156  Line 279 
279                        end                        end
280                  (* end case *))                  (* end case *))
281              | PT.S_New(actor, args) => let              | PT.S_New(actor, args) => let
282                  val argTys' = List.map (fn e => checkExpr(env, cxt, e)) args                  val argsAndTys' = List.map (fn e => checkExpr(env, cxt, e)) args
283                  val (args', tys') = ListPair.unzip argTys'                  val (args', tys') = ListPair.unzip argsAndTys'
284                  in                  in
285  (* FIXME: check that actor is defined and has the argument types match *)  (* FIXME: check that actor is defined and has the argument types match *)
286                    AST.S_New(actor, args')                    (AST.S_New(actor, args'), env)
287                  end                  end
288              | PT.S_Die => (AST.S_Die, env)              | PT.S_Die => (AST.S_Die, env)
289              | PT.S_Stabilize => (AST.S_Stabilize, env)              | PT.S_Stabilize => (AST.S_Stabilize, env)
290            (* end case *))            (* end case *))
291    
292        fun checkParams (env, cxt, params) = let
293              fun chkParam (env, cxt, param) = (case param
294                     of PT.P_Mark m => chkParam (env, #span m, #tree m)
295                      | PT.P_Param(ty, x) => let
296                          val x' = Var.new(x, AST.ActorParam, checkTy (cxt, ty))
297                          in
298                            (x', Env.insertLocal(env, x, x'))
299                          end
300                    (* end case *))
301              fun chk (param, (xs, env)) = let
302                    val (x, env) = chkParam (env, cxt, param)
303                    in
304                      (x::xs, env)
305                    end
306              in
307    (* FIXME: need to check for multiple occurences of the same parameter name! *)
308                List.foldr chk ([], env) params
309              end
310    
311        fun checkMethod (env, cxt, meth) = (case meth
312               of PT.M_Mark m => checkMethod (env, #span m, #tree m)
313                | PT.M_Method(name, body) => let
314                    val (body, _) = checkStmt(env, cxt, body)
315                    in
316                      AST.M_Method(name, body)
317                    end
318              (* end case *))
319    
320        fun checkActor (env, cxt, {name, params, state, methods}) = let
321            (* check the actor parameters *)
322              val (params, env) = checkParams (env, cxt, params)
323            (* check the actor state variable definitions *)
324              val (vds, env) = let
325                    fun checkStateVar (vd, (vds, env)) = let
326                          val (x, x', e') = checkVarDecl (env, cxt, AST.ActorStateVar, vd)
327                          in
328                            (AST.VD_Decl(x', e')::vds, Env.insertLocal(env, x, x'))
329                          end
330                    val (vds, env) = List.foldl checkStateVar ([], env) state
331                    in
332                      (List.rev vds, env)
333                    end
334            (* check the actor methods *)
335              val methods = List.map (fn m => checkMethod (env, cxt, m)) methods
336              in
337                AST.D_Actor{name = name, params = params, state = vds, methods = methods}
338              end
339    
340      fun checkDecl (env, cxt, d) = (case d      fun checkDecl (env, cxt, d) = (case d
341             of PT.D_Mark m => checkDecl (env, #span m, #tree m)             of PT.D_Mark m => checkDecl (env, #span m, #tree m)
342              | PT.D_Input(ty, x, optExp) => let              | PT.D_Input(ty, x, optExp) => let
# Line 184  Line 355 
355                    (dcl, Env.insertGlobal(env, x, x'))                    (dcl, Env.insertGlobal(env, x, x'))
356                  end                  end
357              | PT.D_Var vd => let              | PT.D_Var vd => let
358                  val vd as AST.VD_Decl(x, _) = checkVarDecl (env, cxt, Var.GlobalVar, vd)                  val (x, x', e') = checkVarDecl (env, cxt, Var.GlobalVar, vd)
359                  in                  in
360                    (AST.D_Var vd, Env.insertGlobal(env, x, x'))                    (AST.D_Var(AST.VD_Decl(x', e')), Env.insertGlobal(env, x, x'))
361                  end                  end
362              | PT.D_Actor{nam, params, state, methods} => ??              | PT.D_Actor arg => (checkActor(env, cxt, arg), env)
363              | PT.D_InitialArray of create * iter list              | PT.D_InitialArray(bindings, iterators) => raise Fail "unimplemented" (* FIXME *)
364              | PT.D_InitialCollection of create * iter list              | PT.D_InitialCollection(bindings, iterators) => raise Fail "unimplemented" (* FIXME *)
365            (* end case *))            (* end case *))
 *)  
366    
367      fun check (PT.Program dcls) = AST.Program[]      fun check (PT.Program{span, tree}) = let
368              fun chk (env, [], dcls') = AST.Program(List.rev dcls')
369                | chk (env, dcl::dcls, dcls') = let
370                    val (dcl', env) = checkDecl (env, span, dcl)
371                    in
372                      chk (env, dcls, dcl'::dcls')
373                    end
374              in
375                chk (Basis.env, tree, [])
376              end
377    
378    end    end

Legend:
Removed from v.80  
changed lines
  Added in v.85

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