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 642, Thu May 11 07:30:29 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 : GeneralParams.info -> 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 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
58        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
63      type impexp = DG.impexp      type impexp = DG.impexp
64        type region = GenericVC.SourceMap.region
65    
66      datatype collection =      datatype collection =
67          COLLECTION of { imports: impexp SymbolMap.map,          COLLECTION of { imports: impexp SymbolMap.map,
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: (SrcPath.t * GG.group) list,
72                            sources:
73                                   { class: string, derived: bool } SrcPathMap.map,
74                            reqpriv: GG.privileges }
75          | ERRORCOLLECTION
76    
77      type farlooker = AbsPath.t ->      fun empty' sources =
         { imports: impexp SymbolMap.map, gimports: impexp SymbolMap.map }  
   
     val empty =  
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 = [],
83      fun convertEnv cmenv = let                       sources = sources,
84          fun modulesOnly sl = let                       reqpriv = StringSet.empty }
85              fun addModule (sy, set) =  
86                  case Symbol.nameSpace sy of      val empty = empty' SrcPathMap.empty
87                      (Symbol.STRspace | Symbol.SIGspace |  
88                       Symbol.FCTspace | Symbol.FSIGspace) =>      fun implicit (gp: GeneralParams.info) init_group = let
89                          SymbolSet.add (set, sy)          val { grouppath, ... } =
90                    | _ => set              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          in
97              foldl addModule SymbolSet.empty sl          (* This is a collection that is an implicit member of every
98          end           * library -- the "init" group which exports the pervasive env. *)
99          fun cvt CBE.CM_NONE = NONE          COLLECTION { imports = SymbolMap.empty,
100            | cvt (CBE.CM_ENV { look, symbols }) =                       gimports = SymbolMap.empty,
101              SOME (DG.FCTENV { looker = cvt o look,                       smlfiles = [],
102                                domain = modulesOnly o symbols })                       localdefs = SymbolMap.empty,
103      in                       subgroups = [(grouppath, init_group)],
104          valOf (cvt cmenv)                       sources = sm,
105                         reqpriv = StringSet.empty }
106      end      end
107    
108      fun sequential (COLLECTION c1, COLLECTION c2, error) = let      fun sequential (COLLECTION c1, COLLECTION c2, error) =
109          fun describeSymbol (s, r) = let          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 99  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      end                           subgroups = #subgroups c1 @ #subgroups c2,
144                             sources = s_union (#sources c1, #sources c2),
145      fun expandOne gexports { sourcepath, group, class, error } = let                           reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }
146          fun noPrimitive () = let          end
147              fun e0 s = error s EM.nullErrorBody        | sequential _ = ERRORCOLLECTION
148              val expansions = PrivateTools.expand e0 (sourcepath, class)  
149              fun exp2coll (PrivateTools.GROUP p) = let      fun expandOne { gp, rparse, load_plugin } arg = let
150                      val { imports = i, gimports = gi } = gexports p          val { name, mkpath, group, class, tooloptions, context } = arg
151                  in          val class = Option.map (String.map Char.toLower) class
152            val error = GroupReg.error (#groupreg gp) group
153            fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
154            fun w0 s = error EM.WARN s EM.nullErrorBody
155            val { smlfiles, cmfiles, sources } =
156                PrivateTools.expand { error = e0,
157                                      spec = { name = name,
158                                               mkpath = mkpath,
159                                               class = class,
160                                               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                  end                                   subgroups = [(p, g)],
190                | exp2coll (PrivateTools.SMLSOURCE src) = let                                   sources = SrcPathMap.empty,
191                      val { sourcepath = p, history = h, share = s } = src                                   reqpriv = required }
192                      val i =  SmlInfo.info                  end
193                          Policy.default                | GG.ERRORGROUP => ERRORCOLLECTION
194                          { sourcepath = p, group = group,          fun s_coll (p, s) = let
195                            error = error, history = h,              val i =
196                            share = s }                  SmlInfo.info gp { sourcepath = p, group = group, sh_spec = s }
197                      val exports = SmlInfo.exports i              val exports =
198                    case SmlInfo.exports gp i of
199                        NONE => SS.empty
200                      | SOME ex => (if SS.isEmpty ex then
201                                        w0 ("no module exports from " ^
202                                            SrcPath.descr p)
203                                    else ();
204                                    ex)
205                      fun addLD (s, m) = SymbolMap.insert (m, s, i)                      fun addLD (s, m) = SymbolMap.insert (m, s, i)
206                      val ld = SymbolSet.foldl addLD SymbolMap.empty exports              val ld = SS.foldl addLD SymbolMap.empty exports
207                  in                  in
208                      COLLECTION { imports = SymbolMap.empty,                      COLLECTION { imports = SymbolMap.empty,
209                                   gimports = SymbolMap.empty,                                   gimports = SymbolMap.empty,
210                                   smlfiles = [i],                                   smlfiles = [i],
211                                   localdefs = ld }                           localdefs = ld,
212                             subgroups = [],
213                             sources = SrcPathMap.empty,
214                             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 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))  
                 end  
                 val imp = SymbolSet.foldl addFN SymbolMap.empty exports  
             in  
                 COLLECTION { imports = imp,  
                              gimports = SymbolMap.empty,  
                              smlfiles = [],  
                              localdefs = SymbolMap.empty }  
             end  
           | NONE => noPrimitive ()  
220      end      end
221    
222      fun build (COLLECTION c, fopt, error) = BuildDepend.build (c, fopt, error)      fun build (COLLECTION c, fopt, gp, perv_fsbnode) =
223            BuildDepend.build (c, fopt, gp, perv_fsbnode)
224          | build (ERRORCOLLECTION, _, _, _) =
225            (SymbolMap.empty, StringSet.empty)
226    
227      fun num_look (c: collection) (s: string) = 0      fun subgroups (COLLECTION { subgroups = sg, ... }) = sg
228          | subgroups ERRORCOLLECTION = []
229    
230      fun cm_look (c: collection) (s: string) = false      fun sources (COLLECTION { sources = s, ... }) = s
231          | sources ERRORCOLLECTION = SrcPathMap.empty
232    
233        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.283  
changed lines
  Added in v.642

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