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/pplty.sml
ViewVC logotype

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

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

revision 2013, Fri Aug 11 04:09:23 2006 UTC revision 2014, Fri Aug 11 20:42:24 2006 UTC
# Line 6  Line 6 
6   *   *
7   *)   *)
8    
9  structure PPLTy =  structure PPLty =
10  struct  struct
11    
12  local  local
13    
14      structure LK = LtyKernel      structure LK = Lty
15      structure PT = PrimTyc      structure PT = PrimTyc
16      structure PP = PrettyPrintNew      structure PP = PrettyPrintNew
17      open PPUtilNew      open PPUtilNew
18  in  in
19    
20  fun ppList ppstrm {sep, pp : 'a -> unit} list =  fun ppSeq ppstrm {sep: string, pp : PP.stream -> 'a -> unit} (list: 'a list) =
21      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
22      in       in ppSequence ppstrm
         (ppSequence ppstrm  
23                      {sep = fn ppstrm => (PP.string ppstrm sep;                      {sep = fn ppstrm => (PP.string ppstrm sep;
24                                           PP.break ppstrm {nsp=1, offset=0}),                                           PP.break ppstrm {nsp=1, offset=0}),
25                       style = INCONSISTENT,                       style = INCONSISTENT,
26                       pr = (fn _ => fn elem =>              pr = pp}
27                                        (openHOVBox 1;             list
28                                         (* pps "("; *)      end (* ppSeq *)
29                                         pp elem;  
30                                         (* pps ")"; *)  fun ppList ppstrm {sep: string, pp : PP.stream -> 'a -> unit} (list: 'a list) =
31                                         closeBox()))}      ppClosedSequence ppstrm
32                      list)        {front = fn ppstrm => (PP.string ppstrm "["),
33      end (* ppList *)         back = fn ppstrm => (PP.string ppstrm "]"),
34           sep = fn ppstrm => (PP.string ppstrm sep;
35                               PP.break ppstrm {nsp=1, offset=0}),
36           style = INCONSISTENT,
37           pr = pp}
38          list
39    
40  (* ppTKind : tkind -> unit  (* ppTKind : tkind -> unit
41   * Print a hashconsed representation of the kind *)   * Print a hashconsed representation of the kind *)
42  fun ppTKind ppstrm (tk : LK.tkind) =  fun ppTKind pd ppstrm (tk : Lty.tkind) =
43      let val ppTKind' = ppTKind ppstrm      if pd < 1 then pps ppstrm "<tk>" else
44          val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
45            val ppTKind' = ppTKind (pd-1) ppstrm
46          val ppList' = ppList ppstrm          val ppList' = ppList ppstrm
47          fun ppTKindI(LK.TK_MONO) = pps "TK_MONO"          fun ppTKindI(Lty.TK_MONO) = pps "MK"
48            | ppTKindI(LK.TK_BOX) = pps "TK_BOX"            | ppTKindI(Lty.TK_BOX) = pps "BK"
49            | ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =            | ppTKindI(Lty.TK_FUN (argTkinds, resTkind)) =
50                (* res_tkind is a TK_SEQ wrapping some tkinds                (* res_tkind is a TK_SEQ wrapping some tkinds
51                 * These are produced by Elaborate/modules/instantiate.sml                 * These are produced by Elaborate/modules/instantiate.sml
52                 *)                 *)
53               (openHOVBox 1;               (openHOVBox 1;
54                pps "TK_FUN (";                 pps "(";
55                ppList' {sep="* ", pp=ppTKind'} argTkinds;                 ppList' {sep=",", pp=ppTKind (pd-1)} argTkinds;
56                ppTKind' resTkind;                 pps "=>"; ppTKind' resTkind;
57                pps ")";                pps ")";
58                closeBox())                closeBox())
59            | ppTKindI(LK.TK_SEQ tkinds) =            | ppTKindI(Lty.TK_SEQ tkinds) =
60              (openHOVBox 1;              (openHOVBox 1;
61               pps "TK_SEQ(";                 pps "SK";
62               ppList' {sep=", ", pp=ppTKind'} tkinds;                 ppList' {sep=",", pp=ppTKind (pd-1)} tkinds;
              pps ")";  
63               closeBox())               closeBox())
64      in ppTKindI (LK.tk_out tk)       in ppTKindI (Lty.tk_outX tk)
65      end (* ppTKind *)      end (* ppTKind *)
66    
67  fun tycEnvFlatten(tycenv) =  fun tycEnvFlatten(tycenv) =
68      (print "flatten";      (case Lty.tcSplit(tycenv)
69       (case LK.tcSplit(tycenv) of         of NONE => []
70           NONE => []          | SOME(elem, rest) => elem::tycEnvFlatten(rest))
71         | SOME(elem, rest) => elem::tycEnvFlatten(rest)))  
72    fun ppTycEnvElem pd ppstrm ((tycop,i): Lty.tycEnvElem) =
73  fun ppTycEnvElem ppstrm (tycop, i) =      if pd < 1 then pps ppstrm "<tee>" else
74      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm      let val {openHOVBox, closeBox, pps, ppi, ...} = en_pp ppstrm
75      in      in openHOVBox 1;
76          openHOVBox 1;          pps "(";
77          (* pps "("; *)          (case tycop
78          (case tycop of             of NONE => pps "*"
79               NONE => pps "*"              | SOME(tycs) => ppList ppstrm {sep=",", pp=ppTyc (pd-1)} tycs);
            | SOME(tycs) => ppList ppstrm {sep=",", pp=ppTyc ppstrm} tycs);  
80          pps ", ";          pps ", ";
81          PP.break ppstrm {nsp = 1, offset=0};          ppi i;
82          ppi ppstrm i;          pps ")";
         (* pps ")"; *)  
83          closeBox()          closeBox()
84      end (* function ppTycEnvElem *)      end (* function ppTycEnvElem *)
85    
86  and ppTyc ppstrm (tycon : LK.tyc) =  and ppTyc pd ppstrm (tycon : Lty.tyc) =
87      (* FLINT variables are represented using deBruijn indices *)      (* FLINT variables are represented using deBruijn indices *)
88      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm      if pd < 1 then pps ppstrm "<tyc>" else
89                                                 (* eta-expansion of ppList to avoid      let val {openHOVBox, openHVBox, closeBox, pps, ppi, ...} = en_pp ppstrm
90                                                    value restriction *)          val ppList' : {pp:PP.stream -> 'a -> unit, sep: string} -> 'a list -> unit =
91          val ppList' : {pp:'a -> unit, sep: string} -> 'a list -> unit = fn x => ppList ppstrm x                fn x => ppList ppstrm x
92          val ppTKind' = ppTKind ppstrm                 (* eta-expansion of ppList to avoid value restriction *)
93          val ppTyc' = ppTyc ppstrm  
94          fun ppTycI (LK.TC_VAR(depth, cnt)) =          val ppTKind' = ppTKind (pd-1) ppstrm
95              (pps "TC_VAR(";          val ppTyc' = ppTyc (pd-1) ppstrm
96               PP.break ppstrm {nsp=1,offset=1};  
97            fun ppTycI (Lty.TC_VAR(depth, cnt)) =
98                (pps "TV(";
99               (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)               (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
100               pps (DebIndex.di_print depth);               pps (DebIndex.di_print depth);
101               pps ",";               pps ",";
              PP.break ppstrm {nsp=1,offset=0};  
102               (* cnt is computed in instantiate.sml sigToInst or               (* cnt is computed in instantiate.sml sigToInst or
103                  alternatively may be simply the IBOUND index *)                  alternatively may be simply the IBOUND index *)
104               pps (Int.toString cnt);               ppi cnt;
105               pps ")")               pps ")")
106            (* Named tyc VAR; is actually an lvar *)            (* Named tyc VAR; is actually an lvar *)
107            | ppTycI (LK.TC_NVAR tvar) =            | ppTycI (Lty.TC_NVAR tvar) =
108              (pps "TC_NVAR(";              (pps "NTV:"; ppi tvar)
109               PP.break ppstrm {nsp=1,offset=1};            | ppTycI (Lty.TC_PRIM primtycon) =
110               pps (Int.toString tvar);              (pps "PRIM(";
              pps ")")  
           | ppTycI (LK.TC_PRIM primtycon) =  
             (pps "TC_PRIM(";  
              PP.break ppstrm {nsp=1,offset=0};  
111               pps (PT.pt_print primtycon);               pps (PT.pt_print primtycon);
112               pps ")")               pps ")")
113            | ppTycI (LK.TC_FN (argTkinds, resultTyc)) =            | ppTycI (Lty.TC_FN (argTkinds, resultTyc)) =
114              (openHOVBox 1;              (openHOVBox 1;
115               pps "TC_FN(";               pps "FN(";
116               PP.break ppstrm {nsp=1,offset=1};               ppList' {sep="*", pp=ppTKind (pd-1)} argTkinds;
              ppList' {sep="* ", pp=ppTKind'} argTkinds;  
117               pps ",";               pps ",";
118               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
119               ppTyc' resultTyc;               ppTyc' resultTyc;
120               pps ")";               pps ")";
121               closeBox())               closeBox())
122            | ppTycI (LK.TC_APP(contyc, tys)) =            | ppTycI (Lty.TC_APP(contyc, tys)) =
123              (openHOVBox 1;              (openHOVBox 1;
124               pps "TC_APP(";               pps "APP(";
              PP.break ppstrm {nsp=1,offset=1};  
125               ppTyc' contyc;               ppTyc' contyc;
126               pps ",";               pps ",";
127               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
128               ppList' {sep="* ", pp=ppTyc'} tys;               ppList' {sep=",", pp=ppTyc (pd-1)} tys;
129               pps ")";               pps ")";
130               closeBox())               closeBox())
131            | ppTycI (LK.TC_SEQ tycs) =            | ppTycI (Lty.TC_SEQ tycs) =
132              (openHOVBox 1;              (openHOVBox 1;
133               pps "TC_SEQ(";               pps "SEQ(";
134               PP.break ppstrm {nsp=1,offset=1};               ppList' {sep=",", pp=ppTyc (pd-1)} tycs;
              ppList' {sep=", ", pp=ppTyc'} tycs;  
135               pps ")";               pps ")";
136               closeBox())               closeBox())
137            | ppTycI (LK.TC_PROJ(tycon, index)) =            | ppTycI (Lty.TC_PROJ(tycon, index)) =
138              (openHOVBox 1;              (openHOVBox 1;
139               pps "TC_PROJ(";               pps "PROJ(";
              PP.break ppstrm {nsp=1,offset=1};  
140               ppTyc' tycon;               ppTyc' tycon;
141               pps ", ";               pps ", ";
142               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
143               pps (Int.toString index);               pps (Int.toString index);
144               pps ")";               pps ")";
145               closeBox())               closeBox())
146            | ppTycI (LK.TC_SUM(tycs)) =            | ppTycI (Lty.TC_SUM(tycs)) =
147              (pps "TC_SUM(";              (pps "SUM(";
148               PP.break ppstrm {nsp=1,offset=1};               ppList' {sep=",", pp=ppTyc (pd-1)} tycs;
              ppList' {sep=", ", pp=ppTyc'} tycs;  
149               pps ")")               pps ")")
150              (* TC_FIX is a recursive datatype constructor              (* TC_FIX is a recursive datatype constructor
151                 from a (mutually-)recursive family *)                 from a (mutually-)recursive family *)
152            | ppTycI (LK.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =            | ppTycI (Lty.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =
153              (openHOVBox 1;              (openHOVBox 1;
154               pps "TC_FIX(";               pps "FIX(";
155               PP.break ppstrm {nsp=1,offset=1};               (case (Lty.tc_outX datatypeFamily) of
156               print "LK.tc_out";                    Lty.TC_FN(params, rectyc) => (* generator function *)
              (case (LK.tc_out datatypeFamily) of  
                   LK.TC_FN(params, rectyc) => (* generator function *)  
157                    let fun ppMus 0 = ()                    let fun ppMus 0 = ()
158                          | ppMus i = (pps "mu";                          | ppMus i = (pps "mu";
159                                       ppi ppstrm i;                                       ppi i;
160                                       pps " ";                                       pps " ";
161                                       ppMus (i - 1))                                       ppMus (i - 1))
162                    in                    in
163                    (pps "RECTYCGEN(";                    (pps "REC(";
164                     if (length params) > 0 then (pps "[";                     if (length params) > 0 then (pps "[";
165                                                  ppMus (length params);                                                  ppi (length params);
166                                                  pps "]")                                                  pps "]")
167                     else ();                     else ();
168                     PP.break ppstrm {nsp=1,offset=1};                     PP.break ppstrm {nsp=1,offset=1};
169                     print "LK.tc_out";                    (case (Lty.tc_outX rectyc) of
170                    (case (LK.tc_out rectyc) of                           (rectycI as Lty.TC_FN _) => ppTycI rectycI
171                           (rectycI as LK.TC_FN _) => ppTycI rectycI                         | Lty.TC_SEQ(dconstycs) =>
                        | LK.TC_SEQ(dconstycs) =>  
172                           ppTyc' (List.nth(dconstycs, index))                           ppTyc' (List.nth(dconstycs, index))
173                         | tycI => ppTycI tycI);                         | tycI => ppTycI tycI);
174                    PP.break ppstrm {nsp=0,offset=0};                    PP.break ppstrm {nsp=0,offset=0};
# Line 198  Line 189 
189               pps ", ";               pps ", ";
190               PP.break ppstrm {nsp=1, offset=0};               PP.break ppstrm {nsp=1, offset=0};
191               pps "freeTycs = ";               pps "freeTycs = ";
192               ppList' {sep = ", ", pp = ppTyc'} freetycs;               ppList' {sep = ", ", pp = ppTyc} freetycs;
193               pps ", ";               pps ", ";
194               PP.break ppstrm {nsp=1, offset=0};               PP.break ppstrm {nsp=1, offset=0};
195               pps "index = ";               pps "index = ";
196               pps (Int.toString index);               pps (Int.toString index);
197               pps ")";               pps ")";
198               closeBox() *) )               closeBox() *) )
199            | ppTycI (LK.TC_ABS tyc) =            | ppTycI (Lty.TC_ABS tyc) =
200              (pps "TC_ABS(";              (pps "ABS(";
              PP.break ppstrm {nsp=1,offset=1};  
201               ppTyc' tyc;               ppTyc' tyc;
202               pps ")")               pps ")")
203            | ppTycI (LK.TC_BOX tyc) =            | ppTycI (Lty.TC_BOX tyc) =
204              (pps "TC_BOX(";              (pps "BOX(";
              PP.break ppstrm {nsp=1,offset=1};  
205               ppTyc' tyc;               ppTyc' tyc;
206               pps ")")               pps ")")
207              (* rflag is a tuple kind template, a singleton datatype RF_TMP *)              (* rflag is a tuple kind template, a singleton datatype RF_TMP *)
208            | ppTycI (LK.TC_TUPLE (rflag, tycs)) =            | ppTycI (Lty.TC_TUPLE(rflag, tycs)) =
209              (case tycs of              (ppClosedSequence ppstrm
210                   [] => pps "UNIT"                  {front = (fn s => PP.string s "{"),
211                 | _ => (pps "TC_TUPLE(";                   sep =  (fn s => PP.string s ","),
212                         PP.break ppstrm {nsp=1,offset=1};                   back =  (fn s => PP.string s "}"),
213                         ppList' {sep="* ", pp=ppTyc'} tycs;                   pr = ppTyc (pd-1),
214                         pps ")"))                   style = INCONSISTENT}
215                    tycs)
216              (* fflag records the calling convention: either FF_FIXED or FF_VAR *)              (* fflag records the calling convention: either FF_FIXED or FF_VAR *)
217            | ppTycI (LK.TC_ARROW (fflag, argTycs, resTycs)) =            | ppTycI (Lty.TC_ARROW (fflag, argTycs, resTycs)) =
218              (pps "TC_ARROW(";              (pps "ARR(";
219               PP.break ppstrm {nsp=1,offset=1};               (case fflag of Lty.FF_FIXED => pps "FF_FIXED"
220               (case fflag of LK.FF_FIXED => pps "FF_FIXED"                            | Lty.FF_VAR(b1, b2) =>
221                            | LK.FF_VAR(b1, b2) => (pps "<FF_VAR>" (*;                                (pps "<FF_VAR>" (*; ppBool b1; pps ",";
222                                                     ppBool b1;                                                    ppBool b2; pps ")"*) ));
223                                                    pps ", ";                                                    pps ", ";
224                                                    ppBool b2;               PP.break ppstrm {nsp=1,offset=0};
225                                                    pps ")"*) ));               ppList' {sep=",", pp=ppTyc (pd-1)} argTycs;
              ppList' {sep="* ", pp=ppTyc'} argTycs;  
226               pps ", ";               pps ", ";
227               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
228               ppList' {sep="* ", pp=ppTyc'} resTycs;               ppList' {sep=",", pp=ppTyc (pd-1)} resTycs;
229               pps ")")               pps ")")
230              (* According to ltykernel.sml comment, this arrow tyc is not used *)              (* According to ltykernel.sml comment, this arrow tyc is not used *)
231            | ppTycI (LK.TC_PARROW (argTyc, resTyc)) =            | ppTycI (Lty.TC_PARROW (argTyc, resTyc)) =
232              (pps "TC_PARROW(";              (pps "PARR(";
              PP.break ppstrm {nsp=1,offset=1};  
233               ppTyc' argTyc;               ppTyc' argTyc;
234               pps ", ";               pps ", ";
235               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
236               ppTyc' resTyc;               ppTyc' resTyc;
237               pps ")")               pps ")")
238            | ppTycI (LK.TC_TOKEN (tok, tyc)) =            | ppTycI (Lty.TC_TOKEN (tok, tyc)) =
239              (pps "TC_TOKEN(";              (pps "TOK(";
240               PP.break ppstrm {nsp=1,offset=1};               pps (Lty.token_name tok);
              print "LK.token_name\n";  
              pps (LK.token_name tok);  
241               pps ", ";               pps ", ";
242               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
243               ppTyc' tyc;               ppTyc' tyc;
244               pps ")")               pps ")")
245            | ppTycI (LK.TC_CONT tycs) =            | ppTycI (Lty.TC_CONT tycs) =
246              (pps "TC_CONT(";              (pps "CONT(";
247               PP.break ppstrm {nsp=1,offset=1};               ppList' {sep=", ", pp=ppTyc (pd-1)} tycs;
              ppList' {sep=", ", pp=ppTyc'} tycs;  
248               pps ")")               pps ")")
249            | ppTycI (LK.TC_IND (tyc, tycI)) =            | ppTycI (Lty.TC_IND (tyc, tycI)) =
250              (openHOVBox 1;              (openHOVBox 1;
251               pps "TC_IND(";               pps "IND(";
              PP.break ppstrm {nsp=1,offset=1};  
252               ppTyc' tyc;               ppTyc' tyc;
253               pps ", ";               pps ", ";
254               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
255               ppTycI tycI;               ppTycI tycI;
256               pps ")";               pps ")";
257               closeBox())               closeBox())
258            | ppTycI (LK.TC_ENV (tyc, ol, nl, tenv)) =            | ppTycI (Lty.TC_ENV (tyc, ol, nl, tenv)) =
259              (openHOVBox 1;              (openHVBox 1;
260               pps "TC_ENV(";               pps "ENV(";
              PP.break ppstrm {nsp=1,offset=1};  
              ppTyc' tyc;  
              pps ", ";  
              PP.break ppstrm {nsp=1,offset=0};  
261               pps "ol = ";               pps "ol = ";
262               pps (Int.toString ol);               pps (Int.toString ol);
263               pps ", ";               pps ", ";
# Line 285  Line 265 
265               pps (Int.toString nl);               pps (Int.toString nl);
266               pps ", ";               pps ", ";
267               PP.break ppstrm {nsp=1,offset=0};               PP.break ppstrm {nsp=1,offset=0};
268               ppList' {sep=", ", pp=(ppTycEnvElem ppstrm)} (tycEnvFlatten tenv);               ppTyc' tyc;
269                 pps ",";
270                 PP.break ppstrm {nsp=1,offset=0};
271                 ppList' {sep=",", pp=ppTycEnvElem (pd-1)} (tycEnvFlatten tenv);
272               closeBox())               closeBox())
273      val _ = print "LK.tc_out 1 \n"      in ppTycI (Lty.tc_outX tycon)
     in ppTycI (LK.tc_out tycon)  
274      end (* ppTyc *)      end (* ppTyc *)
275    
276  fun ppTycEnv ppstrm (tycEnv : LK.tycEnv) =  fun ppTycEnv pd ppstrm (tycEnv : Lty.tycEnv) =
277        if pd < 1 then pps ppstrm "<tycEnv>" else
278      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
279      in       in openHOVBox 1;
         openHOVBox 1;  
280          pps "TycEnv(";          pps "TycEnv(";
281          ppList ppstrm {sep=", ", pp=ppTycEnvElem ppstrm} (tycEnvFlatten tycEnv);           ppList ppstrm {sep=", ", pp=ppTycEnvElem (pd-1)} (tycEnvFlatten tycEnv);
282          pps ")";          pps ")";
283          closeBox()          closeBox()
284      end (* function ppTycEnv *)      end (* ppTycEnv *)
285    
286  end (* local *)  end (* local *)
287    
288  end  end (* structure PPLty *)

Legend:
Removed from v.2013  
changed lines
  Added in v.2014

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