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 82, Wed May 26 18:20:49 2010 UTC revision 86, Wed May 26 22:23:17 2010 UTC
# Line 6  Line 6 
6    
7  structure Typechecker : sig  structure Typechecker : sig
8    
9      val check : ParseTree.program -> AST.program      val check : Error.err_stream -> ParseTree.program -> AST.program
10    
11    end = struct    end = struct
12    
# Line 14  Line 14 
14      structure Ty = Types      structure Ty = Types
15      structure U = Util      structure U = Util
16    
17        type context = Error.err_stream * Error.span
18    
19        fun withContext ((errStrm, _), {span, tree}) =
20              ((errStrm, span), tree)
21        fun withEnvAndContext (env, (errStrm, _), {span, tree}) =
22              (env, (errStrm, span), tree)
23    
24        fun error ((errStrm, span), msg) = Error.errorAt(errStrm, span, msg)
25    
26        val realZero = AST.E_Lit(Literal.Float(FloatLit.zero true))
27    
28    (* check a differentiation level, which muse be >= 0 *)    (* check a differentiation level, which muse be >= 0 *)
29      fun checkDiff (cxt, k) =      fun checkDiff (cxt, k) =
30            if (k < 0)            if (k < 0)
# Line 37  Line 48 
48    
49    (* 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 *)
50      fun checkTy (cxt, ty) = (case ty      fun checkTy (cxt, ty) = (case ty
51             of PT.T_Mark m => checkTy(#span m, #tree m)             of PT.T_Mark m => checkTy(withContext(cxt, m))
52              | PT.T_Bool => Ty.T_Bool              | PT.T_Bool => Ty.T_Bool
53              | PT.T_Int => Ty.T_Int              | PT.T_Int => Ty.T_Int
54              | PT.T_Real => Ty.realTy              | PT.T_Real => Ty.realTy
# Line 65  Line 76 
76              | (Literal.Bool _) => (AST.E_Lit lit, Ty.T_Bool)              | (Literal.Bool _) => (AST.E_Lit lit, Ty.T_Bool)
77            (* end case *))            (* end case *))
78    
79      (* resolve overloading: we use a simple scheme that selects the first operator in the
80       * list that matches the argument types.
81       *)
82        fun resolveOverload (rator, argTys, args, candidates) = let
83              fun tryCandidates [] = raise Fail(concat[
84                      "unable to resolve overloaded operator \"", Atom.toString rator, "\""
85                    ])
86                | tryCandidates (x::xs) = let
87                    val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf x)
88                    in
89                      if U.tryMatchTypes(domTy, argTys)
90                        then (AST.E_Apply(x, tyArgs, args, rngTy), rngTy)
91                        else tryCandidates xs
92                    end
93              in
94                tryCandidates candidates
95              end
96    
97    (* typecheck an expression and translate it to AST *)    (* typecheck an expression and translate it to AST *)
98      fun checkExpr (env, cxt, e) = (case e      fun checkExpr (env, cxt, e) = (case e
99             of PT.E_Mark m => checkExpr (env, #span m, #tree m)             of PT.E_Mark m => checkExpr (withEnvAndContext (env, cxt, m))
100              | PT.E_Var x => (case Env.findVar (env, x)              | PT.E_Var x => (case Env.findVar (env, x)
101                   of SOME x' => let                   of SOME x' => let
102                        val (args, ty) = Util.instantiate(Var.typeOf x')                        val (args, ty) = Util.instantiate(Var.typeOf x')
# Line 107  Line 136 
136                          in                          in
137                            if U.matchTypes(domTy, [ty1, ty2])                            if U.matchTypes(domTy, [ty1, ty2])
138                              then (AST.E_Apply(rator, tyArgs, [e1', e2'], rngTy), rngTy)                              then (AST.E_Apply(rator, tyArgs, [e1', e2'], rngTy), rngTy)
139                              else raise Fail "type error for binary operator"                              else raise Fail(concat[
140                                    "type error for binary operator \"", Var.nameOf rator, "\""
141                                  ])
142                          end                          end
143                      | ovldList => raise Fail "unimplemented" (* FIXME *)                      | ovldList => resolveOverload (rator, [ty1, ty2], [e1', e2'], ovldList)
144                    (* end case *)                    (* end case *)
145                  end                  end
146              | PT.E_UnaryOp(rator, e) => let              | PT.E_UnaryOp(rator, e) => let
# Line 121  Line 152 
152                          in                          in
153                            if U.matchType(domTy, ty)                            if U.matchType(domTy, ty)
154                              then (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)                              then (AST.E_Apply(rator, tyArgs, [e'], rngTy), rngTy)
155                              else raise Fail "type error for binary operator"                              else raise Fail(concat[
156                                    "type error for unary operator \"", Var.nameOf rator, "\""
157                                  ])
158                          end                          end
159                      | ovldList => raise Fail "unimplemented" (* FIXME *)                      | ovldList => resolveOverload (rator, [ty], [e'], ovldList)
160                    (* end case *)                    (* end case *)
161                  end                  end
162              | PT.E_Tuple args => let              | PT.E_Tuple args => let
# Line 145  Line 178 
178                      | NONE => raise Fail "unknown function"                      | NONE => raise Fail "unknown function"
179                    (* end case *)                    (* end case *)
180                  end                  end
181              | PT.E_Cons(ty, args) => let              | PT.E_Cons args => let
182                  val ty = checkTy(cxt, ty)                  val (args, ty::tys) = checkExprList (env, cxt, args)
                 val (args, tys) = checkExprList (env, cxt, args)  
183                  in                  in
184                    raise Fail "E_Cons unimplemented" (* FIXME *)                    case Util.prune ty
185                       of Ty.T_Tensor shape => let
186                            fun chkTy ty' = U.matchType(ty, ty')
187                            val resTy = Ty.T_Tensor(Ty.shapeExt(shape, Ty.DimConst(List.length args)))
188                            in
189                              if List.all chkTy tys
190                                then (AST.E_Cons args, resTy)
191                                else raise Fail "arguments of tensor construction must have same type"
192                  end                  end
193                        | _ => raise Fail "Invalid argument type for tensor construction"
194                      (* end case *)
195                    end
196                | PT.E_Real e => (case checkExpr (env, cxt, e)
197                     of (e', Ty.T_Int) =>
198                          (AST.E_Apply(BasisVars.i2r, [], [e'], Ty.realTy), Ty.realTy)
199                      | _ => raise Fail "argument of real conversion must be int"
200                    (* end case *))
201            (* end case *))            (* end case *))
202    
203    (* typecheck a list of expressions returning a list of AST expressions and a list    (* typecheck a list of expressions returning a list of AST expressions and a list
# Line 167  Line 214 
214            end            end
215    
216      fun checkVarDecl (env, cxt, kind, d) = (case d      fun checkVarDecl (env, cxt, kind, d) = (case d
217             of PT.VD_Mark m => checkVarDecl (env, #span m, kind, #tree m)             of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)
218              | PT.VD_Decl(ty, x, e) => let              | PT.VD_Decl(ty, x, e) => let
219                  val ty = checkTy (cxt, ty)                  val ty = checkTy (cxt, ty)
220                  val x' = Var.new (x, kind, ty)                  val x' = Var.new (x, kind, ty)
# Line 180  Line 227 
227    
228    (* typecheck a statement and translate it to AST *)    (* typecheck a statement and translate it to AST *)
229      fun checkStmt (env, cxt, s) = (case s      fun checkStmt (env, cxt, s) = (case s
230             of PT.S_Mark m => checkStmt (env, #span m, #tree m)             of PT.S_Mark m => checkStmt (withEnvAndContext (env, cxt, m))
231              | PT.S_Block stms => let              | PT.S_Block stms => let
232                  fun chk (_, [], stms) = AST.S_Block(List.rev stms)                  fun chk (_, [], stms) = AST.S_Block(List.rev stms)
233                    | chk (env, s::ss, stms) = let                    | chk (env, s::ss, stms) = let
# Line 247  Line 294 
294    
295      fun checkParams (env, cxt, params) = let      fun checkParams (env, cxt, params) = let
296            fun chkParam (env, cxt, param) = (case param            fun chkParam (env, cxt, param) = (case param
297                   of PT.P_Mark m => chkParam (env, #span m, #tree m)                   of PT.P_Mark m => chkParam (withEnvAndContext (env, cxt, m))
298                    | PT.P_Param(ty, x) => let                    | PT.P_Param(ty, x) => let
299                        val x' = Var.new(x, AST.ActorParam, checkTy (cxt, ty))                        val x' = Var.new(x, AST.ActorParam, checkTy (cxt, ty))
300                        in                        in
# Line 265  Line 312 
312            end            end
313    
314      fun checkMethod (env, cxt, meth) = (case meth      fun checkMethod (env, cxt, meth) = (case meth
315             of PT.M_Mark m => checkMethod (env, #span m, #tree m)             of PT.M_Mark m => checkMethod (withEnvAndContext (env, cxt, m))
316              | PT.M_Method(name, body) => let              | PT.M_Method(name, body) => let
317                  val (body, _) = checkStmt(env, cxt, body)                  val (body, _) = checkStmt(env, cxt, body)
318                  in                  in
# Line 294  Line 341 
341            end            end
342    
343      fun checkDecl (env, cxt, d) = (case d      fun checkDecl (env, cxt, d) = (case d
344             of PT.D_Mark m => checkDecl (env, #span m, #tree m)             of PT.D_Mark m => checkDecl (withEnvAndContext (env, cxt, m))
345              | PT.D_Input(ty, x, optExp) => let              | PT.D_Input(ty, x, optExp) => let
346                  val ty = checkTy(cxt, ty)                  val ty = checkTy(cxt, ty)
347                  val x' = Var.new(x, Var.InputVar, ty)                  val x' = Var.new(x, Var.InputVar, ty)
# Line 320  Line 367 
367              | PT.D_InitialCollection(bindings, iterators) => raise Fail "unimplemented" (* FIXME *)              | PT.D_InitialCollection(bindings, iterators) => raise Fail "unimplemented" (* FIXME *)
368            (* end case *))            (* end case *))
369    
370      fun check (PT.Program{span, tree}) = let      fun check errStrm (PT.Program{span, tree}) = let
371              val cxt = (errStrm, span)
372            fun chk (env, [], dcls') = AST.Program(List.rev dcls')            fun chk (env, [], dcls') = AST.Program(List.rev dcls')
373              | chk (env, dcl::dcls, dcls') = let              | chk (env, dcl::dcls, dcls') = let
374                  val (dcl', env) = checkDecl (env, span, dcl)                  val (dcl', env) = checkDecl (env, cxt, dcl)
375                  in                  in
376                    chk (env, dcls, dcl'::dcls')                    chk (env, dcls, dcl'::dcls')
377                  end                  end

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

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