Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/ltykernel.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/ltykernel.sml

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

revision 1992, Wed Jul 26 15:22:19 2006 UTC revision 1993, Wed Jul 26 18:20:36 2006 UTC
# Line 435  Line 435 
435  fun lt_key (ref (h : int, _ : ltyI, _ : aux_info)) = h  fun lt_key (ref (h : int, _ : ltyI, _ : aux_info)) = h
436    
437  (***************************************************************************  (***************************************************************************
438     *            UTILITY FUNCTIONS FOR PRETTY PRINTING                        *
439     ***************************************************************************)
440    (* DBM: moved from ltybasic.sml *)
441    local
442    
443          val itos = Int.toString
444    
445          fun plist(p, []) = ""
446            | plist(p, x::xs) =
447                (p x) ^ (String.concat (map (fn z => ("," ^ (p z))) xs))
448    
449          fun pfflag (FF_VAR b) =
450                let fun pff (true, true) = "rr"  | pff (true, false) = "rc"
451                      | pff (false, true) = "cr" | pff (false, false) = "cc"
452                 in pff b
453                end
454            | pfflag (FF_FIXED) = "f"
455    
456          fun parw(p, (ff, t1, t2)) =
457                "<" ^ (p t1) ^ "> -" ^ pfflag ff ^ "-> <" ^ (p t2) ^ ">"
458    
459    in
460    
461    (** pretty printing of tkinds, tycs, and ltys *)
462    fun tk_print (x : tkind) =
463      (case tk_outX x
464         of TK_MONO => "K0"
465          | TK_BOX => "KB0"
466          | TK_FUN (ks, k) =>
467              "<" ^ (plist(tk_print, ks)) ^ "->" ^ (tk_print k) ^ ">"
468          | TK_SEQ zs => "KS(" ^ (plist(tk_print, zs)) ^ ")")
469    
470    fun tc_print (x : tyc) =
471      (case tc_outX x
472         of TC_VAR(i,j) => "TV(" ^ (DI.di_print i) ^ "," ^ (itos j) ^ ")"
473          | TC_NVAR v => "NTV(v" ^ (itos v) ^ ")"
474          | TC_PRIM pt => PT.pt_print pt
475          | TC_FN(ks, t) =>
476              "(\\[" ^ plist(tk_print, ks) ^ "]." ^ (tc_print t) ^ ")"
477          | TC_APP(t, []) => tc_print t ^ "[]"
478          | TC_APP(t, zs) =>
479              (tc_print t) ^ "[" ^ (plist(tc_print, zs)) ^ "]"
480          | TC_SEQ zs => "TS(" ^ (plist(tc_print,zs)) ^ ")"
481          | TC_PROJ (t, i) =>
482              "TP(" ^ (tc_print t) ^ "," ^ (itos i) ^ ")"
483          | TC_SUM tcs =>
484              "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"
485          | TC_FIX ((_, tc, ts), i) =>
486              if false (* tc_eqv(x,tcc_bool) *) then "B"
487              else if false (* tc_eqv(x,tcc_list) *) then "LST"
488                   else (let (* val ntc = case ts of [] => tc
489                                                | _ => tcc_app(tc, ts) *)
490                             val _ = 1
491                          in ("DT{" ^ "DATA" (* ^ "[" ^ (tc_print tc)
492                                    ^ "] &&" ^ (plist(tc_print, ts))
493                                          ^ "&&" *) ^ "===" ^ (itos i) ^ "}")
494                         end)
495          | TC_ABS t => "Ax(" ^ (tc_print t) ^ ")"
496          | TC_BOX t => "Bx(" ^ (tc_print t) ^ ")"
497          | TC_TUPLE(_,zs) => "TT<" ^ (plist(tc_print, zs)) ^ ">"
498          | TC_ARROW (ff,z1,z2) =>
499              parw(fn u => plist(tc_print,u),(ff,z1,z2))
500          | TC_PARROW _ => "<TC_PARROW>"
501          | TC_TOKEN (k, t) =>
502              if token_isvalid k then
503                 (token_abbrev k) ^ "(" ^ (tc_print t) ^ ")"
504              else bug "<TC_TOKEN>"
505          | TC_CONT ts => "Cnt(" ^ (plist(tc_print,ts)) ^ ")"
506          | TC_IND _ => "<TC_IND>"
507          | TC_ENV _ => "<TC_ENV>")
508         (* function tc_print *)
509    
510    fun lt_print (x : lty) =
511      let fun h (i, t) = "(" ^ (itos i) ^ "," ^ (lt_print t) ^ ")"
512       in case lt_outX x
513            of LT_TYC t => tc_print t
514             | LT_STR zs => "S{" ^ (plist(lt_print, zs)) ^ "}"
515             | LT_FCT (ts1,ts2) =>
516                 "(" ^ (plist(lt_print, ts1)) ^ ") ==> ("
517                     ^ (plist(lt_print, ts2)) ^ ")"
518             | LT_POLY(ks, ts) =>
519                 "(Q[" ^ plist(tk_print, ks) ^ "]." ^ (plist(lt_print,ts)) ^ ")"
520             | LT_CONT ts => "CNT(" ^ (plist(lt_print, ts)) ^ ")"
521             | LT_IND _ => "<LT_IND>"
522             | LT_ENV _ => "<LT_ENV>"
523      end (* function lt_print *)
524    
525    end (* local *)
526    
527    (***************************************************************************
528   *            UTILITY FUNCTIONS ON TKIND ENVIRONMENT                       *   *            UTILITY FUNCTIONS ON TKIND ENVIRONMENT                       *
529   ***************************************************************************)   ***************************************************************************)
530  (** tkind environment: maps each tyvar, i.e., its debindex, to its kind *)  (** tkind environment: maps each tyvar, i.e., its debindex, to its kind *)
# Line 684  Line 774 
774        end        end
775    
776  (** utility function to read the top-level of a tyc *)  (** utility function to read the top-level of a tyc *)
777  and tc_lzrd t =  and tc_lzrd(t: tyc) =
778    let fun g x =    let fun g x =
779              (case tc_outX x              (case tc_outX x
780                of TC_IND (tc, _) => g tc                of TC_IND (tc, _) => g tc
# Line 706  Line 796 
796                                  | (SOME ts, n) =>                                  | (SOME ts, n) =>
797                                      (let val y = List.nth(ts, j)                                      (let val y = List.nth(ts, j)
798                                             handle Subscript =>                                             handle Subscript =>
799                                                    (print ("Selecting "^(Int.toString j)^"th elem");                      (print "***Debugging***\n";
800                                                     if length ts = 0 then print " empty list\n" else                       print "tc_lzrd arg: ";
801                                                     print " length > 0 tyc list\n";                       print(tc_print t); print "\n";
802                         print ("Selecting: j = "^(Int.toString j)^ "\n");
803                         print ("ts length: "^(Int.toString(length ts))^"\n");
804                         print ("ts elements: \n");
805                         app (fn tc => (print(tc_print tc); print "\n")) ts;
806                                                     raise tcUnbound)                                                     raise tcUnbound)
807                                        in h(y, 0, nl - n, initTycEnv)                                        in h(y, 0, nl - n, initTycEnv)
808                                       end)                                       end)

Legend:
Removed from v.1992  
changed lines
  Added in v.1993

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