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/cm/semant/members.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/semant/members.sml

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

revision 283, Wed May 19 08:20:58 1999 UTC revision 632, Sat Apr 29 15:50:42 2000 UTC
# Line 14  Line 14 
14      type symbol = Symbol.symbol      type symbol = Symbol.symbol
15      type smlinfo = SmlInfo.info      type smlinfo = SmlInfo.info
16      type impexp = DependencyGraph.impexp      type impexp = DependencyGraph.impexp
17        type region = GenericVC.SourceMap.region
18    
19      type collection      type collection
20    
     type farlooker = AbsPath.t ->  
         { imports: impexp SymbolMap.map, gimports: impexp SymbolMap.map }  
   
21      val empty : collection      val empty : collection
22    
23      val expandOne : farlooker      val implicit : GroupGraph.group -> collection
24          -> { sourcepath: AbsPath.t, group: AbsPath.t, class: string option,  
25               error : string -> (PrettyPrint.ppstream -> unit) -> unit }      val expandOne :
26            { gp: GeneralParams.info,
27              rparse: SrcPath.t * Version.t option -> GroupGraph.group,
28              load_plugin: SrcPath.context -> string -> bool }
29            -> { name: string,
30                 mkpath: string -> SrcPath.t,
31                 group: SrcPath.t * region,
32                 class: string option,
33                 tooloptions: PrivateTools.toolopts option,
34                 context: SrcPath.context }
35          -> collection          -> collection
36      val sequential : collection * collection * (string -> unit) -> collection      val sequential : collection * collection * (string -> unit) -> collection
37    
38      val build : collection * SymbolSet.set option * (string -> unit)      val build :
39          -> impexp SymbolMap.map          collection * SymbolSet.set option * GeneralParams.info *
40            DependencyGraph.farsbnode       (* pervasive env *)
41            -> impexp SymbolMap.map * GroupGraph.privileges
42    
43      val num_look : collection -> string -> int      val subgroups : collection -> (SrcPath.t * GroupGraph.group) list
44    
45        val num_look : GeneralParams.info -> collection -> string -> int
46        val cm_look : GeneralParams.info -> collection -> string -> bool
47      val ml_look : collection -> symbol -> bool      val ml_look : collection -> symbol -> bool
     val cm_look : collection -> string -> bool  
48  end  end
49    
50  structure MemberCollection :> MEMBERCOLLECTION = struct  structure MemberCollection :> MEMBERCOLLECTION = struct
51    
52      structure DG = DependencyGraph      structure DG = DependencyGraph
53      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
54      structure CBE = GenericVC.BareEnvironment      structure E = GenericVC.Environment
55        structure SS = SymbolSet
56        structure GG = GroupGraph
57        structure V = Version
58    
59      type smlinfo = SmlInfo.info      type smlinfo = SmlInfo.info
60      type symbol = Symbol.symbol      type symbol = Symbol.symbol
61      type impexp = DG.impexp      type impexp = DG.impexp
62        type region = GenericVC.SourceMap.region
63    
64      datatype collection =      datatype collection =
65          COLLECTION of { imports: impexp SymbolMap.map,          COLLECTION of { imports: impexp SymbolMap.map,
66                          gimports: impexp SymbolMap.map,                          gimports: impexp SymbolMap.map,
67                          smlfiles: smlinfo list,                          smlfiles: smlinfo list,
68                          localdefs: smlinfo SymbolMap.map }                          localdefs: smlinfo SymbolMap.map,
69                            subgroups: (SrcPath.t * GG.group) list,
70      type farlooker = AbsPath.t ->                          reqpriv: GG.privileges }
71          { imports: impexp SymbolMap.map, gimports: impexp SymbolMap.map }        | ERRORCOLLECTION
72    
73      val empty =      val empty =
74          COLLECTION { imports = SymbolMap.empty,          COLLECTION { imports = SymbolMap.empty,
75                       gimports = SymbolMap.empty,                       gimports = SymbolMap.empty,
76                       smlfiles = [],                       smlfiles = [],
77                       localdefs = SymbolMap.empty }                       localdefs = SymbolMap.empty,
78                         subgroups = [],
79      fun convertEnv cmenv = let                       reqpriv = StringSet.empty }
80          fun modulesOnly sl = let  
81              fun addModule (sy, set) =      fun implicit init_group = let
82                  case Symbol.nameSpace sy of          val { grouppath, ... } =
83                      (Symbol.STRspace | Symbol.SIGspace |              case init_group of
84                       Symbol.FCTspace | Symbol.FSIGspace) =>                  GG.GROUP x => x
85                          SymbolSet.add (set, sy)                | GG.ERRORGROUP =>
86                    | _ => set                  EM.impossible "members.sml: implicit: bad init group"
         in  
             foldl addModule SymbolSet.empty sl  
         end  
         fun cvt CBE.CM_NONE = NONE  
           | cvt (CBE.CM_ENV { look, symbols }) =  
             SOME (DG.FCTENV { looker = cvt o look,  
                               domain = modulesOnly o symbols })  
87      in      in
88          valOf (cvt cmenv)          (* This is a collection that is an implicit member of every
89             * library -- the "init" group which exports the pervasive env. *)
90            COLLECTION { imports = SymbolMap.empty,
91                         gimports = SymbolMap.empty,
92                         smlfiles = [],
93                         localdefs = SymbolMap.empty,
94                         subgroups = [(grouppath, init_group)],
95                         reqpriv = StringSet.empty }
96      end      end
97    
98      fun sequential (COLLECTION c1, COLLECTION c2, error) = let      fun sequential (COLLECTION c1, COLLECTION c2, error) =
99          fun describeSymbol (s, r) = let          let fun describeSymbol (s, r) = let
100              val ns = Symbol.nameSpace s              val ns = Symbol.nameSpace s
101          in          in
102              Symbol.nameSpaceToString ns :: " " :: Symbol.name s :: r              Symbol.nameSpaceToString ns :: " " :: Symbol.name s :: r
103          end          end
104          fun i_error (s, x as (fn1, _), (fn2, _)) =              fun i_error (s, x as ((f, sbn), e), ((f', sbn'), e')) = let
105              (error (concat (describeSymbol                  fun complain () =
106                              (s, [" imported from ", DG.describeFarSBN fn1,                      error (concat (describeSymbol
107                                   " and also from ", DG.describeFarSBN fn2])));                                         (s, [" imported from ",
108               x)                                              DG.describeSBN sbn,
109                                                " and also from ",
110                                                DG.describeSBN sbn'])))
111                    fun union (NONE, _) = NONE
112                      | union (_, NONE) = NONE
113                      | union (SOME f, SOME f') = SOME (SymbolSet.union (f, f'))
114                in
115                    if DG.sbeq (sbn, sbn') then
116                        ((union (f, f'), sbn), DAEnv.LAYER (e, e'))
117                    else (complain (); x)
118                end
119          val i_union = SymbolMap.unionWithi i_error          val i_union = SymbolMap.unionWithi i_error
120          val gi_union = SymbolMap.unionWith #1          val gi_union = SymbolMap.unionWith #1
121          fun ld_error (s, f1, f2) =          fun ld_error (s, f1, f2) =
# Line 103  Line 128 
128          COLLECTION { imports = i_union (#imports c1, #imports c2),          COLLECTION { imports = i_union (#imports c1, #imports c2),
129                       gimports = gi_union (#gimports c1, #gimports c2),                       gimports = gi_union (#gimports c1, #gimports c2),
130                       smlfiles = #smlfiles c1 @ #smlfiles c2,                       smlfiles = #smlfiles c1 @ #smlfiles c2,
131                       localdefs = ld_union (#localdefs c1, #localdefs c2) }                           localdefs = ld_union (#localdefs c1, #localdefs c2),
132      end                           subgroups = #subgroups c1 @ #subgroups c2,
133                             reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }
134      fun expandOne gexports { sourcepath, group, class, error } = let          end
135          fun noPrimitive () = let        | sequential _ = ERRORCOLLECTION
136              fun e0 s = error s EM.nullErrorBody  
137              val expansions = PrivateTools.expand e0 (sourcepath, class)      fun expandOne { gp, rparse, load_plugin } arg = let
138              fun exp2coll (PrivateTools.GROUP p) = let          val { name, mkpath, group, class, tooloptions, context } = arg
139                      val { imports = i, gimports = gi } = gexports p          val class = Option.map (String.map Char.toLower) class
140                  in          val error = GroupReg.error (#groupreg gp) group
141            fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
142            fun w0 s = error EM.WARN s EM.nullErrorBody
143            val { smlfiles, cmfiles } =
144                PrivateTools.expand { error = e0,
145                                      spec = (name, mkpath, class, tooloptions),
146                                      context = context,
147                                      load_plugin = load_plugin }
148            fun g_coll (p, v) =
149                case rparse (p, v) of
150                    g as GG.GROUP { exports = i, kind, required,
151                                    grouppath, sublibs } => let
152                        val (gi, ver) =
153                            case kind of
154                                GG.NOLIB _ => (i, NONE)
155                              | GG.LIB l => (SymbolMap.empty, #version l)
156                    in
157                        case (v, ver) of
158                            (NONE, _) => ()
159                          | (SOME vrq, NONE) =>
160                            e0 "library does not carry a version stamp"
161                          | (SOME vrq, SOME ver) =>
162                            (case V.compare (vrq, ver) of
163                                 GREATER => e0 "library is older than expected"
164                               | EQUAL => ()
165                               | LESS =>
166                                 (case V.compare (V.nextMajor vrq, ver) of
167                                      GREATER =>
168                                       w0 "library is slightly newer than expected"
169                                    | _ => e0 "library is newer than expected"));
170                      COLLECTION { imports = i, gimports = gi, smlfiles = [],                      COLLECTION { imports = i, gimports = gi, smlfiles = [],
171                                   localdefs = SymbolMap.empty }                                   localdefs = SymbolMap.empty,
172                  end                                   subgroups = [(p, g)],
173                | exp2coll (PrivateTools.SMLSOURCE src) = let                                   reqpriv = required }
174                      val { sourcepath = p, history = h, share = s } = src                  end
175                      val i =  SmlInfo.info                | GG.ERRORGROUP => ERRORCOLLECTION
176                          Policy.default          fun s_coll (p, s) = let
177                          { sourcepath = p, group = group,              val i =
178                            error = error, history = h,                  SmlInfo.info gp { sourcepath = p, group = group, sh_spec = s }
179                            share = s }              val exports =
180                      val exports = SmlInfo.exports i                  case SmlInfo.exports gp i of
181                        NONE => SS.empty
182                      | SOME ex => (if SS.isEmpty ex then
183                                        w0 ("no module exports from " ^
184                                            SrcPath.descr p)
185                                    else ();
186                                    ex)
187                      fun addLD (s, m) = SymbolMap.insert (m, s, i)                      fun addLD (s, m) = SymbolMap.insert (m, s, i)
188                      val ld = SymbolSet.foldl addLD SymbolMap.empty exports              val ld = SS.foldl addLD SymbolMap.empty exports
189                  in                  in
190                      COLLECTION { imports = SymbolMap.empty,                      COLLECTION { imports = SymbolMap.empty,
191                                   gimports = SymbolMap.empty,                                   gimports = SymbolMap.empty,
192                                   smlfiles = [i],                                   smlfiles = [i],
193                                   localdefs = ld }                           localdefs = ld,
194                             subgroups = [],
195                             reqpriv = StringSet.empty }
196                  end                  end
197              val collections = map exp2coll expansions          val collections = map g_coll cmfiles @ map s_coll smlfiles
198              fun combine (c1, c2) = sequential (c2, c1, e0)              fun combine (c1, c2) = sequential (c2, c1, e0)
199          in          in
200              foldl combine empty collections              foldl combine empty collections
201          end          end
202    
203        fun build (COLLECTION c, fopt, gp, perv_fsbnode) =
204            BuildDepend.build (c, fopt, gp, perv_fsbnode)
205          | build (ERRORCOLLECTION, _, _, _) =
206            (SymbolMap.empty, StringSet.empty)
207    
208        fun subgroups (COLLECTION { subgroups = sg, ... }) = sg
209          | subgroups ERRORCOLLECTION = []
210    
211        local
212            fun symenv_look (gp: GeneralParams.info) (c: collection) s =
213                #get (#symval (#param gp) s) ()
214      in      in
215          if isSome class then noPrimitive ()          fun num_look gp c s = getOpt (symenv_look gp c s, 0)
216          else case Primitive.fromString (AbsPath.spec sourcepath) of          fun cm_look gp c s = isSome (symenv_look gp c s)
             SOME p => let  
                 val exports = Primitive.exports p  
                 fun addFN (s, m) = let  
                     val cmenv = Primitive.lookup p s  
                     val env = convertEnv cmenv  
                     val fsbn = (NONE, DG.SB_BNODE (DG.PNODE p))  
                 in  
                     SymbolMap.insert (m, s, (fsbn, env))  
217                  end                  end
                 val imp = SymbolSet.foldl addFN SymbolMap.empty exports  
             in  
                 COLLECTION { imports = imp,  
                              gimports = SymbolMap.empty,  
                              smlfiles = [],  
                              localdefs = SymbolMap.empty }  
             end  
           | NONE => noPrimitive ()  
     end  
   
     fun build (COLLECTION c, fopt, error) = BuildDepend.build (c, fopt, error)  
   
     fun num_look (c: collection) (s: string) = 0  
   
     fun cm_look (c: collection) (s: string) = false  
218    
219      fun ml_look (COLLECTION { imports, localdefs, ... }) s =      fun ml_look (COLLECTION { imports, localdefs, ... }) s =
220          isSome (SymbolMap.find (imports, s)) orelse          isSome (SymbolMap.find (imports, s)) orelse
221          isSome (SymbolMap.find (localdefs, s))          isSome (SymbolMap.find (localdefs, s))
222          | ml_look ERRORCOLLECTON _ = true
223  end  end

Legend:
Removed from v.283  
changed lines
  Added in v.632

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