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 364, Fri Jul 2 07:33:12 1999 UTC revision 632, Sat Apr 29 15:50:42 2000 UTC
# Line 20  Line 20 
20    
21      val empty : collection      val empty : collection
22    
23      val expandOne : GeneralParams.info * (SrcPath.t -> GroupGraph.group)      val implicit : GroupGraph.group -> collection
24          -> { sourcepath: SrcPath.t, group: SrcPath.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 * GeneralParams.info          collection * SymbolSet.set option * GeneralParams.info *
40            DependencyGraph.farsbnode       (* pervasive env *)
41          -> impexp SymbolMap.map * GroupGraph.privileges          -> impexp SymbolMap.map * GroupGraph.privileges
42    
43      val subgroups : collection -> (SrcPath.t * GroupGraph.group) list      val subgroups : collection -> (SrcPath.t * GroupGraph.group) list
# Line 41  Line 51 
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      structure SS = SymbolSet
56      structure GG = GroupGraph      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
# Line 57  Line 68 
68                          localdefs: smlinfo SymbolMap.map,                          localdefs: smlinfo SymbolMap.map,
69                          subgroups: (SrcPath.t * GG.group) list,                          subgroups: (SrcPath.t * GG.group) list,
70                          reqpriv: GG.privileges }                          reqpriv: GG.privileges }
71          | ERRORCOLLECTION
72    
73      val empty =      val empty =
74          COLLECTION { imports = SymbolMap.empty,          COLLECTION { imports = SymbolMap.empty,
# Line 66  Line 78 
78                       subgroups = [],                       subgroups = [],
79                       reqpriv = StringSet.empty }                       reqpriv = StringSet.empty }
80    
81      fun sequential (COLLECTION c1, COLLECTION c2, error) = let      fun implicit init_group = let
82          fun describeSymbol (s, r) = let          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 = [],
93                         localdefs = SymbolMap.empty,
94                         subgroups = [(grouppath, init_group)],
95                         reqpriv = StringSet.empty }
96        end
97    
98        fun sequential (COLLECTION c1, COLLECTION c2, error) =
99            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
# Line 75  Line 104 
104          fun i_error (s, x as ((f, sbn), e), ((f', sbn'), e')) = let          fun i_error (s, x as ((f, sbn), e), ((f', sbn'), e')) = let
105              fun complain () =              fun complain () =
106                  error (concat (describeSymbol                  error (concat (describeSymbol
107                                 (s, [" imported from ", DG.describeSBN sbn,                                         (s, [" imported from ",
108                                      " and also from ", DG.describeSBN sbn'])))                                              DG.describeSBN sbn,
109                                                " and also from ",
110                                                DG.describeSBN sbn'])))
111              fun union (NONE, _) = NONE              fun union (NONE, _) = NONE
112                | union (_, NONE) = NONE                | union (_, NONE) = NONE
113                | union (SOME f, SOME f') = SOME (SymbolSet.union (f, f'))                | union (SOME f, SOME f') = SOME (SymbolSet.union (f, f'))
# Line 101  Line 132 
132                       subgroups = #subgroups c1 @ #subgroups c2,                       subgroups = #subgroups c1 @ #subgroups c2,
133                       reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }                       reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }
134      end      end
135          | sequential _ = ERRORCOLLECTION
136    
137      fun expandOne (gp, rparse) arg = let      fun expandOne { gp, rparse, load_plugin } arg = let
138          val primconf = #primconf (#param gp)          val { name, mkpath, group, class, tooloptions, context } = arg
         val { sourcepath, group, class } = arg  
139          val class = Option.map (String.map Char.toLower) class          val class = Option.map (String.map Char.toLower) class
140          val error = GroupReg.error (#groupreg gp) group          val error = GroupReg.error (#groupreg gp) group
         fun noPrimitive () = let  
141              fun e0 s = error EM.COMPLAIN s EM.nullErrorBody              fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
142              fun w0 s = error EM.WARN s EM.nullErrorBody              fun w0 s = error EM.WARN s EM.nullErrorBody
143              val expansions = PrivateTools.expand e0 (sourcepath, class)          val { smlfiles, cmfiles } =
144              fun exp2coll (PrivateTools.GROUP p) = let              PrivateTools.expand { error = e0,
145                      val g as GG.GROUP { exports = i, kind, required, ... } =                                    spec = (name, mkpath, class, tooloptions),
146                          rparse p                                    context = context,
147                      val gi = case kind of GG.NOLIB => i | _ => SymbolMap.empty                                    load_plugin = load_plugin }
148                  in          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                                   subgroups = [(p, g)],                                   subgroups = [(p, g)],
173                                   reqpriv = required }                                   reqpriv = required }
174                  end                  end
175                | exp2coll (PrivateTools.SMLSOURCE src) = let                | GG.ERRORGROUP => ERRORCOLLECTION
176                      val { sourcepath = p, history = h, share = s } = src          fun s_coll (p, s) = let
177                      val i = SmlInfo.info gp              val i =
178                          { sourcepath = p,                  SmlInfo.info gp { sourcepath = p, group = group, sh_spec = s }
                           group = group,  
                           share = s,  
                           split = true }  
179                      val exports =                      val exports =
180                          case SmlInfo.exports gp i of                          case SmlInfo.exports gp i of
181                              NONE => SS.empty                              NONE => SS.empty
# Line 146  Line 194 
194                                   subgroups = [],                                   subgroups = [],
195                                   reqpriv = StringSet.empty }                                   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
     in  
         if isSome class then noPrimitive ()  
         else case Primitive.fromString primconf (SrcPath.specOf sourcepath) of  
             SOME p => let  
                 val exports = Primitive.exports primconf p  
                 val env = Primitive.da_env primconf p  
                 fun addFN (s, m) = let  
                     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 ()  
     end  
202    
203      fun build (COLLECTION c, fopt, gp) =      fun build (COLLECTION c, fopt, gp, perv_fsbnode) =
204          BuildDepend.build (c, fopt, gp)          BuildDepend.build (c, fopt, gp, perv_fsbnode)
205          | build (ERRORCOLLECTION, _, _, _) =
206            (SymbolMap.empty, StringSet.empty)
207    
208      fun subgroups (COLLECTION { subgroups = sg, ... }) = sg      fun subgroups (COLLECTION { subgroups = sg, ... }) = sg
209          | subgroups ERRORCOLLECTION = []
210    
211      local      local
212          fun symenv_look (gp: GeneralParams.info) (c: collection) s =          fun symenv_look (gp: GeneralParams.info) (c: collection) s =
213              SymVal.look (#symenv (#param gp)) s              #get (#symval (#param gp) s) ()
214      in      in
215          fun num_look gp c s = getOpt (symenv_look gp c s, 0)          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)          fun cm_look gp c s = isSome (symenv_look gp c s)
# Line 190  Line 219 
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.364  
changed lines
  Added in v.632

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