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-3/compiler/Elaborator/print/ppmod.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/Elaborator/print/ppmod.sml

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

sml/trunk/src/compiler/Elaborator/print/ppmod.sml revision 1344, Wed Aug 13 18:04:08 2003 UTC sml/branches/primop-branch-3/compiler/Elaborator/print/ppmod.sml revision 3344, Fri May 15 12:52:07 2009 UTC
# Line 6  Line 6 
6    
7  signature PPMOD =  signature PPMOD =
8  sig  sig
9    val ppSignature: PrettyPrint.stream    val ppSignature: PrettyPrintNew.stream
10          -> Modules.Signature * StaticEnv.staticEnv * int -> unit          -> Modules.Signature * StaticEnv.staticEnv * int -> unit
11    val ppStructure: PrettyPrint.stream    val ppStructure: PrettyPrintNew.stream
12          -> Modules.Structure * StaticEnv.staticEnv * int -> unit          -> Modules.Structure * StaticEnv.staticEnv * int -> unit
13    val ppOpen: PrettyPrint.stream    val ppOpen: PrettyPrintNew.stream
14          -> SymPath.path * Modules.Structure * StaticEnv.staticEnv * int -> unit          -> SymPath.path * Modules.Structure * StaticEnv.staticEnv * int -> unit
15    val ppStructureName : PrettyPrint.stream    val ppStructureName : PrettyPrintNew.stream
16          -> Modules.Structure * StaticEnv.staticEnv -> unit          -> Modules.Structure * StaticEnv.staticEnv -> unit
17    val ppFunctor : PrettyPrint.stream    val ppFunctor : PrettyPrintNew.stream
18          -> Modules.Functor * StaticEnv.staticEnv * int -> unit          -> Modules.Functor * StaticEnv.staticEnv * int -> unit
19    val ppFunsig : PrettyPrint.stream    val ppFunsig : PrettyPrintNew.stream
20          -> Modules.fctSig * StaticEnv.staticEnv * int -> unit          -> Modules.fctSig * StaticEnv.staticEnv * int -> unit
21    val ppBinding: PrettyPrint.stream    val ppBinding: PrettyPrintNew.stream
22          -> Symbol.symbol * Bindings.binding * StaticEnv.staticEnv * int          -> Symbol.symbol * Bindings.binding * StaticEnv.staticEnv * int
23               -> unit               -> unit
24    val ppEnv : PrettyPrint.stream    val ppEnv : PrettyPrintNew.stream
25                -> StaticEnv.staticEnv * StaticEnv.staticEnv * int *                -> StaticEnv.staticEnv * StaticEnv.staticEnv * int *
26                   Symbol.symbol list option                   Symbol.symbol list option
27                -> unit                -> unit
# Line 29  Line 29 
29    (* module internals *)    (* module internals *)
30    
31    val ppElements : (StaticEnv.staticEnv * int * Modules.entityEnv option)    val ppElements : (StaticEnv.staticEnv * int * Modules.entityEnv option)
32                     -> PrettyPrint.stream                     -> PrettyPrintNew.stream
33                     -> Modules.elements -> unit                     -> Modules.elements -> unit
34    
35    val ppEntity : PrettyPrint.stream    val ppEntity : PrettyPrintNew.stream
36                   -> Modules.entity * StaticEnv.staticEnv * int                   -> Modules.entity * StaticEnv.staticEnv * int
37                   -> unit                   -> unit
38    
39    val ppEntityEnv : PrettyPrint.stream    val ppEntityEnv : PrettyPrintNew.stream
40                      -> Modules.entityEnv * StaticEnv.staticEnv * int                      -> Modules.entityEnv * StaticEnv.staticEnv * int
41                      -> unit                      -> unit
42    
43      val ppEPC : PrettyPrintNew.stream
44                  -> EntPathContext.context * int
45                  -> unit
46    
47  end (* signature PPMOD *)  end (* signature PPMOD *)
48    
49    
# Line 62  Line 66 
66        structure EE = EntityEnv        structure EE = EntityEnv
67        structure LU = Lookup        structure LU = Lookup
68    
69        structure PP = PrettyPrint        structure PP = PrettyPrintNew
70        open PrettyPrint PPUtil        structure PU = PPUtilNew
71          open PrettyPrintNew PPUtilNew
72    
73  in  in
74    
# Line 90  Line 95 
95                    let val strEnt = EE.lookStrEnt(entities,entVar)                    let val strEnt = EE.lookStrEnt(entities,entVar)
96                     in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,                     in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,
97                                                    access=A.nullAcc,                                                    access=A.nullAcc,
98                                                    info=II.Null}),                                                    prim=[]}),
99                                env)                                env)
100                    end                    end
101                 | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)                 | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
# Line 102  Line 107 
107  fun sigToEnv(M.SIG {elements,...}) =  fun sigToEnv(M.SIG {elements,...}) =
108      let fun bindElem ((sym,spec), env) =      let fun bindElem ((sym,spec), env) =
109            (case spec            (case spec
110              of M.TYCspec{spec,...} => SE.bind(sym,B.TYCbind spec,env)              of M.TYCspec{info=M.RegTycSpec{spec,...},...} =>
111                    SE.bind(sym,B.TYCbind spec,env)
112                 | M.TYCspec{info=M.InfTycSpec{name,arity},...} =>
113                    let val tyc =
114                            T.GENtyc{stamp=Stamps.special "x", arity=arity,
115                                     eq=ref(T.UNDEF), kind=T.FORMAL, stub=NONE,
116                                     path=InvPath.extend(InvPath.empty,name)}
117                    in SE.bind(sym,B.TYCbind tyc,env)
118                    end
119               | M.STRspec{sign,slot,def,entVar=ev} =>               | M.STRspec{sign,slot,def,entVar=ev} =>
120                   SE.bind(sym,B.STRbind(M.STRSIG{sign=sign,entPath=[ev]}),env)                   SE.bind(sym,B.STRbind(M.STRSIG{sign=sign,entPath=[ev]}),env)
121               | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)               | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
# Line 123  Line 136 
136                   in (TU.equalTycon                   in (TU.equalTycon
137                        (LU.lookTyc                        (LU.lookTyc
138                           (env,                           (env,
139                            SP.SPATH[IP.last(TU.tycPath tyc)],                            SP.SPATH[IP.last(TU.tycPath tyc) handle InvPath.InvPath => bug "ppmod:is_ppable_Consbinding"],
140                            fn _ => raise Hidden),                            fn _ => raise Hidden),
141                         tyc)                         tyc)
142                         handle Hidden => false)                         handle Hidden => false)
# Line 152  Line 165 
165         pr=ppEntVar}         pr=ppEntVar}
166  *)  *)
167    
168    local
169       open EntPathContext
170    in
171    fun ppEPC ppstrm (context, d) =
172        (case context
173          of EMPTY => pps ppstrm "[<empty>]"
174           | LAYER{locals, context, outer} =>
175               (pps ppstrm "[LAYER ";
176                ppEntPath ppstrm context;
177                ppEPC ppstrm (outer, d);
178                pps ppstrm "]"))
179    end
180    
181  fun ppTycExp ppstrm (tycExp,depth) =  fun ppTycExp ppstrm (tycExp,depth) =
182      if depth <= 0 then pps ppstrm "<tycExp>" else      if depth <= 0 then pps ppstrm "<tycExp>" else
183      case tycExp      case tycExp
# Line 179  Line 205 
205    
206  fun ppVariable ppstrm  =  fun ppVariable ppstrm  =
207      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
208          fun ppV(V.VALvar{path,access,typ,info},env:StaticEnv.staticEnv) =          fun ppV(V.VALvar{path,access,typ,prim,btvs},env:StaticEnv.staticEnv) =
209                (openHVBox 0;                (openHVBox 0;
210                 pps (SP.toString path);                 pps (SP.toString path);
211                 if !internals then PPVal.ppAccess ppstrm access else ();                 if !internals then PPVal.ppAccess ppstrm access else ();
# Line 190  Line 216 
216                 ppSym ppstrm (name); pps " : "; ppType env ppstrm body;                 ppSym ppstrm (name); pps " : "; ppType env ppstrm body;
217                 pps " as ";                 pps " as ";
218                 ppSequence ppstrm                 ppSequence ppstrm
219                   {sep=C PrettyPrint.break{nsp=1,offset=0},                   {sep=C PrettyPrintNew.break{nsp=1,offset=0},
220                    pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),                    pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),
221                    style=CONSISTENT}                    style=CONSISTENT}
222                   optl;                   optl;
# Line 219  Line 245 
245      end      end
246    
247  fun ppStructure ppstrm (str,env,depth) =  fun ppStructure ppstrm (str,env,depth) =
248      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
249       in case str       in case str
250            of M.STR { sign, rlzn as { entities, ... }, ... } =>            of M.STR { sign, rlzn as { entities, ... }, prim, ... } =>
251               (if !internals               (if !internals
252                then (openHVBox 2;                then (openHVBox 2;
253                         pps "STR";                         pps "STR";
# Line 234  Line 260 
260                          pps "rlzn:";                          pps "rlzn:";
261                          break {nsp=1,offset=2};                          break {nsp=1,offset=2};
262                          ppStrEntity ppstrm (rlzn,env,depth-1);                          ppStrEntity ppstrm (rlzn,env,depth-1);
263                            newline();
264                            pps "prim:";
265                            break {nsp=1,offset=2};
266                            PPPrim.ppStrPrimInfo ppstrm prim;
267                         closeBox();                         closeBox();
268                        closeBox())                        closeBox())
269                  else case sign                  else case sign
# Line 299  Line 329 
329                     closeBox ppstrm;                     closeBox ppstrm;
330                    closeBox ppstrm)                    closeBox ppstrm)
331    
332                | M.TYCspec{spec,entVar,repl,scope} =>                | M.TYCspec{entVar,info} =>
333                   (if first then () else newline ppstrm;                   (if first then () else newline ppstrm;
334                    openHVBox ppstrm (PP.Rel 0);                    case info
335                        of M.RegTycSpec{spec,repl,scope} =>
336                           (openHVBox ppstrm (PP.Rel 0);
337                     case entityEnvOp                     case entityEnvOp
338                       of NONE =>                       of NONE =>
339                           if repl then                           if repl then
# Line 324  Line 356 
356                           pps ppstrm (Int.toString scope))                           pps ppstrm (Int.toString scope))
357                     else ();                     else ();
358                    closeBox ppstrm)                    closeBox ppstrm)
359                         | M.InfTycSpec{name,arity} =>
360                           (openHVBox ppstrm (PP.Rel 0);
361                             case entityEnvOp
362                               of NONE =>
363                                   (pps ppstrm "type";
364                                    ppFormals ppstrm arity;
365                                    pps ppstrm " ";
366                                    ppSym ppstrm name)
367                                | SOME eenv =>
368                                   (case EE.look(eenv,entVar)
369                                      of M.TYCent tyc =>
370                                           ppTycBind ppstrm (tyc,env)
371                                       | M.ERRORent => pps ppstrm "<ERRORent>"
372                                       | _ => bug "ppElements:TYCent");
373                             if !internals
374                             then (newline ppstrm;
375                                   pps ppstrm "entVar: ";
376                                   pps ppstrm (EntPath.entVarToString entVar))
377                             else ();
378                            closeBox ppstrm))
379    
380                | M.VALspec{spec=typ,...} =>                | M.VALspec{spec=typ,...} =>
381                   (if first then () else newline ppstrm;                   (if first then () else newline ppstrm;
# Line 341  Line 393 
393                   if !internals                   if !internals
394                   then (if first then () else newline ppstrm;                   then (if first then () else newline ppstrm;
395                         ppConBinding ppstrm (dcon,env))                         ppConBinding ppstrm (dcon,env))
396                   else () (* ordinary data constructor, don't print *)                   else () (* don't pring ordinary data constructor,
397                              * because it was printed with its datatype *)
398    
399       in openHVBox ppstrm (PP.Rel 0);       in openHVBox ppstrm (PP.Rel 0);
400          case elements          case elements
# Line 351  Line 404 
404      end      end
405    
406  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =
407      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
408                en_pp ppstrm
409          val env = SE.atop(case entityEnvOp          val env = SE.atop(case entityEnvOp
410                              of NONE => sigToEnv sign                              of NONE => sigToEnv sign
411                               | SOME entEnv => strToEnv(sign,entEnv),                               | SOME entEnv => strToEnv(sign,entEnv),
# Line 371  Line 425 
425                         closeBox()))                         closeBox()))
426                    constraints;                    constraints;
427                  closeBox ())                  closeBox ())
428          val somePrint = ref false          val somePrint = ref false (* i.e., signature is not empty sig end *)
429       in if depth <= 0       in if depth <= 0
430          then pps "<sig>"          then pps "<sig>"
431          else          else
432          case sign          case sign
433            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>
434                 let
435                     (* Filter out ordinary dcon that do not print in ppElements
436                        for element printing so that we do not print the spurious
437                        newline. We still use the unfiltered elements
438                        for determining whether the sig ... end should be
439                        multiline even with just one datatype. *)
440                    val elems' =
441                        List.filter
442                        (fn (_,M.CONspec{spec=T.DATACON{rep=A.EXN _,...},...})
443                                => true
444                          | (_,M.CONspec{spec=dcon,...}) => false
445                          | _ => true)
446                        elements
447                 in
448               if !internals then               if !internals then
449                 (openHVBox 0;                 (openHVBox 0;
450                   pps "SIG:";                   pps "SIG:";
# Line 408  Line 476 
476                else (* not !internals *)                else (* not !internals *)
477                  (openHVBox 0;                  (openHVBox 0;
478                    pps "sig";                    pps "sig";
479                    break{nsp=1,offset=2};                    (case elements
480                           of nil => pps " "
481                            | [(_,M.STRspec _)] => nl_indent ppstrm 2
482                            | [_] => pps " "
483                            | _ => nl_indent ppstrm 2);
484                    openHVBox 0;                    openHVBox 0;
485                     case elements                     case elements
486                       of nil => ()                       of nil => ()
487                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elements;                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elems';
488                                somePrint := true);                                somePrint := true);
489                     case strsharing                     case strsharing
490                       of nil => ()                       of nil => ()
# Line 425  Line 497 
497                                ppConstraints("type ",typsharing);                                ppConstraints("type ",typsharing);
498                                somePrint := true);                                somePrint := true);
499                    closeBox();                    closeBox();
500                    if !somePrint then break{nsp=1,offset=0} else ();                    (case elements
501                        of nil => ()
502                         | [(_,M.STRspec _)] => newline()
503                         | [_] => pps " "
504                         | _ => newline());
505                    pps "end";                    pps "end";
506                   closeBox())                   closeBox())
507                 end
508             | M.ERRORsig => pps "<error sig>"             | M.ERRORsig => pps "<error sig>"
509      end      end
510    
511  and ppFunsig ppstrm (sign,env,depth) =  and ppFunsig ppstrm (sign,env,depth) =
512      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
513                en_pp ppstrm
514          fun trueBodySig (orig as M.SIG { elements =          fun trueBodySig (orig as M.SIG { elements =
515                                           [(sym, M.STRspec { sign, ... })],                                           [(sym, M.STRspec { sign, ... })],
516                                           ... }) =                                           ... }) =
# Line 476  Line 554 
554                  | M.ERRORfsig => pps "<error fsig>"                  | M.ERRORfsig => pps "<error fsig>"
555      end      end
556    
   
557  and ppStrEntity ppstrm (e,env,depth) =  and ppStrEntity ppstrm (e,env,depth) =
558      let val {stamp,entities,properties,rpath,stub} = e      let val {stamp,entities,rpath,stub,properties} = e
559          val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
560                en_pp ppstrm
561       in if depth <= 1       in if depth <= 1
562          then pps "<structure entity>"          then pps "<structure entity>"
563          else (openHVBox 0;          else (openHVBox 0;
# Line 495  Line 573 
573                  pps "entities:";                  pps "entities:";
574                  nl_indent ppstrm 2;                  nl_indent ppstrm 2;
575                  ppEntityEnv ppstrm (entities,env,depth-1);                  ppEntityEnv ppstrm (entities,env,depth-1);
                 newline();  
                 pps "lambdaty:";  
                 nl_indent ppstrm 2;  
                 ppLty ppstrm ( (* ModulePropLists.strEntityLty e,depth-1 *));  
576                 closeBox ();                 closeBox ();
577                closeBox ())                closeBox ())
578      end      end
579    
580  and ppFctEntity ppstrm (e, env, depth) =  and ppFctEntity ppstrm (e, env, depth) =
581      let val {stamp,closure,properties,tycpath,rpath,stub} = e      let val {stamp,paramRlzn,closure,rpath,stub,properties,...} = e
582          val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm          val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
583      in if depth <= 1      in if depth <= 1
584          then pps "<functor entity>"          then pps "<functor entity>"
585          else (openHVBox 0;          else (openHVBox 0;
# Line 518  Line 592 
592                  pps "stamp: ";                  pps "stamp: ";
593                  pps (Stamps.toShortString stamp);                  pps (Stamps.toShortString stamp);
594                  newline();                  newline();
595                (*     pps "primaries: ";
596                  ppSequence ppstrm
597                             {sep=(fn ppstrm =>
598                                      (pps ", "; break{nsp=1,offset=0})),
599                              pr=fn ppstrm => fn s =>
600                                    let val {pps,...} = en_pp ppstrm
601                                    in pps (Stamps.toShortString s)
602                                    end,
603                              style=INCONSISTENT}
604                             primaries; *)
605                    newline();
606                    pps "paramRlzn: ";
607                    break{nsp=1,offset=2};
608                    ppStrEntity ppstrm (paramRlzn,env,depth-1);
609                    newline();
610                  pps "closure:";                  pps "closure:";
611                  break{nsp=1,offset=2};                  break{nsp=1,offset=2};
612                  ppClosure ppstrm (closure,depth-1);                  ppClosure ppstrm (closure,depth-1);
613                  newline();                  newline();
                 pps "lambdaty:";  
                 break{nsp=1,offset=2};  
                 ppLty ppstrm ( (* ModulePropLists.fctEntityLty e,depth-1 *) );  
                 pps "tycpath:";  
                 break{nsp=1,offset=2};  
                 pps "--printing of tycpath not implemented yet--";  
614                 closeBox ();                 closeBox ();
615                closeBox ())                closeBox ())
616      end      end
617    
618  and ppFunctor ppstrm =  and ppFunctor ppstrm =
619      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
620          fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =          fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =
621                  if depth <= 1                  if depth <= 1
622                  then pps "<functor>"                  then pps "<functor>"
# Line 551  Line 634 
634      end      end
635    
636  and ppTycBind ppstrm (tyc,env) =  and ppTycBind ppstrm (tyc,env) =
637      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
638          fun visibleDcons(tyc,dcons) =          fun visibleDcons(tyc,dcons) =
639              let fun checkCON(V.CON c) = c              let fun checkCON(V.CON c) = c
640                    | checkCON _ = raise SE.Unbound                    | checkCON _ = raise SE.Unbound
# Line 615  Line 698 
698                        pps "type";                        pps "type";
699                        ppFormals ppstrm arity;                        ppFormals ppstrm arity;
700                        pps " ";                        pps " ";
701                        ppSym ppstrm (IP.last path);                        ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppTycBind");
702                        closeBox())                        closeBox())
703                     | (_, T.DATATYPE{index,family={members,...},...}) =>                     | (_, T.DATATYPE{index,family={members,...},...}) =>
704                       (* ordinary datatype *)                       (* ordinary datatype *)
# Line 627  Line 710 
710                           pps "datatype";                           pps "datatype";
711                           ppFormals ppstrm arity;                           ppFormals ppstrm arity;
712                           pps " ";                           pps " ";
713                           ppSym ppstrm (IP.last path);                           ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppTycBind 2");
714                           case visdcons                           case visdcons
715                             of nil => pps " = ..."                             of nil => pps " = ..."
716                              | first :: rest =>                              | first :: rest =>
717                                 (break{nsp=1,offset=2};                                 (break{nsp=1,offset=2};
718                                  openHVBox 0;                                  openHVBox 0;
719                                   pps "= "; ppDcon first;                                   pps "= "; ppDcon first;
720                                   app (fn d => (break{nsp=1,offset=0}; pps "| "; ppDcon d))                                   app (fn d => (break{nsp=1,offset=0};
721                                                   pps "| "; ppDcon d))
722                                       rest;                                       rest;
723                                   if incomplete                                   if incomplete
724                                       then (break{nsp=1,offset=0}; pps "... ")                                       then (break{nsp=1,offset=0}; pps "... ")
# Line 649  Line 733 
733                        else pps "type";                        else pps "type";
734                        ppFormals ppstrm arity;                        ppFormals ppstrm arity;
735                        pps " ";                        pps " ";
736                        ppSym ppstrm (IP.last path);                        ppSym ppstrm (IP.last path handle IP.InvPath => bug "ppmod:ppTycBind 3");
737                        closeBox()))                        closeBox()))
738                | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>                | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>
739                  (openHOVBox 2;                  (openHOVBox 2;
740                   pps "type";                   pps "type";
741                   ppFormals ppstrm arity;                   ppFormals ppstrm arity;
742                   break{nsp=1,offset=0};                   break{nsp=1,offset=0};
743                   ppSym ppstrm (InvPath.last path);                   ppSym ppstrm (InvPath.last path handle InvPath.InvPath => bug "ppmod:ppTycBind 2");
744                   pps " =";                   pps " =";
745                   break{nsp=1,offset=0};                   break{nsp=1,offset=0};
746                   ppType env ppstrm body;                   ppType env ppstrm body;
747                   closeBox ())                   closeBox ())
748                  | T.ERRORtyc =>
749                    (pps "ERRORtyc")
750                  | T.PATHtyc _ =>
751                    (pps "PATHtyc:";
752                     ppTycon env ppstrm tyc)
753                | tycon =>                | tycon =>
754                  (pps "strange tycon: ";                  (pps "strange tycon: ";
755                   ppTycon env ppstrm tycon)                   ppTycon env ppstrm tycon)
756      end (* ppTycBind *)      end (* ppTycBind *)
757    
758  and ppReplBind ppstrm  and ppReplBind ppstrm =
759       (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},env) =      let
760      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
761       in openHOVBox 2;                en_pp ppstrm
762        in
763            fn (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},
764                env) =>
765               (* [GK 5/4/07] Does this case ever occur? All datatype
766                  replication tycs are GENtycs after elaboration *)
767               (openHOVBox 2;
768          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
769          ppSym ppstrm (IP.last path);              ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppReplBind");
770          pps " ="; break{nsp=1,offset=0};          pps " ="; break{nsp=1,offset=0};
771          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
772          ppTycon env ppstrm rightTyc;          ppTycon env ppstrm rightTyc;
773          closeBox ()              closeBox ())
774      end           | (tyc as T.GENtyc{stamp, arity, eq, kind, path, stub}, env) =>
775    | ppReplBind _ _ = ErrorMsg.impossible "ppReplBind"             (openHOVBox 2;
776                pps "datatype"; break{nsp=1,offset=0};
777                ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppReplBind 2");
778                pps " ="; break{nsp=1,offset=0};
779                ppTycBind ppstrm (tyc, env);
780                closeBox())
781             | (T.PATHtyc _, _) => ErrorMsg.impossible "<replbind:PATHtyc>"
782             | (T.RECtyc _, _) => ErrorMsg.impossible "<replbind:RECtyc>"
783             | (T.FREEtyc _, _) => ErrorMsg.impossible "<replbind:FREEtyc>"
784             | _ => ErrorMsg.impossible "ppReplBind"
785        end (* fun ppReplBind *)
786    
787  and ppEntity ppstrm (entity,env,depth) =  and ppEntity ppstrm (entity,env,depth) =
788      case entity      case entity
# Line 689  Line 794 
794  and ppEntityEnv ppstrm (entEnv,env,depth) =  and ppEntityEnv ppstrm (entEnv,env,depth) =
795      if depth <= 1      if depth <= 1
796      then pps ppstrm "<entityEnv>"      then pps ppstrm "<entityEnv>"
797      else (ppvseq ppstrm 2 ""      else (ppvseq ppstrm 0 ""
798                (fn ppstrm => fn (entVar,entity) =>                (fn ppstrm => fn (entVar,entity) =>
799                  let val {openHVBox,openHOVBox,closeBox,pps,break,newline} =                  let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} =
800                           en_pp ppstrm                           en_pp ppstrm
801                   in openHVBox 2;                   in openHVBox 2;
802                       pps (EntPath.entVarToString entVar);                       pps (EntPath.entVarToString entVar);
# Line 785  Line 890 
890            (pps ppstrm "FE.V:"; ppEntPath ppstrm ep)            (pps ppstrm "FE.V:"; ppEntPath ppstrm ep)
891         | M.CONSTfct { rpath, ... } =>         | M.CONSTfct { rpath, ... } =>
892            (pps ppstrm "FE.C:"; ppInvPath ppstrm rpath)            (pps ppstrm "FE.C:"; ppInvPath ppstrm rpath)
893         | M.LAMBDA_TP {param, body, ...} =>         | M.LAMBDA {param, primaries, paramRlzn, body} =>
           (openHVBox ppstrm (PP.Rel 0);  
             pps ppstrm "FE.LP:"; break ppstrm {nsp=1,offset=1};  
             openHVBox ppstrm (PP.Rel 0);  
              pps ppstrm "par:"; ppEntVar ppstrm param;  
              break ppstrm {nsp=1,offset=0};  
              pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);  
             closeBox ppstrm;  
            closeBox ppstrm)  
        | M.LAMBDA {param, body} =>  
894            (openHVBox ppstrm (PP.Rel 0);            (openHVBox ppstrm (PP.Rel 0);
895              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};
896              openHVBox ppstrm (PP.Rel 0);              openHVBox ppstrm (PP.Rel 0);
897               pps ppstrm "par:"; ppEntVar ppstrm param;               pps ppstrm "par:"; ppEntVar ppstrm param;
898               break ppstrm {nsp=1,offset=0};               break ppstrm {nsp=1,offset=0};
899                 pps ppstrm "parents:";
900                 ppStrEntity ppstrm (paramRlzn, SE.empty, depth-1);
901                 break ppstrm {nsp=1,offset=0};
902               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
903              closeBox ppstrm;              closeBox ppstrm;
904             closeBox ppstrm)             closeBox ppstrm)
# Line 850  Line 949 
949         | B.CONbind con => ppConBinding ppstrm (con,env)         | B.CONbind con => ppConBinding ppstrm (con,env)
950         | B.TYCbind tycon => ppTycBind ppstrm (tycon,env)         | B.TYCbind tycon => ppTycBind ppstrm (tycon,env)
951         | B.SIGbind sign =>         | B.SIGbind sign =>
952            let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm            let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,...} = en_pp ppstrm
953             in openHVBox 0;             in openHVBox 0;
954                 pps "signature "; ppSym ppstrm name; pps " =";                 pps "signature "; ppSym ppstrm name; pps " =";
955                 break{nsp=1,offset=2};                 break{nsp=1,offset=2};
# Line 865  Line 964 
964                closeBox()                closeBox()
965            end            end
966         | B.STRbind str =>         | B.STRbind str =>
967            let val {openHVBox, openHOVBox,closeBox,pps,break,...} = en_pp ppstrm            let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,...} = en_pp ppstrm
968             in openHVBox 0;             in openHVBox 0;
969                 pps "structure "; ppSym ppstrm name; pps " :";                 pps "structure "; ppSym ppstrm name; pps " :";
970                 break{nsp=1,offset=2};                 break{nsp=1,offset=2};
# Line 907  Line 1006 
1006      end      end
1007    
1008  fun ppOpen ppstrm (path,str,env,depth) =  fun ppOpen ppstrm (path,str,env,depth) =
1009      let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
1010       in openHVBox 0;       in openHVBox 0;
1011           openHVBox 2;           openHVBox 2;
1012            pps "opening ";            pps "opening ";

Legend:
Removed from v.1344  
changed lines
  Added in v.3344

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