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 2407, Fri Apr 13 04:27:56 2007 UTC revision 3285, Wed Apr 1 16:20:00 2009 UTC
# Line 103  Line 103 
103  fun sigToEnv(M.SIG {elements,...}) =  fun sigToEnv(M.SIG {elements,...}) =
104      let fun bindElem ((sym,spec), env) =      let fun bindElem ((sym,spec), env) =
105            (case spec            (case spec
106              of M.TYCspec{spec,...} => SE.bind(sym,B.TYCbind spec,env)              of M.TYCspec{info=M.RegTycSpec{spec,...},...} =>
107                    SE.bind(sym,B.TYCbind spec,env)
108                 | M.TYCspec{info=M.InfTycSpec{name,arity},...} =>
109                    let val tyc =
110                            T.GENtyc{stamp=Stamps.special "x", arity=arity,
111                                     eq=ref(T.UNDEF), kind=T.FORMAL, stub=NONE,
112                                     path=InvPath.extend(InvPath.empty,name)}
113                    in SE.bind(sym,B.TYCbind tyc,env)
114                    end
115               | M.STRspec{sign,slot,def,entVar=ev} =>               | M.STRspec{sign,slot,def,entVar=ev} =>
116                   SE.bind(sym,B.STRbind(M.STRSIG{sign=sign,entPath=[ev]}),env)                   SE.bind(sym,B.STRbind(M.STRSIG{sign=sign,entPath=[ev]}),env)
117               | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)               | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
# Line 180  Line 188 
188    
189  fun ppVariable ppstrm  =  fun ppVariable ppstrm  =
190      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,...} = en_pp ppstrm
191          fun ppV(V.VALvar{path,access,typ,prim},env:StaticEnv.staticEnv) =          fun ppV(V.VALvar{path,access,typ,prim,btvs},env:StaticEnv.staticEnv) =
192                (openHVBox 0;                (openHVBox 0;
193                 pps (SP.toString path);                 pps (SP.toString path);
194                 if !internals then PPVal.ppAccess ppstrm access else ();                 if !internals then PPVal.ppAccess ppstrm access else ();
# Line 238  Line 246 
246                          newline();                          newline();
247                          pps "prim:";                          pps "prim:";
248                          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; *)  
249                          PPPrim.ppStrPrimInfo ppstrm prim;                          PPPrim.ppStrPrimInfo ppstrm prim;
250                         closeBox();                         closeBox();
251                        closeBox())                        closeBox())
# Line 308  Line 312 
312                     closeBox ppstrm;                     closeBox ppstrm;
313                    closeBox ppstrm)                    closeBox ppstrm)
314    
315                | M.TYCspec{spec,entVar,repl,scope} =>                | M.TYCspec{entVar,info} =>
316                   (if first then () else newline ppstrm;                   (if first then () else newline ppstrm;
317                    openHVBox ppstrm (PP.Rel 0);                    case info
318                        of M.RegTycSpec{spec,repl,scope} =>
319                           (openHVBox ppstrm (PP.Rel 0);
320                     case entityEnvOp                     case entityEnvOp
321                       of NONE =>                       of NONE =>
322                           if repl then                           if repl then
# Line 333  Line 339 
339                           pps ppstrm (Int.toString scope))                           pps ppstrm (Int.toString scope))
340                     else ();                     else ();
341                    closeBox ppstrm)                    closeBox ppstrm)
342                         | M.InfTycSpec{name,arity} =>
343                           (openHVBox ppstrm (PP.Rel 0);
344                             case entityEnvOp
345                               of NONE =>
346                                   (pps ppstrm "type";
347                                    ppFormals ppstrm arity;
348                                    pps ppstrm " ";
349                                    ppSym ppstrm name)
350                                | SOME eenv =>
351                                   (case EE.look(eenv,entVar)
352                                      of M.TYCent tyc =>
353                                           ppTycBind ppstrm (tyc,env)
354                                       | M.ERRORent => pps ppstrm "<ERRORent>"
355                                       | _ => bug "ppElements:TYCent");
356                             if !internals
357                             then (newline ppstrm;
358                                   pps ppstrm "entVar: ";
359                                   pps ppstrm (EntPath.entVarToString entVar))
360                             else ();
361                            closeBox ppstrm))
362    
363                | M.VALspec{spec=typ,...} =>                | M.VALspec{spec=typ,...} =>
364                   (if first then () else newline ppstrm;                   (if first then () else newline ppstrm;
# Line 350  Line 376 
376                   if !internals                   if !internals
377                   then (if first then () else newline ppstrm;                   then (if first then () else newline ppstrm;
378                         ppConBinding ppstrm (dcon,env))                         ppConBinding ppstrm (dcon,env))
379                   else () (* ordinary data constructor, don't print *)                   else () (* don't pring ordinary data constructor,
380                              * because it was printed with its datatype *)
381    
382       in openHVBox ppstrm (PP.Rel 0);       in openHVBox ppstrm (PP.Rel 0);
383          case elements          case elements
# Line 360  Line 387 
387      end      end
388    
389  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =
390      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
391                en_pp ppstrm
392          val env = SE.atop(case entityEnvOp          val env = SE.atop(case entityEnvOp
393                              of NONE => sigToEnv sign                              of NONE => sigToEnv sign
394                               | SOME entEnv => strToEnv(sign,entEnv),                               | SOME entEnv => strToEnv(sign,entEnv),
# Line 386  Line 414 
414          else          else
415          case sign          case sign
416            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>
417                 let
418                     (* Filter out ordinary dcon that do not print in ppElements
419                        for element printing so that we do not print the spurious
420                        newline. We still use the unfiltered elements
421                        for determining whether the sig ... end should be
422                        multiline even with just one datatype. *)
423                    val elems' =
424                        List.filter
425                        (fn (_,M.CONspec{spec=T.DATACON{rep=A.EXN _,...},...})
426                                => true
427                          | (_,M.CONspec{spec=dcon,...}) => false
428                          | _ => true)
429                        elements
430                 in
431               if !internals then               if !internals then
432                 (openHVBox 0;                 (openHVBox 0;
433                   pps "SIG:";                   pps "SIG:";
# Line 419  Line 461 
461                    pps "sig";                    pps "sig";
462                    (case elements                    (case elements
463                         of nil => pps " "                         of nil => pps " "
464                            | [(_,M.STRspec _)] => nl_indent ppstrm 2
465                          | [_] => pps " "                          | [_] => pps " "
466                          | _ => nl_indent ppstrm 2);                          | _ => nl_indent ppstrm 2);
467                    openHVBox 0;                    openHVBox 0;
468                     case elements                     case elements
469                       of nil => ()                       of nil => ()
470                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elements;                        | _ => (ppElements (env,depth,entityEnvOp) ppstrm elems';
471                                somePrint := true);                                somePrint := true);
472                     case strsharing                     case strsharing
473                       of nil => ()                       of nil => ()
# Line 439  Line 482 
482                    closeBox();                    closeBox();
483                    (case elements                    (case elements
484                      of nil => ()                      of nil => ()
485                         | [(_,M.STRspec _)] => newline()
486                       | [_] => pps " "                       | [_] => pps " "
487                       | _ => newline());                       | _ => newline());
488                    pps "end";                    pps "end";
489                   closeBox())                   closeBox())
490                 end
491             | M.ERRORsig => pps "<error sig>"             | M.ERRORsig => pps "<error sig>"
492      end      end
493    
494  and ppFunsig ppstrm (sign,env,depth) =  and ppFunsig ppstrm (sign,env,depth) =
495      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
496                en_pp ppstrm
497          fun trueBodySig (orig as M.SIG { elements =          fun trueBodySig (orig as M.SIG { elements =
498                                           [(sym, M.STRspec { sign, ... })],                                           [(sym, M.STRspec { sign, ... })],
499                                           ... }) =                                           ... }) =
# Line 493  Line 539 
539    
540  and ppStrEntity ppstrm (e,env,depth) =  and ppStrEntity ppstrm (e,env,depth) =
541      let val {stamp,entities,properties,rpath,stub} = e      let val {stamp,entities,properties,rpath,stub} = e
542          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
543                en_pp ppstrm
544       in if depth <= 1       in if depth <= 1
545          then pps "<structure entity>"          then pps "<structure entity>"
546          else (openHVBox 0;          else (openHVBox 0;
# Line 518  Line 565 
565      end      end
566    
567  and ppFctEntity ppstrm (e, env, depth) =  and ppFctEntity ppstrm (e, env, depth) =
568      let val {stamp,closure,properties,tycpath,rpath,stub} = e      let val {stamp,paramRlzn,bodyRlzn,closure,properties,rpath,stub} = e
569          val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm          val {openHVBox,openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm
570      in if depth <= 1      in if depth <= 1
571          then pps "<functor entity>"          then pps "<functor entity>"
# Line 532  Line 579 
579                  pps "stamp: ";                  pps "stamp: ";
580                  pps (Stamps.toShortString stamp);                  pps (Stamps.toShortString stamp);
581                  newline();                  newline();
582                    pps "paramRlzn: ";
583                    break{nsp=1,offset=2};
584                    ppStrEntity ppstrm (paramRlzn,env,depth-1);
585                    newline();
586                    pps "bodyRlzn: ";
587                    break{nsp=1,offset=2};
588                    ppStrEntity ppstrm (bodyRlzn,env,depth-1);
589                    newline();
590                  pps "closure:";                  pps "closure:";
591                  break{nsp=1,offset=2};                  break{nsp=1,offset=2};
592                  ppClosure ppstrm (closure,depth-1);                  ppClosure ppstrm (closure,depth-1);
# Line 539  Line 594 
594                  pps "lambdaty:";                  pps "lambdaty:";
595                  break{nsp=1,offset=2};                  break{nsp=1,offset=2};
596                  ppLty ppstrm ( (* ModulePropLists.fctEntityLty e,depth-1 *) );                  ppLty ppstrm ( (* ModulePropLists.fctEntityLty e,depth-1 *) );
597            (*      newline();
598                  pps "tycpath:";                  pps "tycpath:";
599                  break{nsp=1,offset=2};                  break{nsp=1,offset=2};
600                  pps "--printing of tycpath not implemented yet--";                  (case tycpath
601                      of SOME(tp) => PPType.ppTycpath env ppstrm tp
602                       | NONE => pps "no tycpath"); *)
603                 closeBox ();                 closeBox ();
604                closeBox ())                closeBox ())
605      end      end
# Line 648  Line 706 
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 675  Line 734 
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);
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);
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 703  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 808  Line 888 
888               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
889              closeBox ppstrm;              closeBox ppstrm;
890             closeBox ppstrm)             closeBox ppstrm)
891         | M.LAMBDA {param, body} =>         | M.LAMBDA {param, paramRlzn, body} =>
892            (openHVBox ppstrm (PP.Rel 0);            (openHVBox ppstrm (PP.Rel 0);
893              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};              pps ppstrm "FE.L:"; break ppstrm {nsp=1,offset=1};
894              openHVBox ppstrm (PP.Rel 0);              openHVBox ppstrm (PP.Rel 0);
895               pps ppstrm "par:"; ppEntVar ppstrm param;               pps ppstrm "par:"; ppEntVar ppstrm param;
896               break ppstrm {nsp=1,offset=0};               break ppstrm {nsp=1,offset=0};
897                 pps ppstrm "parents:";
898                 ppStrEntity ppstrm (paramRlzn, SE.empty, depth-1);
899                 break ppstrm {nsp=1,offset=0};
900               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);               pps ppstrm "bod:"; ppStrExp ppstrm (body, depth-1);
901              closeBox ppstrm;              closeBox ppstrm;
902             closeBox ppstrm)             closeBox ppstrm)

Legend:
Removed from v.2407  
changed lines
  Added in v.3285

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