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 301, Fri May 28 09:43:39 1999 UTC revision 642, Thu May 11 07:30:29 2000 UTC
# Line 20  Line 20 
20    
21      val empty : collection      val empty : collection
22    
23      val expandOne : GeneralParams.info * (AbsPath.t -> GroupGraph.group)      val implicit : GeneralParams.info -> GroupGraph.group -> collection
24          -> { sourcepath: AbsPath.t, group: AbsPath.t * region,  
25               class: string option }      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 :      val build :
39          collection * SymbolSet.set option * (string -> unit) *          collection * SymbolSet.set option * GeneralParams.info *
40          GeneralParams.info          DependencyGraph.farsbnode       (* pervasive env *)
41          -> impexp SymbolMap.map * GroupGraph.privileges          -> impexp SymbolMap.map * GroupGraph.privileges
42    
43      val subgroups : collection -> GroupGraph.group list      val subgroups : collection -> (SrcPath.t * GroupGraph.group) list
44        val sources : collection ->
45                      { class: string, derived: bool } SrcPathMap.map
46    
47      val num_look : collection -> string -> int      val num_look : GeneralParams.info -> collection -> string -> int
48        val cm_look : GeneralParams.info -> collection -> string -> bool
49      val ml_look : collection -> symbol -> bool      val ml_look : collection -> symbol -> bool
     val cm_look : collection -> string -> bool  
50  end  end
51    
52  structure MemberCollection :> MEMBERCOLLECTION = struct  structure MemberCollection :> MEMBERCOLLECTION = struct
53    
54      structure DG = DependencyGraph      structure DG = DependencyGraph
55      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
56      structure CBE = GenericVC.BareEnvironment      structure E = GenericVC.Environment
57      structure SS = SymbolSet      structure SS = SymbolSet
58      structure GG = GroupGraph      structure GG = GroupGraph
59        structure V = Version
60    
61      type smlinfo = SmlInfo.info      type smlinfo = SmlInfo.info
62      type symbol = Symbol.symbol      type symbol = Symbol.symbol
# Line 56  Line 68 
68                          gimports: impexp SymbolMap.map,                          gimports: impexp SymbolMap.map,
69                          smlfiles: smlinfo list,                          smlfiles: smlinfo list,
70                          localdefs: smlinfo SymbolMap.map,                          localdefs: smlinfo SymbolMap.map,
71                          subgroups: GG.group list,                          subgroups: (SrcPath.t * GG.group) list,
72                            sources:
73                                   { class: string, derived: bool } SrcPathMap.map,
74                          reqpriv: GG.privileges }                          reqpriv: GG.privileges }
75          | ERRORCOLLECTION
76    
77      val empty =      fun empty' sources =
78          COLLECTION { imports = SymbolMap.empty,          COLLECTION { imports = SymbolMap.empty,
79                       gimports = SymbolMap.empty,                       gimports = SymbolMap.empty,
80                       smlfiles = [],                       smlfiles = [],
81                       localdefs = SymbolMap.empty,                       localdefs = SymbolMap.empty,
82                       subgroups = [],                       subgroups = [],
83                         sources = sources,
84                       reqpriv = StringSet.empty }                       reqpriv = StringSet.empty }
85    
86      fun sequential (COLLECTION c1, COLLECTION c2, error) = let      val empty = empty' SrcPathMap.empty
87          fun describeSymbol (s, r) = let  
88        fun implicit (gp: GeneralParams.info) init_group = let
89            val { grouppath, ... } =
90                case init_group of
91                    GG.GROUP x => x
92                  | GG.ERRORGROUP =>
93                    EM.impossible "members.sml: implicit: bad init group"
94            val sm = SrcPathMap.singleton (grouppath,
95                                           { class = "cm", derived = false })
96        in
97            (* This is a collection that is an implicit member of every
98             * library -- the "init" group which exports the pervasive env. *)
99            COLLECTION { imports = SymbolMap.empty,
100                         gimports = SymbolMap.empty,
101                         smlfiles = [],
102                         localdefs = SymbolMap.empty,
103                         subgroups = [(grouppath, init_group)],
104                         sources = sm,
105                         reqpriv = StringSet.empty }
106        end
107    
108        fun sequential (COLLECTION c1, COLLECTION c2, error) =
109            let fun describeSymbol (s, r) = let
110              val ns = Symbol.nameSpace s              val ns = Symbol.nameSpace s
111          in          in
112              Symbol.nameSpaceToString ns :: " " :: Symbol.name s :: r              Symbol.nameSpaceToString ns :: " " :: Symbol.name s :: r
113          end          end
114          fun i_error (s, x as (fn1, _), (fn2, _)) =              fun i_error (s, x as ((f, sbn), e), ((f', sbn'), e')) = let
115              (error (concat (describeSymbol                  fun complain () =
116                              (s, [" imported from ", DG.describeFarSBN fn1,                      error (concat (describeSymbol
117                                   " and also from ", DG.describeFarSBN fn2])));                                         (s, [" imported from ",
118               x)                                              DG.describeSBN sbn,
119                                                " and also from ",
120                                                DG.describeSBN sbn'])))
121                    fun union (NONE, _) = NONE
122                      | union (_, NONE) = NONE
123                      | union (SOME f, SOME f') = SOME (SymbolSet.union (f, f'))
124                in
125                    if DG.sbeq (sbn, sbn') then
126                        ((union (f, f'), sbn), DAEnv.LAYER (e, e'))
127                    else (complain (); x)
128                end
129          val i_union = SymbolMap.unionWithi i_error          val i_union = SymbolMap.unionWithi i_error
130          val gi_union = SymbolMap.unionWith #1          val gi_union = SymbolMap.unionWith #1
131          fun ld_error (s, f1, f2) =          fun ld_error (s, f1, f2) =
# Line 86  Line 134 
134                                   " and also in ", SmlInfo.spec f2])));                                   " and also in ", SmlInfo.spec f2])));
135               f1)               f1)
136          val ld_union = SymbolMap.unionWithi ld_error          val ld_union = SymbolMap.unionWithi ld_error
137                val s_union = SrcPathMap.unionWith #1
138      in      in
139          COLLECTION { imports = i_union (#imports c1, #imports c2),          COLLECTION { imports = i_union (#imports c1, #imports c2),
140                       gimports = gi_union (#gimports c1, #gimports c2),                       gimports = gi_union (#gimports c1, #gimports c2),
141                       smlfiles = #smlfiles c1 @ #smlfiles c2,                       smlfiles = #smlfiles c1 @ #smlfiles c2,
142                       localdefs = ld_union (#localdefs c1, #localdefs c2),                       localdefs = ld_union (#localdefs c1, #localdefs c2),
143                       subgroups = #subgroups c1 @ #subgroups c2,                       subgroups = #subgroups c1 @ #subgroups c2,
144                             sources = s_union (#sources c1, #sources c2),
145                       reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }                       reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }
146      end      end
147          | sequential _ = ERRORCOLLECTION
148    
149      fun expandOne (gp, rparse) arg = let      fun expandOne { gp, rparse, load_plugin } arg = let
150          val primconf = #primconf (#param gp)          val { name, mkpath, group, class, tooloptions, context } = arg
151          val { sourcepath, group, class } = arg          val class = Option.map (String.map Char.toLower) class
152          val error = GroupReg.error (#groupreg gp) group          val error = GroupReg.error (#groupreg gp) group
         fun noPrimitive () = let  
153              fun e0 s = error EM.COMPLAIN s EM.nullErrorBody              fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
154              fun w0 s = error EM.WARN s EM.nullErrorBody              fun w0 s = error EM.WARN s EM.nullErrorBody
155              val expansions = PrivateTools.expand e0 (sourcepath, class)          val { smlfiles, cmfiles, sources } =
156              fun exp2coll (PrivateTools.GROUP p) = let              PrivateTools.expand { error = e0,
157                      val g as GG.GROUP { exports = i, islib, privileges, ... } =                                    spec = { name = name,
158                          rparse p                                             mkpath = mkpath,
159                      val gi = if islib then SymbolMap.empty else i                                             class = class,
160                  in                                             opts = tooloptions,
161                                               derived = false },
162                                      context = context,
163                                      load_plugin = load_plugin }
164            val msources = foldl SrcPathMap.insert' SrcPathMap.empty sources
165            fun g_coll (p, v) =
166                case rparse (p, v) of
167                    g as GG.GROUP { exports = i, kind, required, sources,
168                                    grouppath, sublibs } => let
169                        val (gi, ver) =
170                            case kind of
171                                GG.NOLIB _ => (i, NONE)
172                              | GG.LIB l => (SymbolMap.empty, #version l)
173                    in
174                        case (v, ver) of
175                            (NONE, _) => ()
176                          | (SOME vrq, NONE) =>
177                            e0 "library does not carry a version stamp"
178                          | (SOME vrq, SOME ver) =>
179                            (case V.compare (vrq, ver) of
180                                 GREATER => e0 "library is older than expected"
181                               | EQUAL => ()
182                               | LESS =>
183                                 (case V.compare (V.nextMajor vrq, ver) of
184                                      GREATER =>
185                                       w0 "library is slightly newer than expected"
186                                    | _ => e0 "library is newer than expected"));
187                      COLLECTION { imports = i, gimports = gi, smlfiles = [],                      COLLECTION { imports = i, gimports = gi, smlfiles = [],
188                                   localdefs = SymbolMap.empty,                                   localdefs = SymbolMap.empty,
189                                   subgroups = [g],                                   subgroups = [(p, g)],
190                                   reqpriv = #required privileges }                                   sources = SrcPathMap.empty,
191                  end                                   reqpriv = required }
192                | exp2coll (PrivateTools.SMLSOURCE src) = let                  end
193                      val { sourcepath = p, history = h, share = s } = src                | GG.ERRORGROUP => ERRORCOLLECTION
194                      val i = SmlInfo.info gp          fun s_coll (p, s) = let
195                          { sourcepath = p,              val i =
196                            group = group,                  SmlInfo.info gp { sourcepath = p, group = group, sh_spec = s }
                           share = s }  
197                      val exports =                      val exports =
198                          case SmlInfo.exports gp i of                          case SmlInfo.exports gp i of
199                              NONE => SS.empty                              NONE => SS.empty
200                            | SOME ex => (if SS.isEmpty ex then                            | SOME ex => (if SS.isEmpty ex then
201                                              w0 ("no module exports from " ^                                              w0 ("no module exports from " ^
202                                                  AbsPath.name p)                                          SrcPath.descr p)
203                                          else ();                                          else ();
204                                          ex)                                          ex)
205                      fun addLD (s, m) = SymbolMap.insert (m, s, i)                      fun addLD (s, m) = SymbolMap.insert (m, s, i)
# Line 135  Line 210 
210                                   smlfiles = [i],                                   smlfiles = [i],
211                                   localdefs = ld,                                   localdefs = ld,
212                                   subgroups = [],                                   subgroups = [],
213                             sources = SrcPathMap.empty,
214                                   reqpriv = StringSet.empty }                                   reqpriv = StringSet.empty }
215                  end                  end
216              val collections = map exp2coll expansions          val collections = map g_coll cmfiles @ map s_coll smlfiles
217              fun combine (c1, c2) = sequential (c2, c1, e0)              fun combine (c1, c2) = sequential (c2, c1, e0)
218          in          in
219              foldl combine empty collections          foldl combine (empty' msources) collections
         end  
     in  
         if isSome class then noPrimitive ()  
         else case Primitive.fromString (AbsPath.spec sourcepath) of  
             SOME p => let  
                 val exports = Primitive.exports primconf p  
                 val plook = Primitive.lookup primconf p  
                 fun addFN (s, m) = let  
                     val env = plook s  
                     val fsbn = (NONE, DG.SB_BNODE (DG.PNODE p))  
                 in  
                     SymbolMap.insert (m, s, (fsbn, env))  
                 end  
                 val imp = SS.foldl addFN SymbolMap.empty exports  
             in  
                 COLLECTION { imports = imp,  
                              gimports = SymbolMap.empty,  
                              smlfiles = [],  
                              localdefs = SymbolMap.empty,  
                              subgroups = [],  
                              reqpriv = Primitive.reqpriv p }  
             end  
           | NONE => noPrimitive ()  
220      end      end
221    
222      fun build (COLLECTION c, fopt, error, gp) =      fun build (COLLECTION c, fopt, gp, perv_fsbnode) =
223          BuildDepend.build (c, fopt, error, gp)          BuildDepend.build (c, fopt, gp, perv_fsbnode)
224          | build (ERRORCOLLECTION, _, _, _) =
225            (SymbolMap.empty, StringSet.empty)
226    
227      fun subgroups (COLLECTION { subgroups = sg, ... }) = sg      fun subgroups (COLLECTION { subgroups = sg, ... }) = sg
228          | subgroups ERRORCOLLECTION = []
229    
230      fun num_look (c: collection) (s: string) = 0      fun sources (COLLECTION { sources = s, ... }) = s
231          | sources ERRORCOLLECTION = SrcPathMap.empty
232    
233      fun cm_look (c: collection) (s: string) = false      local
234            fun symenv_look (gp: GeneralParams.info) (c: collection) s =
235                #get (#symval (#param gp) s) ()
236        in
237            fun num_look gp c s = getOpt (symenv_look gp c s, 0)
238            fun cm_look gp c s = isSome (symenv_look gp c s)
239        end
240    
241      fun ml_look (COLLECTION { imports, localdefs, ... }) s =      fun ml_look (COLLECTION { imports, localdefs, ... }) s =
242          isSome (SymbolMap.find (imports, s)) orelse          isSome (SymbolMap.find (imports, s)) orelse
243          isSome (SymbolMap.find (localdefs, s))          isSome (SymbolMap.find (localdefs, s))
244          | ml_look ERRORCOLLECTON _ = true
245  end  end

Legend:
Removed from v.301  
changed lines
  Added in v.642

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