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

revision 85, Wed May 26 19:51:10 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))      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 *)
# Line 39  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 87  Line 96 
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 169  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)  
                 in  
                   case (ty, tys)  
                    of (Ty.T_Tensor(Ty.Shape[]), [Ty.T_Int]) => (* int to real conversion *)  
                         (AST.E_Apply(BasisVars.i2r, [], args, ty), ty)  
                     | (Ty.T_Tensor(Ty.Shape[]), _) => raise Fail "invalid \"real\" conversion"  
                     | (Ty.T_Tensor(Ty.Shape dims), _) => let  
                         fun getDim (Ty.DimConst k) = k  
                           | getDim _ = raise Fail "unexpected dimension variable"  
                         val resultArity = List.foldl (fn (dim, a) => getDim dim * a) 1 dims  
                         val argArity = List.length args  
                         in  
                           if (resultArity = argArity)  
                             then (AST.E_Cons(ty, args), ty)  
                           else if (resultArity > argArity)  
                             then let  
                               val xArgs = List.tabulate (resultArity-argArity, fn _ => realZero)  
183                                in                                in
184                                  (AST.E_Cons(ty, args@xArgs), ty)                    case Util.prune ty
185                                end                     of Ty.T_Tensor shape => let
186                            else raise Fail "arity mismatch in tensor construction"                          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 *)                    (* end case *)
195                  end                  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 211  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 224  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 291  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 309  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 338  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 364  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.85  
changed lines
  Added in v.86

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