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

revision 2222, Tue Nov 28 22:02:39 2006 UTC revision 3322, Wed May 6 22:47:35 2009 UTC
# Line 40  Line 40 
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 103  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 124  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 153  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 180  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,prim},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 238  Line 263 
263                          newline();                          newline();
264                          pps "prim:";                          pps "prim:";
265                          break {nsp=1,offset=2};                          break {nsp=1,offset=2};
                         (* GK: This should be cleaned up soon so as to use a  
                            ppStrInfo that is an actual pretty printer conforming  
                            to the pattern of the other pretty printers.  
                         PrimOpId.ppStrInfo prim; *)  
266                          PPPrim.ppStrPrimInfo ppstrm prim;                          PPPrim.ppStrPrimInfo ppstrm prim;
267                         closeBox();                         closeBox();
268                        closeBox())                        closeBox())
# Line 308  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 333  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 350  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 360  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,ppi,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 380  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 417  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 434  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,ppi,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 486  Line 555 
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,ppi,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 503  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,ppi,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>"
# Line 526  Line 592 
592                  pps "stamp: ";                  pps "stamp: ";
593                  pps (Stamps.toShortString stamp);                  pps (Stamps.toShortString stamp);
594                  newline();                  newline();
595                    pps "paramRlzn: ";
596                    break{nsp=1,offset=2};
597                    ppStrEntity ppstrm (paramRlzn,env,depth-1);
598                    newline();
599                  pps "closure:";                  pps "closure:";
600                  break{nsp=1,offset=2};                  break{nsp=1,offset=2};
601                  ppClosure ppstrm (closure,depth-1);                  ppClosure ppstrm (closure,depth-1);
602                  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--";  
603                 closeBox ();                 closeBox ();
604                closeBox ())                closeBox ())
605      end      end
# Line 623  Line 687 
687                        pps "type";                        pps "type";
688                        ppFormals ppstrm arity;                        ppFormals ppstrm arity;
689                        pps " ";                        pps " ";
690                        ppSym ppstrm (IP.last path);                        ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppTycBind");
691                        closeBox())                        closeBox())
692                     | (_, T.DATATYPE{index,family={members,...},...}) =>                     | (_, T.DATATYPE{index,family={members,...},...}) =>
693                       (* ordinary datatype *)                       (* ordinary datatype *)
# Line 635  Line 699 
699                           pps "datatype";                           pps "datatype";
700                           ppFormals ppstrm arity;                           ppFormals ppstrm arity;
701                           pps " ";                           pps " ";
702                           ppSym ppstrm (IP.last path);                           ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppTycBind 2");
703                           case visdcons                           case visdcons
704                             of nil => pps " = ..."                             of nil => pps " = ..."
705                              | first :: rest =>                              | first :: rest =>
706                                 (break{nsp=1,offset=2};                                 (break{nsp=1,offset=2};
707                                  openHVBox 0;                                  openHVBox 0;
708                                   pps "= "; ppDcon first;                                   pps "= "; ppDcon first;
709                                   app (fn d => (break{nsp=1,offset=0}; pps "| "; ppDcon d))                                   app (fn d => (break{nsp=1,offset=0};
710                                                   pps "| "; ppDcon d))
711                                       rest;                                       rest;
712                                   if incomplete                                   if incomplete
713                                       then (break{nsp=1,offset=0}; pps "... ")                                       then (break{nsp=1,offset=0}; pps "... ")
# Line 657  Line 722 
722                        else pps "type";                        else pps "type";
723                        ppFormals ppstrm arity;                        ppFormals ppstrm arity;
724                        pps " ";                        pps " ";
725                        ppSym ppstrm (IP.last path);                        ppSym ppstrm (IP.last path handle IP.InvPath => bug "ppmod:ppTycBind 3");
726                        closeBox()))                        closeBox()))
727                | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>                | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>
728                  (openHOVBox 2;                  (openHOVBox 2;
729                   pps "type";                   pps "type";
730                   ppFormals ppstrm arity;                   ppFormals ppstrm arity;
731                   break{nsp=1,offset=0};                   break{nsp=1,offset=0};
732                   ppSym ppstrm (InvPath.last path);                   ppSym ppstrm (InvPath.last path handle InvPath.InvPath => bug "ppmod:ppTycBind 2");
733                   pps " =";                   pps " =";
734                   break{nsp=1,offset=0};                   break{nsp=1,offset=0};
735                   ppType env ppstrm body;                   ppType env ppstrm body;
736                   closeBox ())                   closeBox ())
737                  | T.ERRORtyc =>
738                    (pps "ERRORtyc")
739                  | T.PATHtyc _ =>
740                    (pps "PATHtyc:";
741                     ppTycon env ppstrm tyc)
742                | tycon =>                | tycon =>
743                  (pps "strange tycon: ";                  (pps "strange tycon: ";
744                   ppTycon env ppstrm tycon)                   ppTycon env ppstrm tycon)
745      end (* ppTycBind *)      end (* ppTycBind *)
746    
747  and ppReplBind ppstrm  and ppReplBind ppstrm =
748       (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},env) =      let
749      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
750       in openHOVBox 2;                en_pp ppstrm
751        in
752            fn (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},
753                env) =>
754               (* [GK 5/4/07] Does this case ever occur? All datatype
755                  replication tycs are GENtycs after elaboration *)
756               (openHOVBox 2;
757          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
758          ppSym ppstrm (IP.last path);              ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppReplBind");
759          pps " ="; break{nsp=1,offset=0};          pps " ="; break{nsp=1,offset=0};
760          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
761          ppTycon env ppstrm rightTyc;          ppTycon env ppstrm rightTyc;
762          closeBox ()              closeBox ())
763      end           | (tyc as T.GENtyc{stamp, arity, eq, kind, path, stub}, env) =>
764    | ppReplBind _ _ = ErrorMsg.impossible "ppReplBind"             (openHOVBox 2;
765                pps "datatype"; break{nsp=1,offset=0};
766                ppSym ppstrm (IP.last path handle InvPath.InvPath => bug "ppmod:ppReplBind 2");
767                pps " ="; break{nsp=1,offset=0};
768                ppTycBind ppstrm (tyc, env);
769                closeBox())
770             | (T.PATHtyc _, _) => ErrorMsg.impossible "<replbind:PATHtyc>"
771             | (T.RECtyc _, _) => ErrorMsg.impossible "<replbind:RECtyc>"
772             | (T.FREEtyc _, _) => ErrorMsg.impossible "<replbind:FREEtyc>"
773             | _ => ErrorMsg.impossible "ppReplBind"
774        end (* fun ppReplBind *)
775    
776  and ppEntity ppstrm (entity,env,depth) =  and ppEntity ppstrm (entity,env,depth) =
777      case entity      case entity
# Line 697  Line 783 
783  and ppEntityEnv ppstrm (entEnv,env,depth) =  and ppEntityEnv ppstrm (entEnv,env,depth) =
784      if depth <= 1      if depth <= 1
785      then pps ppstrm "<entityEnv>"      then pps ppstrm "<entityEnv>"
786      else (ppvseq ppstrm 2 ""      else (ppvseq ppstrm 0 ""
787                (fn ppstrm => fn (entVar,entity) =>                (fn ppstrm => fn (entVar,entity) =>
788                  let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} =                  let val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} =
789                           en_pp ppstrm                           en_pp ppstrm
# Line 793  Line 879 
879            (pps ppstrm "FE.V:"; ppEntPath ppstrm ep)            (pps ppstrm "FE.V:"; ppEntPath ppstrm ep)
880         | M.CONSTfct { rpath, ... } =>         | M.CONSTfct { rpath, ... } =>
881            (pps ppstrm "FE.C:"; ppInvPath ppstrm rpath)            (pps ppstrm "FE.C:"; ppInvPath ppstrm rpath)
882         | M.LAMBDA_TP {param, body, ...} =>         | M.LAMBDA {param, 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} =>  
883            (openHVBox ppstrm (PP.Rel 0);            (openHVBox ppstrm (PP.Rel 0);
884              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};
885              openHVBox ppstrm (PP.Rel 0);              openHVBox ppstrm (PP.Rel 0);
886               pps ppstrm "par:"; ppEntVar ppstrm param;               pps ppstrm "par:"; ppEntVar ppstrm param;
887               break ppstrm {nsp=1,offset=0};               break ppstrm {nsp=1,offset=0};
888                 pps ppstrm "parents:";
889                 ppStrEntity ppstrm (paramRlzn, SE.empty, depth-1);
890                 break ppstrm {nsp=1,offset=0};
891               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
892              closeBox ppstrm;              closeBox ppstrm;
893             closeBox ppstrm)             closeBox ppstrm)

Legend:
Removed from v.2222  
changed lines
  Added in v.3322

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