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

SCM Repository

[diderot] Diff of /branches/pure-cfg/src/compiler/typechecker/typechecker.sml
ViewVC logotype

Diff of /branches/pure-cfg/src/compiler/typechecker/typechecker.sml

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

revision 902, Wed Apr 20 21:32:01 2011 UTC revision 903, Thu Apr 21 14:09:20 2011 UTC
# Line 17  Line 17 
17    
18    end = struct    end = struct
19    
20        structure BV = BasisVars
21      structure PT = ParseTree      structure PT = ParseTree
22      structure Ty = Types      structure Ty = Types
23      structure TU = TypeUtil      structure TU = TypeUtil
# Line 236  Line 237 
237                                    in                                    in
238                                      splitLast ([], dd1)                                      splitLast ([], dd1)
239                                    end                                    end
240                              val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf BasisVars.op_inner)                              val (tyArgs, Ty.T_Fun(domTy, rngTy)) = Util.instantiate(Var.typeOf BV.op_inner)
241                              val resTy = Ty.T_Tensor(Ty.Shape(dd1@dd2))                              val resTy = Ty.T_Tensor(Ty.Shape(dd1@dd2))
242                              in                              in
243                                if U.matchDim(d1, d2)                                if U.matchDim(d1, d2)
244                                andalso U.matchTypes(domTy, [ty1, ty2])                                andalso U.matchTypes(domTy, [ty1, ty2])
245                                andalso U.matchType(rngTy, resTy)                                andalso U.matchType(rngTy, resTy)
246                                  then (AST.E_Apply(BasisVars.op_inner, tyArgs, [e1', e2'], rngTy), rngTy)                                  then (AST.E_Apply(BV.op_inner, tyArgs, [e1', e2'], rngTy), rngTy)
247                                  else err (cxt, [                                  else err (cxt, [
248                                      S "type error for arguments of binary operator \"•\"\n",                                      S "type error for arguments of binary operator \"•\"\n",
249                                      S "  found: ", TYS[ty1, ty2], S "\n"                                      S "  found: ", TYS[ty1, ty2], S "\n"
# Line 319  Line 320 
320                  in                  in
321                    raise Fail "E_Subscript not yet implemented" (* FIXME *)                    raise Fail "E_Subscript not yet implemented" (* FIXME *)
322                  end                  end
323              | PT.E_Apply(f, args) => let              | PT.E_Apply(e, args) => let
324                    fun stripMark (PT.E_Mark{tree, ...}) = stripMark tree
325                      | stripMark e = e
326                  val (args, tys) = checkExprList (env, cxt, args)                  val (args, tys) = checkExprList (env, cxt, args)
327                    fun checkFieldApp (e1', ty1) = (case (args, tys)
328                           of ([e2'], [ty2]) => let
329                                val (tyArgs, Ty.T_Fun(domTy, rngTy)) =
330                                      Util.instantiate(Var.typeOf BV.op_at)
331                  in                  in
332                    case Env.findFunc (#env env, f)                                if U.matchTypes(domTy, [ty1, ty2])
333                                    then (AST.E_Apply(BV.op_at, tyArgs, [e1', e2'], rngTy), rngTy)
334                                    else err (cxt, [
335                                        S "type error for field application\n",
336                                        S "  expected:  ", TYS domTy, S "\n",
337                                        S "  but found: ", TYS[ty1, ty2]
338                                      ])
339                                end
340                            | _ => err(cxt, [S "badly formed field application"])
341                          (* end case *))
342                    in
343                      case stripMark e
344                       of PT.E_Var f => (case Env.findVar (#env env, f)
345                             of SOME f' => checkFieldApp (AST.E_Var f', Var.monoTypeOf f')
346                              | NONE => (case Env.findFunc (#env env, f)
347                     of [] => err(cxt, [S "unknown function ", A f])                     of [] => err(cxt, [S "unknown function ", A f])
348                      | [f] =>                      | [f] =>
349                          if (inStrand env) andalso (Basis.isRestricted f)                          if (inStrand env) andalso (Basis.isRestricted f)
350                            then err(cxt, [S "use of restricted operation ", V f, S " in strand body"])                                        then err(cxt, [
351                                              S "use of restricted operation ", V f,
352                                              S " in strand body"
353                                            ])
354                            else (case Util.instantiate(Var.typeOf f)                            else (case Util.instantiate(Var.typeOf f)
355                               of (tyArgs, Ty.T_Fun(domTy, rngTy)) =>                               of (tyArgs, Ty.T_Fun(domTy, rngTy)) =>
356                                    if U.matchTypes(domTy, tys)                                    if U.matchTypes(domTy, tys)
# Line 339  Line 363 
363                                | _ => err(cxt, [S "application of non-function ", V f])                                | _ => err(cxt, [S "application of non-function ", V f])
364                              (* end case *))                              (* end case *))
365                      | ovldList => resolveOverload (cxt, f, tys, args, ovldList)                      | ovldList => resolveOverload (cxt, f, tys, args, ovldList)
366                                  (* end case *))
367                              (* end case *))
368                        | _ => checkFieldApp (checkExpr (env, cxt, e))
369                    (* end case *)                    (* end case *)
370                  end                  end
371              | PT.E_Tuple args => let              | PT.E_Tuple args => let
# Line 369  Line 396 
396                  end                  end
397              | PT.E_Real e => (case checkExpr (env, cxt, e)              | PT.E_Real e => (case checkExpr (env, cxt, e)
398                   of (e', Ty.T_Int) =>                   of (e', Ty.T_Int) =>
399                        (AST.E_Apply(BasisVars.i2r, [], [e'], Ty.realTy), Ty.realTy)                        (AST.E_Apply(BV.i2r, [], [e'], Ty.realTy), Ty.realTy)
400                    | _ => err(cxt, [S "argument of real conversion must be int"])                    | _ => err(cxt, [S "argument of real conversion must be int"])
401                  (* end case *))                  (* end case *))
402              | PT.E_Id d => let              | PT.E_Id d => let
403                  val (tyArgs, Ty.T_Fun(_, rngTy)) =                  val (tyArgs, Ty.T_Fun(_, rngTy)) =
404                        Util.instantiate(Var.typeOf(BasisVars.identity))                        Util.instantiate(Var.typeOf(BV.identity))
405                  in                  in
406                    if U.matchType(Ty.T_Tensor(checkShape(cxt, [d,d])), rngTy)                    if U.matchType(Ty.T_Tensor(checkShape(cxt, [d,d])), rngTy)
407                      then (AST.E_Apply(BasisVars.identity, tyArgs, [], rngTy), rngTy)                      then (AST.E_Apply(BV.identity, tyArgs, [], rngTy), rngTy)
408                      else raise Fail "impossible"                      else raise Fail "impossible"
409                  end                  end
410              | PT.E_Zero dd => let              | PT.E_Zero dd => let
411                  val (tyArgs, Ty.T_Fun(_, rngTy)) =                  val (tyArgs, Ty.T_Fun(_, rngTy)) =
412                        Util.instantiate(Var.typeOf(BasisVars.zero))                        Util.instantiate(Var.typeOf(BV.zero))
413                  in                  in
414                    if U.matchType(Ty.T_Tensor(checkShape(cxt, dd)), rngTy)                    if U.matchType(Ty.T_Tensor(checkShape(cxt, dd)), rngTy)
415                      then (AST.E_Apply(BasisVars.zero, tyArgs, [], rngTy), rngTy)                      then (AST.E_Apply(BV.zero, tyArgs, [], rngTy), rngTy)
416                      else raise Fail "impossible"                      else raise Fail "impossible"
417                  end                  end
418            (* end case *))            (* end case *))

Legend:
Removed from v.902  
changed lines
  Added in v.903

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