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 275, Sat May 15 09:54:52 1999 UTC revision 632, Sat Apr 29 15:50:42 2000 UTC
# Line 11  Line 11 
11   *)   *)
12  signature MEMBERCOLLECTION = sig  signature MEMBERCOLLECTION = sig
13    
14      type symbol = GenericVC.Symbol.symbol      type symbol = Symbol.symbol
15      type smlinfo = SmlInfo.info      type smlinfo = SmlInfo.info
16        type impexp = DependencyGraph.impexp
17        type region = GenericVC.SourceMap.region
18    
19      type collection      type collection
20    
21      val empty : collection      val empty : collection
22    
23      val expandOne : (AbsPath.t -> DependencyGraph.farnode SymbolMap.map)      val implicit : GroupGraph.group -> collection
24          -> { sourcepath: AbsPath.t, group: AbsPath.t, class: string option,  
25               error : string -> 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 num_look : collection -> string -> int      val build :
39      val ml_look : collection -> GenericVC.Symbol.symbol -> bool          collection * SymbolSet.set option * GeneralParams.info *
40      val cm_look : collection -> string -> bool          DependencyGraph.farsbnode       (* pervasive env *)
41            -> impexp SymbolMap.map * GroupGraph.privileges
42    
43        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
48  end  end
49    
50  structure MemberCollection :> MEMBERCOLLECTION = struct  structure MemberCollection :> MEMBERCOLLECTION = struct
51    
52      structure DG = DependencyGraph      structure DG = DependencyGraph
53      structure Symbol = GenericVC.Symbol      structure EM = GenericVC.ErrorMsg
54        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
62        type region = GenericVC.SourceMap.region
63    
64      datatype collection =      datatype collection =
65          COLLECTION of { subexports: DG.farnode SymbolMap.map,          COLLECTION of { imports: impexp SymbolMap.map,
66                            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                            reqpriv: GG.privileges }
71          | ERRORCOLLECTION
72    
73      val empty =      val empty =
74          COLLECTION { subexports = SymbolMap.empty,          COLLECTION { imports = SymbolMap.empty,
75                         gimports = SymbolMap.empty,
76                         smlfiles = [],
77                         localdefs = SymbolMap.empty,
78                         subgroups = [],
79                         reqpriv = StringSet.empty }
80    
81        fun implicit init_group = let
82            val { grouppath, ... } =
83                case init_group of
84                    GG.GROUP x => x
85                  | GG.ERRORGROUP =>
86                    EM.impossible "members.sml: implicit: bad init group"
87        in
88            (* 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 = [],                       smlfiles = [],
93                       localdefs = SymbolMap.empty }                       localdefs = SymbolMap.empty,
94                         subgroups = [(grouppath, init_group)],
95                         reqpriv = StringSet.empty }
96        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 se_error (s, x as (_, n1), (_, n2)) =              fun i_error (s, x as ((f, sbn), e), ((f', sbn'), e')) = let
105              (error (concat (describeSymbol                  fun complain () =
106                              (s, [" imported from ", DG.describeNode n1,                      error (concat (describeSymbol
107                                   " and also from ", DG.describeNode n2])));                                         (s, [" imported from ",
108               x)                                              DG.describeSBN sbn,
109          val se_union = SymbolMap.unionWithi se_error                                              " 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
120                val gi_union = SymbolMap.unionWith #1
121          fun ld_error (s, f1, f2) =          fun ld_error (s, f1, f2) =
122              (error (concat (describeSymbol              (error (concat (describeSymbol
123                              (s, [" defined in ", SmlInfo.describe f1,                                      (s, [" defined in ", SmlInfo.spec f1,
124                                   " and also in ", SmlInfo.describe f2])));                                           " and also in ", SmlInfo.spec f2])));
125               f1)               f1)
126          val ld_union = SymbolMap.unionWithi ld_error          val ld_union = SymbolMap.unionWithi ld_error
127      in      in
128          COLLECTION { subexports = se_union (#subexports c1, #subexports c2),              COLLECTION { imports = i_union (#imports c1, #imports c2),
129                             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              val expansions = PrivateTools.expand error (sourcepath, class)  
137              fun exp2coll (PrivateTools.GROUP p) =      fun expandOne { gp, rparse, load_plugin } arg = let
138                  COLLECTION { subexports = gexports p,          val { name, mkpath, group, class, tooloptions, context } = arg
139                               smlfiles = [],          val class = Option.map (String.map Char.toLower) class
140                               localdefs = SymbolMap.empty }          val error = GroupReg.error (#groupreg gp) group
141                | exp2coll (PrivateTools.SMLSOURCE src) = let          fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
142                      val { sourcepath = p, history = h, share = s } = src          fun w0 s = error EM.WARN s EM.nullErrorBody
143                      val i =  SmlInfo.new          val { smlfiles, cmfiles } =
144                          Policy.default              PrivateTools.expand { error = e0,
145                          { sourcepath = p, group = group,                                    spec = (name, mkpath, class, tooloptions),
146                            error = error, history = h,                                    context = context,
147                            share = s, stableinfo = NONE }                                    load_plugin = load_plugin }
148                      val exports = SmlInfo.exports i          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 = [],
171                                     localdefs = SymbolMap.empty,
172                                     subgroups = [(p, g)],
173                                     reqpriv = required }
174                    end
175                  | GG.ERRORGROUP => ERRORCOLLECTION
176            fun s_coll (p, s) = let
177                val i =
178                    SmlInfo.info gp { sourcepath = p, group = group, sh_spec = s }
179                val exports =
180                    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 { subexports = SymbolMap.empty,              COLLECTION { imports = SymbolMap.empty,
191                             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, error)          fun combine (c1, c2) = sequential (c2, c1, e0)
199          in          in
200              foldl combine empty collections              foldl combine empty collections
201          end          end
     in  
         if isSome class then noPrimitive ()  
         else case Primitive.fromString (AbsPath.spec sourcepath) of  
             SOME p => let  
                 val exports = Primitive.exports p  
                 fun addFN (s, m) =  
                     SymbolMap.insert (m, s, (NONE, DG.PNODE p))  
                 val se = SymbolSet.foldl addFN SymbolMap.empty exports  
             in  
                 COLLECTION { subexports = se,  
                              smlfiles = [],  
                              localdefs = SymbolMap.empty }  
             end  
           | NONE => noPrimitive ()  
     end  
202    
203      fun num_look (c: collection) (s: string) = 0      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      fun cm_look (c: collection) (s: string) = false      local
212            fun symenv_look (gp: GeneralParams.info) (c: collection) s =
213                #get (#symval (#param gp) s) ()
214        in
215            fun num_look gp c s = getOpt (symenv_look gp c s, 0)
216            fun cm_look gp c s = isSome (symenv_look gp c s)
217        end
218    
219      fun ml_look (COLLECTION { subexports, localdefs, ... }) s =      fun ml_look (COLLECTION { imports, localdefs, ... }) s =
220          isSome (SymbolMap.find (subexports, 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.275  
changed lines
  Added in v.632

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