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 2568, Thu May 17 22:37:20 2007 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    
# Line 62  Line 62 
62        structure EE = EntityEnv        structure EE = EntityEnv
63        structure LU = Lookup        structure LU = Lookup
64    
65        structure PP = PrettyPrint        structure PP = PrettyPrintNew
66        open PrettyPrint PPUtil        structure PU = PPUtilNew
67          open PrettyPrintNew PPUtilNew
68    
69  in  in
70    
# Line 90  Line 91 
91                    let val strEnt = EE.lookStrEnt(entities,entVar)                    let val strEnt = EE.lookStrEnt(entities,entVar)
92                     in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,                     in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,
93                                                    access=A.nullAcc,                                                    access=A.nullAcc,
94                                                    info=II.Null}),                                                    prim=[]}),
95                                env)                                env)
96                    end                    end
97                 | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)                 | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
# Line 179  Line 180 
180    
181  fun ppVariable ppstrm  =  fun ppVariable ppstrm  =
182      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
183          fun ppV(V.VALvar{path,access,typ,info},env:StaticEnv.staticEnv) =          fun ppV(V.VALvar{path,access,typ,prim},env:StaticEnv.staticEnv) =
184                (openHVBox 0;                (openHVBox 0;
185                 pps (SP.toString path);                 pps (SP.toString path);
186                 if !internals then PPVal.ppAccess ppstrm access else ();                 if !internals then PPVal.ppAccess ppstrm access else ();
# Line 190  Line 191 
191                 ppSym ppstrm (name); pps " : "; ppType env ppstrm body;                 ppSym ppstrm (name); pps " : "; ppType env ppstrm body;
192                 pps " as ";                 pps " as ";
193                 ppSequence ppstrm                 ppSequence ppstrm
194                   {sep=C PrettyPrint.break{nsp=1,offset=0},                   {sep=C PrettyPrintNew.break{nsp=1,offset=0},
195                    pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),                    pr=(fn ppstrm => fn{variant,...} =>ppV(variant,env)),
196                    style=CONSISTENT}                    style=CONSISTENT}
197                   optl;                   optl;
# Line 219  Line 220 
220      end      end
221    
222  fun ppStructure ppstrm (str,env,depth) =  fun ppStructure ppstrm (str,env,depth) =
223      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
224       in case str       in case str
225            of M.STR { sign, rlzn as { entities, ... }, ... } =>            of M.STR { sign, rlzn as { entities, ... }, prim, ... } =>
226               (if !internals               (if !internals
227                then (openHVBox 2;                then (openHVBox 2;
228                         pps "STR";                         pps "STR";
# Line 234  Line 235 
235                          pps "rlzn:";                          pps "rlzn:";
236                          break {nsp=1,offset=2};                          break {nsp=1,offset=2};
237                          ppStrEntity ppstrm (rlzn,env,depth-1);                          ppStrEntity ppstrm (rlzn,env,depth-1);
238                            newline();
239                            pps "prim:";
240                            break {nsp=1,offset=2};
241                            (* GK: This should be cleaned up soon so as to use a
242                               ppStrInfo that is an actual pretty printer conforming
243                               to the pattern of the other pretty printers.
244                            PrimOpId.ppStrInfo prim; *)
245                            PPPrim.ppStrPrimInfo ppstrm prim;
246                         closeBox();                         closeBox();
247                        closeBox())                        closeBox())
248                  else case sign                  else case sign
# Line 306  Line 315 
315                       of NONE =>                       of NONE =>
316                           if repl then                           if repl then
317                             ppReplBind ppstrm (spec,env)                             ppReplBind ppstrm (spec,env)
318                           else ppTycBind ppstrm (spec,env)                           else (case spec
319                                     of T.ERRORtyc =>
320                                         (* dummy TYCspec in inferred signature
321                                          * We don't know the arity without an
322                                          * entity env (next case), so we have to
323                                          * punt on printing arity *)
324                                         (pps ppstrm "type";
325                                          break ppstrm {nsp=1,offset=0};                                                  ppSym ppstrm sym)
326                                      | _ => ppTycBind ppstrm (spec,env))
327                        | SOME eenv =>                        | SOME eenv =>
328                           (case EE.look(eenv,entVar)                           (case EE.look(eenv,entVar)
329                              of M.TYCent tyc =>                              of M.TYCent tyc =>
# Line 341  Line 358 
358                   if !internals                   if !internals
359                   then (if first then () else newline ppstrm;                   then (if first then () else newline ppstrm;
360                         ppConBinding ppstrm (dcon,env))                         ppConBinding ppstrm (dcon,env))
361                   else () (* ordinary data constructor, don't print *)                   else () (* don't pring ordinary data constructor,
362                              * because it was printed with its datatype *)
363    
364       in openHVBox ppstrm (PP.Rel 0);       in openHVBox ppstrm (PP.Rel 0);
365          case elements          case elements
# Line 351  Line 369 
369      end      end
370    
371  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =
372      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
373                en_pp ppstrm
374          val env = SE.atop(case entityEnvOp          val env = SE.atop(case entityEnvOp
375                              of NONE => sigToEnv sign                              of NONE => sigToEnv sign
376                               | SOME entEnv => strToEnv(sign,entEnv),                               | SOME entEnv => strToEnv(sign,entEnv),
# Line 371  Line 390 
390                         closeBox()))                         closeBox()))
391                    constraints;                    constraints;
392                  closeBox ())                  closeBox ())
393          val somePrint = ref false          val somePrint = ref false (* i.e., signature is not empty sig end *)
394       in if depth <= 0       in if depth <= 0
395          then pps "<sig>"          then pps "<sig>"
396          else          else
397          case sign          case sign
398            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>
399                 let
400                     (* Filter out ordinary dcon that do not print in ppElements
401                        for element printing so that we do not print the spurious
402                        newline. We still use the unfiltered elements
403                        for determining whether the sig ... end should be
404                        multiline even with just one datatype. *)
405                    val elems' =
406                        List.filter
407                        (fn (_,M.CONspec{spec=T.DATACON{rep=A.EXN _,...},...})
408                                => true
409                          | (_,M.CONspec{spec=dcon,...}) => false
410                          | _ => true)
411                        elements
412                 in
413               if !internals then               if !internals then
414                 (openHVBox 0;                 (openHVBox 0;
415                   pps "SIG:";                   pps "SIG:";
# Line 408  Line 441 
441                else (* not !internals *)                else (* not !internals *)
442                  (openHVBox 0;                  (openHVBox 0;
443                    pps "sig";                    pps "sig";
444                    break{nsp=1,offset=2};                    (case elements
445                           of nil => pps " "
446                            | [(_,M.STRspec _)] => nl_indent ppstrm 2
447                            | [_] => pps " "
448                            | _ => nl_indent ppstrm 2);
449                    openHVBox 0;                    openHVBox 0;
450                     case elements                     case elements
451                       of nil => ()                       of nil => ()
452                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elements;                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elems';
453                                somePrint := true);                                somePrint := true);
454                     case strsharing                     case strsharing
455                       of nil => ()                       of nil => ()
# Line 425  Line 462 
462                                ppConstraints("type ",typsharing);                                ppConstraints("type ",typsharing);
463                                somePrint := true);                                somePrint := true);
464                    closeBox();                    closeBox();
465                    if !somePrint then break{nsp=1,offset=0} else ();                    (case elements
466                        of nil => ()
467                         | [(_,M.STRspec _)] => newline()
468                         | [_] => pps " "
469                         | _ => newline());
470                    pps "end";                    pps "end";
471                   closeBox())                   closeBox())
472                 end
473             | M.ERRORsig => pps "<error sig>"             | M.ERRORsig => pps "<error sig>"
474      end      end
475    
476  and ppFunsig ppstrm (sign,env,depth) =  and ppFunsig ppstrm (sign,env,depth) =
477      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
478                en_pp ppstrm
479          fun trueBodySig (orig as M.SIG { elements =          fun trueBodySig (orig as M.SIG { elements =
480                                           [(sym, M.STRspec { sign, ... })],                                           [(sym, M.STRspec { sign, ... })],
481                                           ... }) =                                           ... }) =
# Line 476  Line 519 
519                  | M.ERRORfsig => pps "<error fsig>"                  | M.ERRORfsig => pps "<error fsig>"
520      end      end
521    
   
522  and ppStrEntity ppstrm (e,env,depth) =  and ppStrEntity ppstrm (e,env,depth) =
523      let val {stamp,entities,properties,rpath,stub} = e      let val {stamp,entities,properties,rpath,stub} = e
524          val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
525                en_pp ppstrm
526       in if depth <= 1       in if depth <= 1
527          then pps "<structure entity>"          then pps "<structure entity>"
528          else (openHVBox 0;          else (openHVBox 0;
# Line 505  Line 548 
548    
549  and ppFctEntity ppstrm (e, env, depth) =  and ppFctEntity ppstrm (e, env, depth) =
550      let val {stamp,closure,properties,tycpath,rpath,stub} = e      let val {stamp,closure,properties,tycpath,rpath,stub} = e
551          val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm          val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
552      in if depth <= 1      in if depth <= 1
553          then pps "<functor entity>"          then pps "<functor entity>"
554          else (openHVBox 0;          else (openHVBox 0;
# Line 533  Line 576 
576      end      end
577    
578  and ppFunctor ppstrm =  and ppFunctor ppstrm =
579      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
580          fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =          fun ppF (M.FCT { sign, rlzn, ... }, env, depth) =
581                  if depth <= 1                  if depth <= 1
582                  then pps "<functor>"                  then pps "<functor>"
# Line 551  Line 594 
594      end      end
595    
596  and ppTycBind ppstrm (tyc,env) =  and ppTycBind ppstrm (tyc,env) =
597      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
598          fun visibleDcons(tyc,dcons) =          fun visibleDcons(tyc,dcons) =
599              let fun checkCON(V.CON c) = c              let fun checkCON(V.CON c) = c
600                    | checkCON _ = raise SE.Unbound                    | checkCON _ = raise SE.Unbound
# Line 634  Line 677 
677                                 (break{nsp=1,offset=2};                                 (break{nsp=1,offset=2};
678                                  openHVBox 0;                                  openHVBox 0;
679                                   pps "= "; ppDcon first;                                   pps "= "; ppDcon first;
680                                   app (fn d => (break{nsp=1,offset=0}; pps "| "; ppDcon d))                                   app (fn d => (break{nsp=1,offset=0};
681                                                   pps "| "; ppDcon d))
682                                       rest;                                       rest;
683                                   if incomplete                                   if incomplete
684                                       then (break{nsp=1,offset=0}; pps "... ")                                       then (break{nsp=1,offset=0}; pps "... ")
# Line 661  Line 705 
705                   break{nsp=1,offset=0};                   break{nsp=1,offset=0};
706                   ppType env ppstrm body;                   ppType env ppstrm body;
707                   closeBox ())                   closeBox ())
708                  | T.ERRORtyc =>
709                    (pps "ERRORtyc")
710                  | T.PATHtyc _ =>
711                    (pps "PATHtyc:";
712                     ppTycon env ppstrm tyc)
713                | tycon =>                | tycon =>
714                  (pps "strange tycon: ";                  (pps "strange tycon: ";
715                   ppTycon env ppstrm tycon)                   ppTycon env ppstrm tycon)
716      end (* ppTycBind *)      end (* ppTycBind *)
717    
718  and ppReplBind ppstrm  and ppReplBind ppstrm =
719       (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},env) =      let
720      let val {openHVBox, openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
721       in openHOVBox 2;                en_pp ppstrm
722        in
723            fn (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},
724                env) =>
725               (* [GK 5/4/07] Does this case ever occur? All datatype
726                  replication tycs are GENtycs after elaboration *)
727               (openHOVBox 2;
728          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
729          ppSym ppstrm (IP.last path);          ppSym ppstrm (IP.last path);
730          pps " ="; break{nsp=1,offset=0};          pps " ="; break{nsp=1,offset=0};
731          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
732          ppTycon env ppstrm rightTyc;          ppTycon env ppstrm rightTyc;
733          closeBox ()              closeBox ())
734      end           | (tyc as T.GENtyc{stamp, arity, eq, kind, path, stub}, env) =>
735    | ppReplBind _ _ = ErrorMsg.impossible "ppReplBind"             (openHOVBox 2;
736                pps "datatype"; break{nsp=1,offset=0};
737                ppSym ppstrm (IP.last path);
738                pps " ="; break{nsp=1,offset=0};
739                ppTycBind ppstrm (tyc, env);
740                closeBox())
741             | (T.PATHtyc _, _) => ErrorMsg.impossible "<replbind:PATHtyc>"
742             | (T.RECtyc _, _) => ErrorMsg.impossible "<replbind:RECtyc>"
743             | (T.FREEtyc _, _) => ErrorMsg.impossible "<replbind:FREEtyc>"
744             | _ => ErrorMsg.impossible "ppReplBind"
745        end (* fun ppReplBind *)
746    
747  and ppEntity ppstrm (entity,env,depth) =  and ppEntity ppstrm (entity,env,depth) =
748      case entity      case entity
# Line 691  Line 756 
756      then pps ppstrm "<entityEnv>"      then pps ppstrm "<entityEnv>"
757      else (ppvseq ppstrm 2 ""      else (ppvseq ppstrm 2 ""
758                (fn ppstrm => fn (entVar,entity) =>                (fn ppstrm => fn (entVar,entity) =>
759                  let val {openHVBox,openHOVBox,closeBox,pps,break,newline} =                  let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} =
760                           en_pp ppstrm                           en_pp ppstrm
761                   in openHVBox 2;                   in openHVBox 2;
762                       pps (EntPath.entVarToString entVar);                       pps (EntPath.entVarToString entVar);
# Line 850  Line 915 
915         | B.CONbind con => ppConBinding ppstrm (con,env)         | B.CONbind con => ppConBinding ppstrm (con,env)
916         | B.TYCbind tycon => ppTycBind ppstrm (tycon,env)         | B.TYCbind tycon => ppTycBind ppstrm (tycon,env)
917         | B.SIGbind sign =>         | B.SIGbind sign =>
918            let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm            let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,...} = en_pp ppstrm
919             in openHVBox 0;             in openHVBox 0;
920                 pps "signature "; ppSym ppstrm name; pps " =";                 pps "signature "; ppSym ppstrm name; pps " =";
921                 break{nsp=1,offset=2};                 break{nsp=1,offset=2};
# Line 865  Line 930 
930                closeBox()                closeBox()
931            end            end
932         | B.STRbind str =>         | B.STRbind str =>
933            let val {openHVBox, openHOVBox,closeBox,pps,break,...} = en_pp ppstrm            let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,...} = en_pp ppstrm
934             in openHVBox 0;             in openHVBox 0;
935                 pps "structure "; ppSym ppstrm name; pps " :";                 pps "structure "; ppSym ppstrm name; pps " :";
936                 break{nsp=1,offset=2};                 break{nsp=1,offset=2};
# Line 907  Line 972 
972      end      end
973    
974  fun ppOpen ppstrm (path,str,env,depth) =  fun ppOpen ppstrm (path,str,env,depth) =
975      let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm      let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
976       in openHVBox 0;       in openHVBox 0;
977           openHVBox 2;           openHVBox 2;
978            pps "opening ";            pps "opening ";

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

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