CVS: sml-dist/src/compiler/FLINT/kernel ltybasic.sml, 1.13, 1.13.24.1 ltykernel.sml, 1.18.12.1, 1.18.12.2
David MacQueen <[email protected]> Wed, 26 Jul 2006 11:20:41 -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-serv5568/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
ltybasic.sml ltykernel.sml
Log Message:
further debugging code
Index: ltybasic.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltybasic.sml,v
retrieving revision 1.13
retrieving revision 1.13.24.1
diff -C2 -d -r1.13 -r1.13.24.1
*** ltybasic.sml 1 Jun 2000 18:33:26 -0000 1.13
--- ltybasic.sml 26 Jul 2006 18:20:36 -0000 1.13.24.1
***************
*** 25,29 ****
--- 25,32 ----
val ltc_env = LK.ltc_env
+ (* duplicated in ltykernel.sml *)
+
val itos = Int.toString
+
fun plist(p, []) = ""
| plist(p, x::xs) =
***************
*** 39,42 ****
--- 42,46 ----
fun parw(p, (ff, t1, t2)) =
"<" ^ (p t1) ^ "> -" ^ pfflag ff ^ "-> <" ^ (p t2) ^ ">"
+
in
Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.1
retrieving revision 1.18.12.2
diff -C2 -d -r1.18.12.1 -r1.18.12.2
*** ltykernel.sml 26 Jul 2006 15:21:41 -0000 1.18.12.1
--- ltykernel.sml 26 Jul 2006 18:20:36 -0000 1.18.12.2
***************
*** 436,439 ****
--- 436,529 ----
(***************************************************************************
+ * UTILITY FUNCTIONS FOR PRETTY PRINTING *
+ ***************************************************************************)
+ (* DBM: moved from ltybasic.sml *)
+ local
+
+ val itos = Int.toString
+
+ fun plist(p, []) = ""
+ | plist(p, x::xs) =
+ (p x) ^ (String.concat (map (fn z => ("," ^ (p z))) xs))
+
+ fun pfflag (FF_VAR b) =
+ let fun pff (true, true) = "rr" | pff (true, false) = "rc"
+ | pff (false, true) = "cr" | pff (false, false) = "cc"
+ in pff b
+ end
+ | pfflag (FF_FIXED) = "f"
+
+ fun parw(p, (ff, t1, t2)) =
+ "<" ^ (p t1) ^ "> -" ^ pfflag ff ^ "-> <" ^ (p t2) ^ ">"
+
+ in
+
+ (** pretty printing of tkinds, tycs, and ltys *)
+ fun tk_print (x : tkind) =
+ (case tk_outX x
+ of TK_MONO => "K0"
+ | TK_BOX => "KB0"
+ | TK_FUN (ks, k) =>
+ "<" ^ (plist(tk_print, ks)) ^ "->" ^ (tk_print k) ^ ">"
+ | TK_SEQ zs => "KS(" ^ (plist(tk_print, zs)) ^ ")")
+
+ fun tc_print (x : tyc) =
+ (case tc_outX x
+ of TC_VAR(i,j) => "TV(" ^ (DI.di_print i) ^ "," ^ (itos j) ^ ")"
+ | TC_NVAR v => "NTV(v" ^ (itos v) ^ ")"
+ | TC_PRIM pt => PT.pt_print pt
+ | TC_FN(ks, t) =>
+ "(\\[" ^ plist(tk_print, ks) ^ "]." ^ (tc_print t) ^ ")"
+ | TC_APP(t, []) => tc_print t ^ "[]"
+ | TC_APP(t, zs) =>
+ (tc_print t) ^ "[" ^ (plist(tc_print, zs)) ^ "]"
+ | TC_SEQ zs => "TS(" ^ (plist(tc_print,zs)) ^ ")"
+ | TC_PROJ (t, i) =>
+ "TP(" ^ (tc_print t) ^ "," ^ (itos i) ^ ")"
+ | TC_SUM tcs =>
+ "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"
+ | TC_FIX ((_, tc, ts), i) =>
+ if false (* tc_eqv(x,tcc_bool) *) then "B"
+ else if false (* tc_eqv(x,tcc_list) *) then "LST"
+ else (let (* val ntc = case ts of [] => tc
+ | _ => tcc_app(tc, ts) *)
+ val _ = 1
+ in ("DT{" ^ "DATA" (* ^ "[" ^ (tc_print tc)
+ ^ "] &&" ^ (plist(tc_print, ts))
+ ^ "&&" *) ^ "===" ^ (itos i) ^ "}")
+ end)
+ | TC_ABS t => "Ax(" ^ (tc_print t) ^ ")"
+ | TC_BOX t => "Bx(" ^ (tc_print t) ^ ")"
+ | TC_TUPLE(_,zs) => "TT<" ^ (plist(tc_print, zs)) ^ ">"
+ | TC_ARROW (ff,z1,z2) =>
+ parw(fn u => plist(tc_print,u),(ff,z1,z2))
+ | TC_PARROW _ => "<TC_PARROW>"
+ | TC_TOKEN (k, t) =>
+ if token_isvalid k then
+ (token_abbrev k) ^ "(" ^ (tc_print t) ^ ")"
+ else bug "<TC_TOKEN>"
+ | TC_CONT ts => "Cnt(" ^ (plist(tc_print,ts)) ^ ")"
+ | TC_IND _ => "<TC_IND>"
+ | TC_ENV _ => "<TC_ENV>")
+ (* function tc_print *)
+
+ fun lt_print (x : lty) =
+ let fun h (i, t) = "(" ^ (itos i) ^ "," ^ (lt_print t) ^ ")"
+ in case lt_outX x
+ of LT_TYC t => tc_print t
+ | LT_STR zs => "S{" ^ (plist(lt_print, zs)) ^ "}"
+ | LT_FCT (ts1,ts2) =>
+ "(" ^ (plist(lt_print, ts1)) ^ ") ==> ("
+ ^ (plist(lt_print, ts2)) ^ ")"
+ | LT_POLY(ks, ts) =>
+ "(Q[" ^ plist(tk_print, ks) ^ "]." ^ (plist(lt_print,ts)) ^ ")"
+ | LT_CONT ts => "CNT(" ^ (plist(lt_print, ts)) ^ ")"
+ | LT_IND _ => "<LT_IND>"
+ | LT_ENV _ => "<LT_ENV>"
+ end (* function lt_print *)
+
+ end (* local *)
+
+ (***************************************************************************
* UTILITY FUNCTIONS ON TKIND ENVIRONMENT *
***************************************************************************)
***************
*** 685,689 ****
(** utility function to read the top-level of a tyc *)
! and tc_lzrd t =
let fun g x =
(case tc_outX x
--- 775,779 ----
(** utility function to read the top-level of a tyc *)
! and tc_lzrd(t: tyc) =
let fun g x =
(case tc_outX x
***************
*** 707,713 ****
(let val y = List.nth(ts, j)
handle Subscript =>
! (print ("Selecting "^(Int.toString j)^"th elem");
! if length ts = 0 then print " empty list\n" else
! print " length > 0 tyc list\n";
raise tcUnbound)
in h(y, 0, nl - n, initTycEnv)
--- 797,807 ----
(let val y = List.nth(ts, j)
handle Subscript =>
! (print "***Debugging***\n";
! print "tc_lzrd arg: ";
! print(tc_print t); print "\n";
! print ("Selecting: j = "^(Int.toString j)^ "\n");
! print ("ts length: "^(Int.toString(length ts))^"\n");
! print ("ts elements: \n");
! app (fn tc => (print(tc_print tc); print "\n")) ts;
raise tcUnbound)
in h(y, 0, nl - n, initTycEnv)
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV