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 2408, Mon Apr 16 06:10:46 2007 UTC revision 2571, Sun May 20 15:12:54 2007 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 308  Line 316 
316                     closeBox ppstrm;                     closeBox ppstrm;
317                    closeBox ppstrm)                    closeBox ppstrm)
318    
319                | M.TYCspec{spec,entVar,repl,scope} =>                | M.TYCspec{entVar,info} =>
320                   (if first then () else newline ppstrm;                   (if first then () else newline ppstrm;
321                    openHVBox ppstrm (PP.Rel 0);                    case info
322                        of M.RegTycSpec{spec,repl,scope} =>
323                           (openHVBox ppstrm (PP.Rel 0);
324                     case entityEnvOp                     case entityEnvOp
325                       of NONE =>                       of NONE =>
326                           if repl then                           if repl then
# Line 333  Line 343 
343                           pps ppstrm (Int.toString scope))                           pps ppstrm (Int.toString scope))
344                     else ();                     else ();
345                    closeBox ppstrm)                    closeBox ppstrm)
346                         | M.InfTycSpec{name,arity} =>
347                           (openHVBox ppstrm (PP.Rel 0);
348                             case entityEnvOp
349                               of NONE =>
350                                   (pps ppstrm "type";
351                                    break ppstrm {nsp=1,offset=0};
352                                    ppFormals ppstrm arity; pps ppstrm " ";
353                                    ppSym ppstrm name)
354                                | SOME eenv =>
355                                   (case EE.look(eenv,entVar)
356                                      of M.TYCent tyc =>
357                                           ppTycBind ppstrm (tyc,env)
358                                       | M.ERRORent => pps ppstrm "<ERRORent>"
359                                       | _ => bug "ppElements:TYCent");
360                             if !internals
361                             then (newline ppstrm;
362                                   pps ppstrm "entVar: ";
363                                   pps ppstrm (EntPath.entVarToString entVar))
364                             else ();
365                            closeBox ppstrm))
366    
367                | M.VALspec{spec=typ,...} =>                | M.VALspec{spec=typ,...} =>
368                   (if first then () else newline ppstrm;                   (if first then () else newline ppstrm;
# Line 350  Line 380 
380                   if !internals                   if !internals
381                   then (if first then () else newline ppstrm;                   then (if first then () else newline ppstrm;
382                         ppConBinding ppstrm (dcon,env))                         ppConBinding ppstrm (dcon,env))
383                   else () (* ordinary data constructor, don't print *)                   else () (* don't pring ordinary data constructor,
384                              * because it was printed with its datatype *)
385    
386       in openHVBox ppstrm (PP.Rel 0);       in openHVBox ppstrm (PP.Rel 0);
387          case elements          case elements
# Line 360  Line 391 
391      end      end
392    
393  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =  and ppSignature0 ppstrm (sign,env,depth,entityEnvOp) =
394      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
395                en_pp ppstrm
396          val env = SE.atop(case entityEnvOp          val env = SE.atop(case entityEnvOp
397                              of NONE => sigToEnv sign                              of NONE => sigToEnv sign
398                               | SOME entEnv => strToEnv(sign,entEnv),                               | SOME entEnv => strToEnv(sign,entEnv),
# Line 392  Line 424 
424                      newline. We still use the unfiltered elements                      newline. We still use the unfiltered elements
425                      for determining whether the sig ... end should be                      for determining whether the sig ... end should be
426                      multiline even with just one datatype. *)                      multiline even with just one datatype. *)
427                  val elems' = List.filter                  val elems' =
428                                   (fn (_,M.CONspec{spec=dcon,...}) => false |                      List.filter
429                                       _ => true)                      (fn (_,M.CONspec{spec=T.DATACON{rep=A.EXN _,...},...})
430                                => true
431                          | (_,M.CONspec{spec=dcon,...}) => false
432                          | _ => true)
433                                   elements                                   elements
434               in               in
435               if !internals then               if !internals then
# Line 430  Line 465 
465                    pps "sig";                    pps "sig";
466                    (case elements                    (case elements
467                         of nil => pps " "                         of nil => pps " "
468                            | [(_,M.STRspec _)] => nl_indent ppstrm 2
469                          | [_] => pps " "                          | [_] => pps " "
470                          | _ => nl_indent ppstrm 2);                          | _ => nl_indent ppstrm 2);
471                    openHVBox 0;                    openHVBox 0;
# Line 450  Line 486 
486                    closeBox();                    closeBox();
487                    (case elements                    (case elements
488                      of nil => ()                      of nil => ()
489                         | [(_,M.STRspec _)] => newline()
490                       | [_] => pps " "                       | [_] => pps " "
491                       | _ => newline());                       | _ => newline());
492                    pps "end";                    pps "end";
# Line 459  Line 496 
496      end      end
497    
498  and ppFunsig ppstrm (sign,env,depth) =  and ppFunsig ppstrm (sign,env,depth) =
499      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
500                en_pp ppstrm
501          fun trueBodySig (orig as M.SIG { elements =          fun trueBodySig (orig as M.SIG { elements =
502                                           [(sym, M.STRspec { sign, ... })],                                           [(sym, M.STRspec { sign, ... })],
503                                           ... }) =                                           ... }) =
# Line 505  Line 543 
543    
544  and ppStrEntity ppstrm (e,env,depth) =  and ppStrEntity ppstrm (e,env,depth) =
545      let val {stamp,entities,properties,rpath,stub} = e      let val {stamp,entities,properties,rpath,stub} = e
546          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
547                en_pp ppstrm
548       in if depth <= 1       in if depth <= 1
549          then pps "<structure entity>"          then pps "<structure entity>"
550          else (openHVBox 0;          else (openHVBox 0;
# Line 660  Line 699 
699                                 (break{nsp=1,offset=2};                                 (break{nsp=1,offset=2};
700                                  openHVBox 0;                                  openHVBox 0;
701                                   pps "= "; ppDcon first;                                   pps "= "; ppDcon first;
702                                   app (fn d => (break{nsp=1,offset=0}; pps "| "; ppDcon d))                                   app (fn d => (break{nsp=1,offset=0};
703                                                   pps "| "; ppDcon d))
704                                       rest;                                       rest;
705                                   if incomplete                                   if incomplete
706                                       then (break{nsp=1,offset=0}; pps "... ")                                       then (break{nsp=1,offset=0}; pps "... ")
# Line 687  Line 727 
727                   break{nsp=1,offset=0};                   break{nsp=1,offset=0};
728                   ppType env ppstrm body;                   ppType env ppstrm body;
729                   closeBox ())                   closeBox ())
730                  | T.ERRORtyc =>
731                    (pps "ERRORtyc")
732                  | T.PATHtyc _ =>
733                    (pps "PATHtyc:";
734                     ppTycon env ppstrm tyc)
735                | tycon =>                | tycon =>
736                  (pps "strange tycon: ";                  (pps "strange tycon: ";
737                   ppTycon env ppstrm tycon)                   ppTycon env ppstrm tycon)
738      end (* ppTycBind *)      end (* ppTycBind *)
739    
740  and ppReplBind ppstrm  and ppReplBind ppstrm =
741       (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},env) =      let
742      let val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} = en_pp ppstrm          val {openHVBox, openHOVBox,closeBox,pps,ppi,break,newline} =
743       in openHOVBox 2;                en_pp ppstrm
744        in
745            fn (T.DEFtyc{tyfun=T.TYFUN{body=T.CONty(rightTyc,_),...},path,...},
746                env) =>
747               (* [GK 5/4/07] Does this case ever occur? All datatype
748                  replication tycs are GENtycs after elaboration *)
749               (openHOVBox 2;
750          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
751          ppSym ppstrm (IP.last path);          ppSym ppstrm (IP.last path);
752          pps " ="; break{nsp=1,offset=0};          pps " ="; break{nsp=1,offset=0};
753          pps "datatype"; break{nsp=1,offset=0};          pps "datatype"; break{nsp=1,offset=0};
754          ppTycon env ppstrm rightTyc;          ppTycon env ppstrm rightTyc;
755          closeBox ()              closeBox ())
756      end           | (tyc as T.GENtyc{stamp, arity, eq, kind, path, stub}, env) =>
757    | ppReplBind _ _ = ErrorMsg.impossible "ppReplBind"             (openHOVBox 2;
758                pps "datatype"; break{nsp=1,offset=0};
759                ppSym ppstrm (IP.last path);
760                pps " ="; break{nsp=1,offset=0};
761                ppTycBind ppstrm (tyc, env);
762                closeBox())
763             | (T.PATHtyc _, _) => ErrorMsg.impossible "<replbind:PATHtyc>"
764             | (T.RECtyc _, _) => ErrorMsg.impossible "<replbind:RECtyc>"
765             | (T.FREEtyc _, _) => ErrorMsg.impossible "<replbind:FREEtyc>"
766             | _ => ErrorMsg.impossible "ppReplBind"
767        end (* fun ppReplBind *)
768    
769  and ppEntity ppstrm (entity,env,depth) =  and ppEntity ppstrm (entity,env,depth) =
770      case entity      case entity

Legend:
Removed from v.2408  
changed lines
  Added in v.2571

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