CVS: sml-dist/src/compiler/FLINT/plambda chkplexp.sml, 1.9, 1.9.10.1

Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12356/src/compiler/FLINT/plambda

Modified Files:
      Tag: primop-branch-2
	chkplexp.sml 
Log Message:
adding kind checking to chkplexp.sml

Index: chkplexp.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda/chkplexp.sml,v
retrieving revision 1.9
retrieving revision 1.9.10.1
diff -C2 -d -r1.9 -r1.9.10.1
*** chkplexp.sml	28 Aug 2003 21:59:07 -0000	1.9
--- chkplexp.sml	18 Aug 2006 22:58:46 -0000	1.9.10.1
***************
*** 108,113 ****
  
  val lt_inst_chk = LT.lt_inst_chk_gen()
  
! fun ltAppChk (lt, ts, kenv) = 
    (case lt_inst_chk(lt, ts, kenv) 
      of [b] => b 
--- 108,115 ----
  
  val lt_inst_chk = LT.lt_inst_chk_gen()
+ (* kind checker for ltys *)
+ val ltyChk = LT.ltyChkGen ()
  
! fun ltAppChk (lt, ts, kenv) : LT.lty = 
    (case lt_inst_chk(lt, ts, kenv) 
      of [b] => b 
***************
*** 207,217 ****
        end
  
- 
  (** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)
  fun check (kenv, venv, d) = 
!   let fun loop le =
         (case le
           of VAR v => 
!               (LT.ltLookup(venv, v, d) 
                 handle LT.ltUnbound => 
                  (say ("** Lvar ** " ^ (LV.lvarName(v)) ^ " is unbound *** \n");
--- 209,221 ----
        end
  
  (** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)
  fun check (kenv, venv, d) = 
!   let val ltyChkenv = ltyChk kenv
!       fun loop le =
         (case le
           of VAR v => 
!               (let val lty = LT.ltLookup(venv, v, d) 
!                 in ltyChk kenv lty; lty  (* no -- move this out and kcheck result *)
!                end
                 handle LT.ltUnbound => 
                  (say ("** Lvar ** " ^ (LV.lvarName(v)) ^ " is unbound *** \n");
***************
*** 221,228 ****
            | REAL _ => LT.ltc_real
            | STRING _ => ltString
!           | PRIM(p, t, ts) => ltTyApp le "PRIM" (t, ts, kenv) 
  
!           | FN(v, t, e1) => 
!               let val venv' = LT.ltInsert(venv, v, t, d)
                    val res = check (kenv, venv', d) e1
                 in ltFun(t, res) (* handle both functions and functors *)
--- 225,236 ----
            | REAL _ => LT.ltc_real
            | STRING _ => ltString
!           | PRIM(p, t, ts) =>
!              (* kind check t and ts *)
!               (ltyChkenv t; map ltyChkenv ts;
!                ltTyApp le "PRIM" (t, ts, kenv))
  
!           | FN(v, t, e1) =>
!               let val _ = ltyChkenv t (* kind check *)
!                   val venv' = LT.ltInsert(venv, v, t, d)
                    val res = check (kenv, venv', d) e1
                 in ltFun(t, res) (* handle both functions and functors *)
***************
*** 230,234 ****
  
            | FIX(vs, ts, es, eb) => 
!               let fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)
                      | h (env, [], []) = env
                      | h _ = bug "unexpected FIX bindings in checkLty."
--- 238,243 ----
  
            | FIX(vs, ts, es, eb) => 
!               let val _ = map ltyChkenv ts  (* kind check *)
!                   fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)
                      | h (env, [], []) = env
                      | h _ = bug "unexpected FIX bindings in checkLty."
***************
*** 331,337 ****
                 in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
                end)
!                             
! 
!   in loop 
   end (* end-of-fn-check *)
  
--- 340,345 ----
                 in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
                end)
!   in (* wrap loop with kind check of result *)
!      fn x => let val y = loop x in ltyChkenv y; y end
   end (* end-of-fn-check *)
  
***************
*** 343,345 ****
  end (* toplevel local *)
  end (* structure CheckLty *)
- 
--- 351,352 ----


-------------------------------------------------------------------------
Using Tomcat but need to do more? Need to support web services, security?
Get stuff done quickly with pre-integrated technology to make your job easier
Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo
http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642