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/elaborate/elabmod.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/Elaborator/elaborate/elabmod.sml

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

revision 2417, Wed Apr 18 14:26:11 2007 UTC revision 2418, Wed Apr 18 15:32:14 2007 UTC
# Line 335  Line 335 
335  fun extractSig (env, epContext, context,  fun extractSig (env, epContext, context,
336                  compInfo as {mkStamp,...} : EU.compInfo,                  compInfo as {mkStamp,...} : EU.compInfo,
337                  absDecl) =                  absDecl) =
338    let fun getDeclOrder(decl) =    let fun getEpOp (look, modId) =
           let fun procstrbs([]) = []  
                 | procstrbs((A.STRB{name,...})::rest) = name::(procstrbs rest)  
               fun procpat(A.VARpat(V.VALvar{path,...})) = [SymPath.first path]  
                 | procpat(A.VARpat(_)) =  
                     bug "elabmod: extractSig -- Bad VARpat"  
                 | procpat(A.RECORDpat{fields,...}) =  
                     foldl (fn ((_,pat), names) => (procpat pat)@names) []  
                           fields  
                 | procpat(A.APPpat(_,_,pat)) = procpat pat  
                 | procpat(A.CONSTRAINTpat(pat,_)) = procpat pat  
                 | procpat(A.LAYEREDpat(pat,pat')) =  
                     (procpat pat)@(procpat pat')  
                 | procpat(A.ORpat(pat,pat')) = (procpat pat)@(procpat pat')  
                 | procpat(A.VECTORpat(pats,_)) =  
                     foldl (fn (pat,names) => (procpat pat)@names) [] pats  
                 | procpat _ = []  
               fun procvbs([]) = []  
                 | procvbs((A.VB{pat,...})::rest) =  
                     (procpat pat)@(procvbs rest)  
               fun proctycs([]) = []  
                 | proctycs(tyc::rest) = (TU.tycName tyc)::(proctycs rest)  
               fun procdatatycs([]) = []  
                 | procdatatycs(T.GENtyc{kind=T.DATATYPE dt, path, ...}::rest) =  
                     let val {index,family as {members,...},...} = dt  
                         val {tycname,dcons,...} = Vector.sub(members,index)  
                         val pathname = InvPath.last path  
                     in (map (fn ({name,...}) => name) dcons)@  
                        (pathname::procdatatycs rest)  
                     end  
                 | procdatatycs(_) = bug "elabmod: extractSig -- bad datatycs"  
               fun procebs([]) = []  
                 | procebs((A.EBgen{exn=T.DATACON{name,...},...})::rest) =  
                     name::(procebs rest)  
                 | procebs((A.EBdef{exn=T.DATACON{name,...},...})::rest) =  
                     name::(procebs rest)  
               fun procfctbs([]) = []  
                 | procfctbs(A.FCTB{name,...}::rest) = name::(procfctbs rest)  
               fun procstr(M.STR{sign=M.SIG{symbols,...},...}) = symbols  
                 | procstr(M.STR{sign=M.ERRORsig,...}) =  
                     bug "elabmod: extractSig ERRORsig"  
                 | procstr(M.STRSIG{sign=M.SIG{symbols,...},...}) = symbols  
                 | procstr(M.STRSIG{sign=M.ERRORsig,...}) =  
                     bug "elabmod: extractSig ERRORsig in STRSIG"  
                 | procstr(M.ERRORstr) = bug "elabmod: extractSig ERRORstr"  
               fun procrvbs([]) = []  
                 | procrvbs(A.RVB{var=V.VALvar{path,...},...}::rest) =  
                     (SymPath.first path)::(procrvbs rest)  
                 | procrvbs(_::rest) = bug "elabmod: extractSig -- Bad RVB"  
           in case decl  
               of A.STRdec(strbs) => procstrbs strbs  
                | A.VALdec(vbs) => procvbs vbs  
                | A.VALRECdec(rvbs) => procrvbs rvbs  
                | A.TYPEdec(tycs) => proctycs tycs  
                | A.DATATYPEdec{datatycs,withtycs} =>  
                    (procdatatycs datatycs)@(proctycs withtycs)  
                | A.ABSTYPEdec{abstycs,withtycs,body} =>  
                    (proctycs abstycs)@(proctycs withtycs)@(getDeclOrder body)  
                | A.EXCEPTIONdec(ebs) => procebs ebs  
                | A.ABSdec(strbs) => procstrbs strbs  
                | A.FCTdec(fctbs) => procfctbs fctbs  
                | A.OPENdec(pathstrs) =>  
                    foldl (fn (str,names) => (procstr str)@names) []  
                          (map #2 pathstrs)  
                | A.LOCALdec(_,dec) => (getDeclOrder dec)  
                | A.SEQdec(decs) =>  
                    foldl (fn (dec,names) => (getDeclOrder dec)@names) [] decs  
                | A.MARKdec(dec,_) => getDeclOrder dec  
                | A.FIXdec{ops,...} => ops  
                | _ => bug "elabmod: extractSig Unexpected dec"  
           end  
       fun getEpOp (look, modId) =  
339          case context of EU.INFCT _ => look (epContext, modId)          case context of EU.INFCT _ => look (epContext, modId)
340                        | _ => NONE                        | _ => NONE
341        val relativize =        val relativize =
# Line 545  Line 474 
474                end                end
475    
476            | _ => (elements, entEnv, entDecl, trans, slotCount, fctflag)            | _ => (elements, entEnv, entDecl, trans, slotCount, fctflag)
477                   (* [GK 4/15/07] This consolidate is somehow        (* getDeclOrder : absyn -> symbol list
478                      messing the elements order ... it is supposed           getDeclOrder returns the names of all the surface declaractions
479                      to just eliminate EMPTY bindings.           in decl. We use this function to return the signature elements
480                      SE.foldOverElems seems to fix this problem. We can           in the same order as the structure decls. *)
481                      now compute the elements (specs) in the correct        fun getDeclOrder(decl) =
482                      order on the consolidated list. *)            let fun procstrbs([]) = []
483                    | procstrbs((A.STRB{name,...})::rest) = name::(procstrbs rest)
484                  fun procpat(A.VARpat(V.VALvar{path,...})) = [SymPath.first path]
485                    | procpat(A.VARpat(_)) =
486                        bug "elabmod: extractSig -- Bad VARpat"
487                    | procpat(A.RECORDpat{fields,...}) =
488                        foldl (fn ((_,pat), names) => (procpat pat)@names) []
489                              fields
490                    | procpat(A.APPpat(_,_,pat)) = procpat pat
491                    | procpat(A.CONSTRAINTpat(pat,_)) = procpat pat
492                    | procpat(A.LAYEREDpat(pat,pat')) =
493                        (procpat pat)@(procpat pat')
494                    | procpat(A.ORpat(pat,pat')) = (procpat pat)@(procpat pat')
495                    | procpat(A.VECTORpat(pats,_)) =
496                        foldl (fn (pat,names) => (procpat pat)@names) [] pats
497                    | procpat _ = []
498                  fun procvbs([]) = []
499                    | procvbs((A.VB{pat,...})::rest) =
500                        (procpat pat)@(procvbs rest)
501                  fun proctycs([]) = []
502                    | proctycs(tyc::rest) = (TU.tycName tyc)::(proctycs rest)
503                  fun procdatatycs([]) = []
504                    | procdatatycs(T.GENtyc{kind=T.DATATYPE dt, path, ...}::rest) =
505                        let val {index,family as {members,...},...} = dt
506                            val {tycname,dcons,...} = Vector.sub(members,index)
507                            val pathname = InvPath.last path
508                        in (map (fn ({name,...}) => name) dcons)@
509                           (pathname::procdatatycs rest)
510                        end
511                    | procdatatycs(_) = bug "elabmod: extractSig -- bad datatycs"
512                  fun procebs([]) = []
513                    | procebs((A.EBgen{exn=T.DATACON{name,...},...})::rest) =
514                        name::(procebs rest)
515                    | procebs((A.EBdef{exn=T.DATACON{name,...},...})::rest) =
516                        name::(procebs rest)
517                  fun procfctbs([]) = []
518                    | procfctbs(A.FCTB{name,...}::rest) = name::(procfctbs rest)
519                  fun procstr(M.STR{sign=M.SIG{symbols,...},...}) = symbols
520                    | procstr(M.STR{sign=M.ERRORsig,...}) =
521                        bug "elabmod: extractSig ERRORsig"
522                    | procstr(M.STRSIG{sign=M.SIG{symbols,...},...}) = symbols
523                    | procstr(M.STRSIG{sign=M.ERRORsig,...}) =
524                        bug "elabmod: extractSig ERRORsig in STRSIG"
525                    | procstr(M.ERRORstr) = bug "elabmod: extractSig ERRORstr"
526                  fun procrvbs([]) = []
527                    | procrvbs(A.RVB{var=V.VALvar{path,...},...}::rest) =
528                        (SymPath.first path)::(procrvbs rest)
529                    | procrvbs(_::rest) = bug "elabmod: extractSig -- Bad RVB"
530              in case decl
531                  of A.STRdec(strbs) => procstrbs strbs
532                   | A.VALdec(vbs) => procvbs vbs
533                   | A.VALRECdec(rvbs) => procrvbs rvbs
534                   | A.TYPEdec(tycs) => proctycs tycs
535                   | A.DATATYPEdec{datatycs,withtycs} =>
536                       (procdatatycs datatycs)@(proctycs withtycs)
537                   | A.ABSTYPEdec{abstycs,withtycs,body} =>
538                       (proctycs abstycs)@(proctycs withtycs)@(getDeclOrder body)
539                   | A.EXCEPTIONdec(ebs) => procebs ebs
540                   | A.ABSdec(strbs) => procstrbs strbs
541                   | A.FCTdec(fctbs) => procfctbs fctbs
542                   | A.OPENdec(pathstrs) =>
543                       foldl (fn (str,names) => (procstr str)@names) []
544                             (map #2 pathstrs)
545                   | A.LOCALdec(_,dec) => (getDeclOrder dec)
546                   | A.SEQdec(decs) =>
547                       foldl (fn (dec,names) => (getDeclOrder dec)@names) [] decs
548                   | A.MARKdec(dec,_) => getDeclOrder dec
549                   | A.FIXdec{ops,...} => ops
550                   | _ => bug "elabmod: extractSig Unexpected dec"
551              end
552            (* suppressDuplicates is not strictly necessary for correctness
553               because signature matching will just try to match the duplicate
554               specs to the same type. However, suppressing duplicates will
555               eliminate these extraneous signature match checks.
556               [GK 4/18/07] *)
557          fun suppressDuplicates syms =          fun suppressDuplicates syms =
558              let              let
   
559                  fun helper([], memset, result) = (memset, result)                  fun helper([], memset, result) = (memset, result)
560                    | helper(s::rest, memset, result) =                    | helper(s::rest, memset, result) =
561                      if ST.member(memset,s)                      if ST.member(memset,s)
# Line 561  Line 563 
563                      else helper(rest,ST.add(memset,s),s::result)                      else helper(rest,ST.add(memset,s),s::result)
564              in helper(syms, ST.empty, [])              in helper(syms, ST.empty, [])
565              end              end
566            (* Check that the decl names list computed by getDeclOrder is
567          val (oldset, oldsyms) = suppressDuplicates(SE.symbols env)             equivalent (up to reordering) to the keys in the static
568          val (newset, origdeclorder) = suppressDuplicates(getDeclOrder absDecl)             environment. If they are not equal, then getDeclOrder may
569          val _ = if ST.equal(oldset,newset)             be missing some decl name. We use the decl names list to
570                  then say "elabmod: extractSig oldsyms = newsyms\n"             order the elements in this extracted/inferred signature.
571                  else (say (concat["elabmod: extractSig oldsyms <> newsyms\n",             [GK 4/18/07] *)
572                                   "oldset: ", Int.toString(ST.numItems oldset),          val (envkeyset, envkeyorder) = suppressDuplicates(SE.symbols env)
573                                   "\nnewset: ", Int.toString(ST.numItems newset),          val (declnameset, origdeclorder) =
574                                   "\n"]);                suppressDuplicates(getDeclOrder absDecl)
575                        ST.app (fn s => say ((S.name s)^" ")) (ST.difference(oldset,newset)); say "\noldset "; ST.app (fn s => say ((S.name s)^" ")) oldset;          val _ =
576                       say "\nnewset "; ST.app (fn s => say ((S.name s)^" ")) newset;              if ST.equal(envkeyset,declnameset)
577                       say "\n")              then ()
578                else (debugmsg
579                          (concat["--elabmod: extractSig statenv and absyn decl\
580                                   \mismatch\n\toldset: ",
581                                  Int.toString(ST.numItems envkeyset),
582                                  "\n\tnewset: ",
583                                  Int.toString(ST.numItems declnameset),
584                                  "\n\tDifference: "]);
585                      ST.app (fn s => say ((S.name s)^" "))
586                             (ST.difference(envkeyset,declnameset));
587                      say "\n\toldset ";
588                      ST.app (fn s => say ((S.name s)^" ")) envkeyset;
589                      say "\n\tnewset ";
590                      ST.app (fn s => say ((S.name s)^" ")) declnameset;
591                      say "\n";
592                      bug "elabmod: extractSig getDeclOrder")
593            (* [GK 4/15/07] Consolidate will compact the potentially
594               linear static environment (i.e., BIND(...BIND(...)))
595               into a hashtable (IntStrMap) and therefore eliminate
596               any connection between statenv binding order and the
597               structure declaration order. We use getDeclOrder to
598               extract the structure decl order and then use
599               SE.foldOverElems to compute the elements (specs) in
600               the structure decl order on the consolidated list. *)
601          val cenv = SE.consolidate env          val cenv = SE.consolidate env
602          val (elements, entEnv, entDecl, trans, _, fctflag) =          val (elements, entEnv, entDecl, trans, _, fctflag) =
603            SE.foldOverElems(transBind,(nil, EE.empty, [], [], 0, false),cenv,            SE.foldOverElems(transBind,(nil, EE.empty, [], [], 0, false),cenv,
604                             origdeclorder)                             origdeclorder)
605              handle SE.Unbound => bug "elabmod: extractSig -- SE.foldOverElems \
606                                        \Unbound symbol in origdeclorder"
607       in (rev elements, entEnv, rev entDecl, rev trans, fctflag)       in (rev elements, entEnv, rev entDecl, rev trans, fctflag)
608      end      end
609    

Legend:
Removed from v.2417  
changed lines
  Added in v.2418

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