CVS: sml-dist/src/compiler/FLINT/plambda chkplexp.sml, 1.9.10.6, 1.9.10.7
George Kuan <[email protected]> Thu, 24 Aug 2006 11:28:45 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3188/src/compiler/FLINT/plambda
Modified Files:
Tag: primop-branch-2
chkplexp.sml
Log Message:
improved error reporting in chkplexp
Index: chkplexp.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda/chkplexp.sml,v
retrieving revision 1.9.10.6
retrieving revision 1.9.10.7
diff -C2 -d -r1.9.10.6 -r1.9.10.7
*** chkplexp.sml 24 Aug 2006 17:45:03 -0000 1.9.10.6
--- chkplexp.sml 24 Aug 2006 18:28:43 -0000 1.9.10.7
***************
*** 5,8 ****
--- 5,10 ----
sig
+ exception ChkPlexp (* PLambda type check error *)
+
val checkLtyTop : PLambda.lexp * int -> bool
val checkLty : PLambda.lexp * PLambdaType.ltyEnv * int -> bool
***************
*** 22,25 ****
--- 24,29 ----
in
+ exception ChkPlexp (* PLambda type check error *)
+
(*** a hack of printing diagnostic output into a separate file ***)
val newlam_ref : PLambda.lexp ref = ref (RECORD[])
***************
*** 214,251 ****
(** 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 =>
! (LT.ltLookup(venv, v, d)
! handle LT.ltUnbound =>
! (say ("** Lvar ** " ^ (LV.lvarName(v)) ^ " is unbound *** \n");
! bug "unexpected lambda code in checkLty"))
! | (INT _ | WORD _) => LT.ltc_int
! | (INT32 _ | WORD32 _) => LT.ltc_int32
! | REAL _ => LT.ltc_real
! | STRING _ => ltString
! | PRIM(p, t, ts) =>
! (* kind check t and ts *)
! ((* ltyChkenv t; map (tycChk kenv) ts; *)
! ltTyApp le "PRIM" (t, ts, kenv))
!
! | FN(v, t, e1) =>
! let val _ = ltyChkenv t (* kind check bound variable type *)
! val venv' = LT.ltInsert(venv, v, t, d)
! val res = check (kenv, venv', d) e1
! val _ = ltyChkenv res
! in ltFun(t, res) (* handle both functions and functors *)
! end
!
! | FIX(vs, ts, es, eb) =>
! let val _ = map ltyChkenv ts (* kind check bound variable types *)
! 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."
! val venv' = h(venv, vs, ts)
!
! val nts = map (check (kenv, venv', d)) es
! val _ = map ltyChkenv nts
val _ = app2(ltMatch le "FIX1", ts, nts)
--- 218,273 ----
(** check : tkindEnv * ltyEnv * DI.depth -> lexp -> lty *)
fun check (kenv, venv, d) =
! let fun ltyChkMsg msg lexp kenv lty =
! ltyChk kenv lty
! handle LT.KindChk kndchkmsg =>
! (say ("*** Kind check failure during \
! \ PLambda type check: ");
! say (msg);
! say ("***\n Term: ");
! PPLexp.printLexp lexp;
! say ("\n Kind check error: ");
! say kndchkmsg;
! say ("\n");
! raise ChkPlexp)
fun loop le =
! let fun ltyChkMsgLexp msg kenv lty =
! ltyChkMsg msg lexp kenv lty
! fun ltyChkenv msg lty = ltyChkMsgLexp msg kenv lty
! in
! (case le
! of VAR v =>
! (LT.ltLookup(venv, v, d)
! handle LT.ltUnbound =>
! (say ("** Lvar ** " ^ (LV.lvarName(v))
! ^ " is unbound *** \n");
! bug "unexpected lambda code in checkLty"))
! | (INT _ | WORD _) => LT.ltc_int
! | (INT32 _ | WORD32 _) => LT.ltc_int32
! | REAL _ => LT.ltc_real
! | STRING _ => ltString
! | PRIM(p, t, ts) =>
! (* kind check t and ts *)
! ((* ltyChkenv t; map (tycChk kenv) ts; *)
! ltTyApp le "PRIM" (t, ts, kenv))
!
! | FN(v, t, e1) =>
! let val _ = ltyChkenv "FN bound var" t
! (* kind check bound variable type *)
! val venv' = LT.ltInsert(venv, v, t, d)
! val res = check (kenv, venv', d) e1
! val _ = ltyChkenv "FN rng" res
! in ltFun(t, res) (* handle both functions and functors *)
! end
!
! | FIX(vs, ts, es, eb) =>
! let val _ = map (ltyChkenv "FIX bound var") ts
! (* kind check bound variable types *)
! 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."
! val venv' = h(venv, vs, ts)
!
! val nts = map (check (kenv, venv', d)) es
! val _ = map (ltyChkenv "FIX body types") nts
val _ = app2(ltMatch le "FIX1", ts, nts)
***************
*** 262,268 ****
| LET(v, e1, e2) =>
let val t1 = loop e1
! val _ = ltyChkenv t1
val venv' = LT.ltInsert(venv, v, t1, d)
! in check (kenv, venv', d) e2
end
--- 284,292 ----
| LET(v, e1, e2) =>
let val t1 = loop e1
! val _ = ltyChkenv "LET definen" t1
val venv' = LT.ltInsert(venv, v, t1, d)
! val bodyLty = check (kenv, venv', d) e2
! val _ = ltyChkenv "LET body" bodyLty
! in bodyLty
end
***************
*** 270,274 ****
let val kenv' = LT.tkInsert(kenv, ks)
val lt = check (kenv', venv, DI.next d) e
! val _ = ltyChk (ks::kenv) lt
in LT.ltc_poly(ks, [lt])
end
--- 294,298 ----
let val kenv' = LT.tkInsert(kenv, ks)
val lt = check (kenv', venv, DI.next d) e
! val _ = ltyChkMsgLexp "TFN body" (ks::kenv) lt
in LT.ltc_poly(ks, [lt])
end
***************
*** 276,281 ****
| TAPP(e, ts) =>
let val lt = loop e
! val _ = map (fn tc => ltyChkenv(LT.ltc_tyc tc)) ts (* kind check type args *)
! val _ = ltyChkenv lt
in ltTyApp le "TAPP" (lt, ts, kenv)
end
--- 300,305 ----
| TAPP(e, ts) =>
let val lt = loop e
! val _ = map (fn tc => ltyChkenv "TAPP args" (LT.ltc_tyc tc)) ts (* kind check type args *)
! val _ = ltyChkenv "TAPP type function " lt
in ltTyApp le "TAPP" (lt, ts, kenv)
end
***************
*** 283,287 ****
| GENOP(dict, p, t, ts) =>
((* should type check dict also *)
! (map (fn tc => ltyChkenv(LT.ltc_tyc tc)) ts;
ltTyApp le "GENOP" (t, ts, kenv)))
--- 307,311 ----
| GENOP(dict, p, t, ts) =>
((* should type check dict also *)
! (map (fn tc => ltyChkenv "GENOP args " (LT.ltc_tyc tc)) ts;
ltTyApp le "GENOP" (t, ts, kenv)))
***************
*** 294,300 ****
| CON((_, rep, lt), ts, e) =>
let val t1 = ltTyApp le "CON" (lt, ts, kenv)
! val _ = ltyChkenv t1
val t2 = loop e
! val _ = ltyChkenv t2
in ltFnApp le "CON-A" (t1, t2)
end
--- 318,324 ----
| CON((_, rep, lt), ts, e) =>
let val t1 = ltTyApp le "CON" (lt, ts, kenv)
! val _ = ltyChkenv "CON 1 " t1
val t2 = loop e
! val _ = ltyChkenv "CON 2 " t2
in ltFnApp le "CON-A" (t1, t2)
end
***************
*** 311,316 ****
| VECTOR (el, t) =>
let val ts = map loop el
! in ltyChkenv (LT.ltc_tyc t);
! map ltyChkenv ts;
app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts;
ltVector t
--- 335,340 ----
| VECTOR (el, t) =>
let val ts = map loop el
! in ltyChkenv "VECTOR index " (LT.ltc_tyc t);
! map (ltyChkenv "VECTOR vector ") ts;
app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts;
ltVector t
***************
*** 326,330 ****
end
val ts = map h cl
! val _ = map ltyChkenv ts
in (case ts
of [] => bug "empty switch in checkLty"
--- 350,354 ----
end
val ts = map h cl
! val _ = map (ltyChkenv "SWITCH branch ") ts
in (case ts
of [] => bug "empty switch in checkLty"
***************
*** 339,343 ****
let val z = loop e (* what do we check on e ? *)
val _ = ltMatch le "ETAG1" (z, LT.ltc_string)
! val _ = ltyChkenv t
in ltEtag t
end
--- 363,367 ----
let val z = loop e (* what do we check on e ? *)
val _ = ltMatch le "ETAG1" (z, LT.ltc_string)
! val _ = ltyChkenv "ETAG " t
in ltEtag t
end
***************
*** 362,370 ****
else (if b then LT.tcc_box t else LT.tcc_abs t)
val nt = LT.ltc_tyc ntc
! val _ = ltyChkenv nt
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 *)
--- 386,395 ----
else (if b then LT.tcc_box t else LT.tcc_abs t)
val nt = LT.ltc_tyc ntc
! val _ = ltyChkenv "UNWRAP " nt
in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
end)
+ end (* loop *)
in (* wrap loop with kind check of result *)
! fn x => let val y = loop x in ltyChkMsg "RESULT " x kenv y; y end
end (* end-of-fn-check *)
-------------------------------------------------------------------------
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