CVS: sml-dist/src/compiler/FLINT/kernel lty.sig, 1.1.2.9, 1.1.2.10 lty.sml, 1.1.2.15, 1.1.2.16 ltyextern.sml, 1.19.24.11, 1.19.24.12 pplty.sml, 1.1.2.11, 1.1.2.12
David MacQueen <[email protected]> Tue, 22 Aug 2006 15:54:12 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv13888/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
lty.sig lty.sml ltyextern.sml pplty.sml
Log Message:
continued instrumentation and commenting for tcc_env bug
Index: lty.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.sig,v
retrieving revision 1.1.2.9
retrieving revision 1.1.2.10
diff -C2 -d -r1.1.2.9 -r1.1.2.10
*** lty.sig 18 Aug 2006 23:54:34 -0000 1.1.2.9
--- lty.sig 22 Aug 2006 22:54:10 -0000 1.1.2.10
***************
*** 193,197 ****
val tkChkGen : unit -> (tkindEnv -> (tkind * tyc) -> unit)
val ltyChkGen : unit -> (tkindEnv -> lty -> tkind)
!
end (* signature LTY *)
--- 193,198 ----
val tkChkGen : unit -> (tkindEnv -> (tkind * tyc) -> unit)
val ltyChkGen : unit -> (tkindEnv -> lty -> tkind)
! val tkTycGen' : unit -> (tkindEnv -> tyc -> tkind) *
! (tycEnv * int * tkindEnv -> unit)
end (* signature LTY *)
Index: lty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.sml,v
retrieving revision 1.1.2.15
retrieving revision 1.1.2.16
diff -C2 -d -r1.1.2.15 -r1.1.2.16
*** lty.sml 21 Aug 2006 23:07:05 -0000 1.1.2.15
--- lty.sml 22 Aug 2006 22:54:10 -0000 1.1.2.16
***************
*** 30,34 ****
type enc_tvar = int
! fun tvEncode (d, k) = d * MVAL + k
fun tvDecode x = ((x div MVAL), (x mod MVAL))
--- 30,34 ----
type enc_tvar = int
! fun tvEncode (d, k) = d * MVAL + k (* d >= 1, k >= 0 *)
fun tvDecode x = ((x div MVAL), (x mod MVAL))
***************
*** 74,78 ****
if h < h' then h :: mergeTvs (t, l')
else if h = h' then h :: mergeTvs (t, t')
! else h' :: mergeTvs (l, t')
(* fmergeTvs : tvar list list -> tvar list
--- 74,78 ----
if h < h' then h :: mergeTvs (t, l')
else if h = h' then h :: mergeTvs (t, t')
! else h' :: mergeTvs (l, t') (* h' < h *)
(* fmergeTvs : tvar list list -> tvar list
***************
*** 590,601 ****
* --CALeague
*)
! fun tkLookupFreeVars (kenv, tyc) =
let fun g (kenv, d, []) = []
| g (kenv, d, ftv::ftvs) =
! let val (d', i') = tvDecode ftv
val kenv' = List.drop (kenv, d'-d)
! handle Subscript => raise tkUnbound
! val k = List.nth (hd kenv', i')
! handle Subscript => raise tkUnbound
in
k :: g (kenv', d', ftvs)
--- 590,612 ----
* --CALeague
*)
! fun tkLookupFreeVars (kenv, tyc) : tkind list option =
! (* invariant for g: kenv starts with the d(th) frame of the original
! * kenv passed to tkLookupFreeVars *)
let fun g (kenv, d, []) = []
| g (kenv, d, ftv::ftvs) =
! let val (d', k') = tvDecode ftv
val kenv' = List.drop (kenv, d'-d)
! handle Subscript =>
! (print "### tkLookupFreeVars:1\n";
! raise tkUnbound)
! (* kenv' should start with the d'(th) frame *)
! val k = case kenv'
! of nil => (print "### tkLookupFreeVars:2\n";
! raise tkUnbound)
! | ks :: _ => (* ks is d'(th) frame *)
! (List.nth (ks, k')
! handle Subscript =>
! (print "### tkLookupFreeVars:3\n";
! raise tkUnbound))
in
k :: g (kenv', d', ftvs)
***************
*** 603,606 ****
--- 614,620 ----
fun h ftvs = g (kenv, 1, ftvs)
in Option.map h (tc_vs tyc)
+ (* assumes that tc_vs returns free variable codes sorted in
+ * ascending numerical order, which means lexicographical order
+ * on the decoded pairs *)
end
***************
*** 763,767 ****
else raise TkTycChk "Mono assertion failed!"
! (* select the ith element from a kind sequence *)
fun tkSel (tk, i) =
(case (tk_outX tk)
--- 777,781 ----
else raise TkTycChk "Mono assertion failed!"
! (* select the ith element (0 based) from a kind sequence *)
fun tkSel (tk, i) =
(case (tk_outX tk)
***************
*** 793,796 ****
--- 807,813 ----
| _ => raise TkTycChk "Application of non-TK_FUN")
+
+ (* Kind checking **************************************************)
+
(* Kind-checking naturally requires traversing type graphs. to avoid
* re-traversing bits of the dag, we use a dictionary to memoize the
Index: ltyextern.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltyextern.sml,v
retrieving revision 1.19.24.11
retrieving revision 1.19.24.12
diff -C2 -d -r1.19.24.11 -r1.19.24.12
*** ltyextern.sml 18 Aug 2006 23:54:34 -0000 1.19.24.11
--- ltyextern.sml 22 Aug 2006 22:54:10 -0000 1.19.24.12
***************
*** 39,48 ****
fun lt_bug lt s = bug (s ^ "\n\n" ^ (lt_print lt) ^ "\n\n")
(** instantiating a polymorphic type or an higher-order constructor *)
fun lt_inst (lt : lty, ts : tyc list) =
let val nt = lt_whnm lt
in (case ((* lt_outX *) lt_out nt, ts)
! of (LT.LT_POLY(ks, b), ts) =>
let val nenv = LT.teCons(LT.Beta(0,ts,ks), LT.teEmpty)
in map (fn x => ltc_env(x, 1, 0, nenv)) b
end
--- 39,59 ----
fun lt_bug lt s = bug (s ^ "\n\n" ^ (lt_print lt) ^ "\n\n")
+ val ltKindChk = Lty.ltyChkGen ()
+ val (tcKindChk,teKindChk) = Lty.tkTycGen' ()
+
(** instantiating a polymorphic type or an higher-order constructor *)
fun lt_inst (lt : lty, ts : tyc list) =
let val nt = lt_whnm lt
in (case ((* lt_outX *) lt_out nt, ts)
! of (LT.LT_POLY(ks, b), ts) =>
! if length ks <> length ts
! then (print "### arity error in lt_inst:\n|ks| = ";
! print (Int.toString (length ks));
! print ", |ts| = "; print (Int.toString (length ks));
! print "\n";
! bug "lt_inst")
! else
let val nenv = LT.teCons(LT.Beta(0,ts,ks), LT.teEmpty)
+ (* (no kind env) val _ = teKindChk(nenv,0,Lty.initTkEnv) *)
in map (fn x => ltc_env(x, 1, 0, nenv)) b
end
Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.sml,v
retrieving revision 1.1.2.11
retrieving revision 1.1.2.12
diff -C2 -d -r1.1.2.11 -r1.1.2.12
*** pplty.sml 17 Aug 2006 21:26:26 -0000 1.1.2.11
--- pplty.sml 22 Aug 2006 22:54:10 -0000 1.1.2.12
***************
*** 291,295 ****
end (* ppTycEnv *)
- end (* local *)
end (* structure PPLty *)
--- 291,347 ----
end (* ppTycEnv *)
+ fun ppLty pd ppstrm (lty: Lty.lty) =
+ if pd < 1 then pps ppstrm "<tyc>" else
+ let val {openHOVBox, openHVBox, closeBox, pps, ppi, ...} = en_pp ppstrm
+ val ppList' : {pp:PP.stream -> 'a -> unit, sep: string} -> 'a list -> unit =
+ fn x => ppList ppstrm x
+ (* eta-expansion of ppList to avoid value restriction *)
+
+ val ppTKind' = ppTKind (pd-1) ppstrm
+ val ppLty' = ppLty (pd-1) ppstrm
+
+ fun ppLtyI (Lty.LT_TYC tc) =
+ (pps "TYC("; ppTyc pd ppstrm tc; pps "0")
+ | ppLtyI (Lty.LT_STR ltys) =
+ (pps "STR("; ppList' {sep=",",pp=ppLty (pd-1)} ltys; pps ")")
+ | ppLtyI (Lty.LT_FCT (args,res)) =
+ (pps "FCT("; ppList' {sep=",",pp=ppLty (pd-1)} args; pps ",";
+ PP.break ppstrm {nsp=1,offset=0};
+ ppList' {sep=",",pp=ppLty (pd-1)} res; pps ")")
+ | ppLtyI (Lty.LT_POLY (ks,ltys)) =
+ (openHOVBox 1;
+ pps "FN(";
+ ppList' {sep="*", pp=ppTKind (pd-1)} ks;
+ pps ",";
+ PP.break ppstrm {nsp=1,offset=0};
+ ppList' {sep=",",pp=ppLty (pd-1)} ltys;
+ pps ")";
+ closeBox())
+ | ppLtyI (Lty.LT_CONT ltys) =
+ (pps "CONT("; ppList' {sep=",",pp=ppLty (pd-1)} ltys; pps ")")
+ | ppLtyI (Lty.LT_IND(nt,ot)) =
+ (pps "IND("; ppLty (pd-1) ppstrm nt; pps ",";
+ PP.break ppstrm {nsp=1,offset=0};
+ ppLtyI ot; pps ")")
+ | ppLtyI (Lty.LT_ENV (lty, ol, nl, tenv)) =
+ (openHVBox 1;
+ pps "LT_ENV(";
+ pps "ol=";
+ pps (Int.toString ol);
+ pps ", ";
+ pps "nl=";
+ pps (Int.toString nl);
+ pps ",";
+ PP.break ppstrm {nsp=1,offset=0};
+ ppLty' lty;
+ pps ",";
+ PP.break ppstrm {nsp=1,offset=0};
+ ppList' {sep=",", pp=ppTEBinder (pd-1)} (tycEnvFlatten tenv);
+ closeBox())
+ in ppLtyI (Lty.lt_outX lty)
+ end (* ppLty *)
+
+ end (* local *)
+
end (* structure PPLty *)
-------------------------------------------------------------------------
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