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/trunk/src/compiler/MiscUtil/print/ppmod.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/MiscUtil/print/ppmod.sml

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

revision 586, Thu Mar 30 05:08:07 2000 UTC revision 587, Thu Mar 30 09:01:52 2000 UTC
# Line 86  Line 86 
86                 | M.STRspec{entVar,sign,...} =>                 | M.STRspec{entVar,sign,...} =>
87                    let val strEnt = EE.lookStrEnt(entities,entVar)                    let val strEnt = EE.lookStrEnt(entities,entVar)
88                     in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,                     in SE.bind(sym,B.STRbind(M.STR{sign=sign,rlzn=strEnt,
89                                        access=A.nullAcc, info=II.nullInfo}),env)                                        access=A.nullAcc, info=II.nullInfo}),
90                                  env)
91                    end                    end
92                 | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)                 | M.CONspec{spec=dcon, ...} => SE.bind(sym,B.CONbind dcon,env)
93                 | _ => env                 | _ => env
# Line 104  Line 105 
105               | _ => env)               | _ => env)
106       in foldl bindElem SE.empty elements       in foldl bindElem SE.empty elements
107      end      end
108      | sigToEnv _ = bug "sigToEnv"
109    
110  (*  (*
111   * Support for a hack to make sure that non-visible ConBindings don't   * Support for a hack to make sure that non-visible ConBindings don't
# Line 162  Line 164 
164  fun ppStructureName ppstrm (str,env) =  fun ppStructureName ppstrm (str,env) =
165      let val rpath =      let val rpath =
166              case str              case str
167                of M.STR{rlzn={rpath,...},...} => rpath               of M.STR { rlzn, ... } => #rpath rlzn
168                 | _ => bug "ppStructureName"                 | _ => bug "ppStructureName"
169          fun look a = LU.lookStr(env,a,(fn _ => raise Env.Unbound))          fun look a = LU.lookStr(env,a,(fn _ => raise Env.Unbound))
170          fun check str' = MU.eqOrigin(str',str)          fun check str' = MU.eqOrigin(str',str)
# Line 231  Line 233 
233                         end_block();                         end_block();
234                        end_block())                        end_block())
235                  else case sign                  else case sign
236                         of M.SIG{name,...} =>                         of M.SIG { name = SOME sym, ... } =>
                            (case name  
                               of SOME sym =>  
237                                    ((if MU.eqSign                                    ((if MU.eqSign
238                                         (sign,                                         (sign,
239                                          LU.lookSig                                          LU.lookSig
# Line 242  Line 242 
242                                      else (ppSym ppstrm sym; pps "?"))                                      else (ppSym ppstrm sym; pps "?"))
243                                     handle Env.Unbound =>                                     handle Env.Unbound =>
244                                       (ppSym ppstrm sym; pps "?"))                                       (ppSym ppstrm sym; pps "?"))
245                                 | NONE =>                          | M.SIG { name = NONE, ... } =>
246                                    if depth <= 1 then pps "<sig>"                                    if depth <= 1 then pps "<sig>"
247                                    else ppSignature0 ppstrm                                    else ppSignature0 ppstrm
248                                          (sign,env,depth-1,SOME entities))                                              (sign,env,depth-1,SOME entities)
249                          | M.ERRORsig => pps "<error sig>")                          | M.ERRORsig => pps "<error sig>")
250             | M.STRSIG _ => pps "<strsig>"             | M.STRSIG _ => pps "<strsig>"
251             | M.ERRORstr => pps "<error str>"             | M.ERRORstr => pps "<error str>"
# Line 264  Line 264 
264                      case entityEnvOp                      case entityEnvOp
265                        of NONE => ppSignature0 ppstrm (sign,env,depth-1,NONE)                        of NONE => ppSignature0 ppstrm (sign,env,depth-1,NONE)
266                         | SOME eenv =>                         | SOME eenv =>
267                            let val M.STRent{entities,...} = EE.look(eenv,entVar)                            let val {entities,...} =
268                                      case EE.look(eenv,entVar) of
269                                          M.STRent e => e
270                                        | _ => bug "ppElements:STRent"
271                             in ppSignature0 ppstrm                             in ppSignature0 ppstrm
272                                  (sign,env,depth-1,SOME entities)                                  (sign,env,depth-1,SOME entities)
273                            end;                            end;
# Line 300  Line 303 
303                        | SOME eenv =>                        | SOME eenv =>
304                           (case EE.look(eenv,entVar)                           (case EE.look(eenv,entVar)
305                              of M.TYCent tyc => ppTycBind ppstrm (tyc,env)                              of M.TYCent tyc => ppTycBind ppstrm (tyc,env)
306                               | M.ERRORent => add_string ppstrm "<ERRORent>");                               | M.ERRORent => add_string ppstrm "<ERRORent>"
307                                 | _ => bug "ppElements:TYCent");
308                     if !internals                     if !internals
309                     then (add_newline ppstrm;                     then (add_newline ppstrm;
310                           add_string ppstrm "entVar: ";                           add_string ppstrm "entVar: ";
# Line 362  Line 366 
366          then pps "<sig>"          then pps "<sig>"
367          else          else
368          case sign          case sign
369            of M.SIG {name,stamp,elements,typsharing,strsharing,...} =>            of M.SIG {stamp,name,elements,typsharing,strsharing,...} =>
370               if !internals then               if !internals then
371                 (begin_block CONSISTENT 0;                 (begin_block CONSISTENT 0;
372                   pps "SIG:";                   pps "SIG:";
373                   nl_indent ppstrm 2;                   nl_indent ppstrm 2;
374                   begin_block CONSISTENT 0;                   begin_block CONSISTENT 0;
375                    pps "stamp: "; pps (Stamps.stampToShortString stamp);                    pps "stamp: "; pps (Stamps.toShortString stamp);
376                    add_newline();                    add_newline();
377                    pps "name: ";                    pps "name: ";
378                    case name                    case name
# Line 419  Line 423 
423    
424  and ppFunsig ppstrm (sign,env,depth) =  and ppFunsig ppstrm (sign,env,depth) =
425      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
426          fun trueBodySig(orig as M.SIG{elements=[(sym,M.STRspec{sign,...})],...}) =          fun trueBodySig (orig as M.SIG { elements =
427                if Symbol.eq(sym,resultId)                                           [(sym, M.STRspec { sign, ... })],
428                then sign                                           ... }) =
429                else orig              if Symbol.eq (sym, resultId) then sign else orig
430            | trueBodySig sign = sign            | trueBodySig orig = orig
431       in if depth<=0 then pps "<fctsig>"       in if depth<=0 then pps "<fctsig>"
432          else case sign          else case sign
433                 of M.FSIG {paramsig,paramvar,paramsym,bodysig, ...} =>                 of M.FSIG {paramsig,paramvar,paramsym,bodysig, ...} =>
# Line 463  Line 467 
467      end      end
468    
469    
470  and ppStrEntity ppstrm ({stamp,entities,lambdaty,rpath},env,depth) =  and ppStrEntity ppstrm ({stamp,entities,lambdaty,rpath,stub},env,depth) =
471      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
472       in if depth <= 1       in if depth <= 1
473          then pps "<structure entity>"          then pps "<structure entity>"
# Line 475  Line 479 
479                  pps (IP.toString rpath);                  pps (IP.toString rpath);
480                  add_newline();                  add_newline();
481                  pps "stamp: ";                  pps "stamp: ";
482                  pps (Stamps.stampToShortString stamp);                  pps (Stamps.toShortString stamp);
483                  add_newline();                  add_newline();
484                  pps "entities:";                  pps "entities:";
485                  nl_indent ppstrm 2;                  nl_indent ppstrm 2;
# Line 488  Line 492 
492                end_block ())                end_block ())
493      end      end
494    
495  and ppFctEntity ppstrm ({stamp,closure,lambdaty,tycpath,rpath},env,depth) =  and ppFctEntity ppstrm ({stamp,closure,lambdaty,tycpath,rpath,stub},
496                            env, depth) =
497      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm      let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
498       in if depth <= 1       in if depth <= 1
499          then pps "<functor entity>"          then pps "<functor entity>"
# Line 500  Line 505 
505                  pps (IP.toString rpath);                  pps (IP.toString rpath);
506                  add_newline();                  add_newline();
507                  pps "stamp: ";                  pps "stamp: ";
508                  pps (Stamps.stampToShortString stamp);                  pps (Stamps.toShortString stamp);
509                  add_newline();                  add_newline();
510                  pps "closure:";                  pps "closure:";
511                  add_break (1,2);                  add_break (1,2);
# Line 589  Line 594 
594          then (begin_block CONSISTENT 0;          then (begin_block CONSISTENT 0;
595                 pps "type "; ppTycon env ppstrm tyc;                 pps "type "; ppTycon env ppstrm tyc;
596                end_block())                end_block())
597          else case tyc          else
598                 of T.GENtyc{path, arity, eq=ref T.ABS,...} =>              case tyc of
599                    T.GENtyc { path, arity, eq, kind, ... } =>
600                    (case (!eq, kind) of
601                         (T.ABS, _) =>
602                     (* abstype *)                     (* abstype *)
603                     (begin_block CONSISTENT 0;                     (begin_block CONSISTENT 0;
604                       pps "type";                       pps "type";
# Line 598  Line 606 
606                       pps " ";                       pps " ";
607                       ppSym ppstrm (IP.last path);                       ppSym ppstrm (IP.last path);
608                      end_block())                      end_block())
609                  | T.GENtyc{path, arity, eq,                     | (_, T.DATATYPE{index,family={members,...},...}) =>
                            kind=T.DATATYPE{index,family={members,...},...}, ...} =>  
610                     (* ordinary datatype *)                     (* ordinary datatype *)
611                      let val {dcons,...} = Vector.sub(members,index)                      let val {dcons,...} = Vector.sub(members,index)
612                          val visdcons = visibleDcons(tyc,dcons)                          val visdcons = visibleDcons(tyc,dcons)
613                          val incomplete = length visdcons < length dcons                          val incomplete = length visdcons < length dcons
614                       in begin_block CONSISTENT 0;                       in
615                             begin_block CONSISTENT 0;
616                           pps "datatype";                           pps "datatype";
617                           ppFormals ppstrm arity;                           ppFormals ppstrm arity;
618                           pps " ";                           pps " ";
# Line 623  Line 631 
631                                  end_block());                                  end_block());
632                          end_block()                          end_block()
633                      end                      end
634                 | T.GENtyc{path,arity,...} =>                     | _ =>
635                     (begin_block CONSISTENT 0;                     (begin_block CONSISTENT 0;
636                       if EqTypes.isEqTycon tyc                       if EqTypes.isEqTycon tyc
637                       then pps "eqtype"                       then pps "eqtype"
# Line 631  Line 639 
639                       ppFormals ppstrm arity;                       ppFormals ppstrm arity;
640                       pps " ";                       pps " ";
641                       ppSym ppstrm (IP.last path);                       ppSym ppstrm (IP.last path);
642                      end_block())                        end_block()))
643                 | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>                 | T.DEFtyc{path,tyfun=T.TYFUN{arity,body},...} =>
644                     (begin_block INCONSISTENT 2;                     (begin_block INCONSISTENT 2;
645                       pps "type";                       pps "type";
# Line 862  Line 870 
870              case boundsyms              case boundsyms
871                of NONE => SE.sort env                of NONE => SE.sort env
872                 | SOME l => foldr (fn (x,bs) =>                 | SOME l => foldr (fn (x,bs) =>
873                                      ((x,Env.look(env,x))::bs                                      ((x,SE.look(env,x))::bs
874                                       handle Env.Unbound => bs))                                       handle Env.Unbound => bs))
875                                  [] l                                  [] l
876          val pp_env = Env.atop(env,topenv)          val pp_env = Env.atop(env,topenv)
# Line 884  Line 892 
892            else (case str            else (case str
893                    of M.STR {sign, rlzn as {entities,...}, ...} =>                    of M.STR {sign, rlzn as {entities,...}, ...} =>
894                        (case sign                        (case sign
895                           of M.SIG {elements,...} =>                           of M.SIG {elements = [],...} => ()
896                               (case elements                            | M.SIG {elements,...} =>
                                 of nil => ()  
                                  | _ =>  
897                                      (add_newline ();                                      (add_newline ();
898                                       begin_block CONSISTENT 0;                                       begin_block CONSISTENT 0;
899                                       ppElements (SE.atop(sigToEnv sign, env),                                       ppElements (SE.atop(sigToEnv sign, env),
900                                                   depth,SOME entities)                                                   depth,SOME entities)
901                                                  ppstrm elements;                                                  ppstrm elements;
902                                       end_block ()))                               end_block ())
903                            | M.ERRORsig => ())                            | M.ERRORsig => ())
904                     | M.ERRORstr => ()                     | M.ERRORstr => ()
905                     | M.STRSIG _ => bug "ppOpen");                     | M.STRSIG _ => bug "ppOpen");

Legend:
Removed from v.586  
changed lines
  Added in v.587

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