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 2434, Fri Apr 20 03:26:51 2007 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 464  Line 509 
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 509  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 526  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 549  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 646  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 658  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 680  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 720  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 816  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.2434  
changed lines
  Added in v.3322

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