Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/semant/semant.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/semant/semant.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 840 - (view) (download)

1 : blume 267 (*
2 :     * semantic actions to go with the grammar for CM description files
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 : blume 265 signature CM_SEMANT = sig
9 :    
10 : blume 666 type context = SrcPath.dir
11 : blume 297 type region = GenericVC.SourceMap.region
12 : blume 265 type ml_symbol
13 :     type cm_symbol
14 : blume 380 type cm_class
15 : blume 632 type cm_version = Version.t
16 : blume 265
17 : blume 294 type group = GroupGraph.group
18 : blume 265
19 : blume 305 type privilegespec
20 : blume 265 type aexp
21 :     type exp
22 :     type members (* still conditional *)
23 :     type exports (* still conditional *)
24 :    
25 : blume 588 type toolopt
26 : blume 735 type toolregistry
27 : blume 588
28 : blume 266 type complainer = string -> unit
29 :    
30 : blume 735 val newToolRegistry : unit -> toolregistry
31 :    
32 : blume 267 (* getting elements of primitive types (pathnames and symbols) *)
33 : blume 666 val file_native : string * context * complainer -> SrcPath.prefile
34 : blume 632 val file_standard :
35 : blume 666 GeneralParams.info -> string * context * complainer -> SrcPath.prefile
36 : blume 265 val cm_symbol : string -> cm_symbol
37 : blume 632 val cm_version : string * complainer -> cm_version
38 : blume 265 val ml_structure : string -> ml_symbol
39 :     val ml_signature : string -> ml_symbol
40 :     val ml_functor : string -> ml_symbol
41 :     val ml_funsig : string -> ml_symbol
42 : blume 380 val class : cm_symbol -> cm_class
43 : blume 265
44 : blume 270 (* getting the full analysis for a group/library *)
45 : blume 666 val group : { path: SrcPath.file,
46 : blume 632 privileges: privilegespec,
47 :     exports: exports option,
48 :     members: members,
49 :     gp: GeneralParams.info,
50 : blume 666 curlib: SrcPath.file option,
51 :     owner: SrcPath.file option,
52 : blume 632 initgroup: group } -> group
53 : blume 666 val library : { path: SrcPath.file,
54 : blume 632 privileges: privilegespec,
55 :     exports: exports,
56 :     version : cm_version option,
57 :     members: members,
58 :     gp: GeneralParams.info,
59 :     initgroup: group } -> group
60 : blume 771 val proxy : { path: SrcPath.file,
61 :     privileges: privilegespec,
62 :     members: members,
63 :     error: complainer } -> group
64 : blume 265
65 : blume 283 (* assembling privilege lists *)
66 :     val initialPrivilegeSpec : privilegespec
67 :     val require : privilegespec * cm_symbol * complainer -> privilegespec
68 : blume 348 val wrap : privilegespec * cm_symbol * complainer -> privilegespec
69 : blume 265
70 : blume 267 (* constructing member collections *)
71 : blume 265 val emptyMembers : members
72 : blume 297 val member :
73 : blume 632 { gp: GeneralParams.info,
74 : blume 666 rparse: SrcPath.file option ->
75 :     SrcPath.file * Version.t option * SrcPath.rebindings ->
76 :     group,
77 :     load_plugin: SrcPath.dir -> string -> bool }
78 : blume 587 -> { name: string,
79 : blume 756 mkpath: unit -> SrcPath.prefile,
80 : blume 666 group: SrcPath.file * region,
81 : blume 587 class: cm_class option,
82 : blume 588 tooloptions: toolopt list option,
83 : blume 735 local_registry: toolregistry,
84 : blume 666 context: SrcPath.dir }
85 : blume 270 -> members
86 : blume 265 val members : members * members -> members
87 : blume 443 val guarded_members :
88 :     exp * (members * members) * (string -> unit) -> members
89 : blume 275 val error_member : (unit -> unit) -> members
90 : blume 265
91 : blume 267 (* constructing export lists *)
92 : blume 265 val emptyExports : exports
93 : blume 356 val export : ml_symbol * complainer -> exports
94 : blume 265 val exports : exports * exports -> exports
95 : blume 275 val guarded_exports :
96 :     exp * (exports * exports) * (string -> unit) -> exports
97 :     val error_export : (unit -> unit) -> exports
98 : blume 265
99 : blume 632 (* groups of operator symbols (to make grammar smaller) *)
100 :     type addsym
101 :     val PLUS : addsym
102 :     val MINUS : addsym
103 :    
104 :     type mulsym
105 :     val TIMES : mulsym
106 :     val DIV : mulsym
107 :     val MOD : mulsym
108 :    
109 :     type eqsym
110 :     val EQ : eqsym
111 :     val NE : eqsym
112 :    
113 :     type ineqsym
114 :     val GT : ineqsym
115 :     val GE : ineqsym
116 :     val LT : ineqsym
117 :     val LE : ineqsym
118 :    
119 : blume 267 (* arithmetic (number-valued) expression *)
120 : blume 265 val number : int -> aexp
121 : blume 336 val variable : GeneralParams.info -> cm_symbol -> aexp
122 : blume 632 val add : aexp * addsym * aexp -> aexp
123 :     val mul : aexp * mulsym * aexp -> aexp
124 :     val sign : addsym * aexp -> aexp
125 : blume 265 val negate : aexp -> aexp
126 :    
127 : blume 267 (* (bool-valued) expressions *)
128 : blume 265 val ml_defined : ml_symbol -> exp
129 : blume 336 val cm_defined : GeneralParams.info -> cm_symbol -> exp
130 : blume 265 val conj : exp * exp -> exp
131 :     val disj : exp * exp -> exp
132 : blume 632 val beq : exp * eqsym * exp -> exp
133 : blume 265 val not : exp -> exp
134 : blume 632 val ineq : aexp * ineqsym * aexp -> exp
135 :     val eq : aexp * eqsym * aexp -> exp
136 : blume 588
137 :     (* tool options *)
138 : blume 756 val string : { name: string, mkpath: unit -> SrcPath.prefile } -> toolopt
139 : blume 588 val subopts : { name: string, opts: toolopt list } -> toolopt
140 : blume 265 end
141 :    
142 :     structure CMSemant :> CM_SEMANT = struct
143 :    
144 : blume 267 structure SymPath = GenericVC.SymPath
145 : blume 294 structure EM = GenericVC.ErrorMsg
146 :     structure GG = GroupGraph
147 : blume 267
148 : blume 666 type context = SrcPath.dir
149 : blume 297 type region = GenericVC.SourceMap.region
150 : blume 267 type ml_symbol = Symbol.symbol
151 : blume 265 type cm_symbol = string
152 : blume 380 type cm_class = string
153 : blume 632 type cm_version = Version.t
154 : blume 265
155 : blume 294 type group = GG.group
156 : blume 348 type privilegespec = { required: GG.privileges, wrapped: GG.privileges }
157 : blume 265
158 : blume 268 type environment = MemberCollection.collection
159 : blume 265
160 :     type aexp = environment -> int
161 :     type exp = environment -> bool
162 : blume 666 type members =
163 :     environment * SrcPath.file option -> MemberCollection.collection
164 : blume 267 type exports = environment -> SymbolSet.set
165 : blume 265
166 : blume 588 type toolopt = PrivateTools.toolopt
167 : blume 735 type toolregistry = PrivateTools.registry
168 : blume 588
169 : blume 735 val newToolRegistry = PrivateTools.newRegistry
170 :    
171 : blume 266 type complainer = string -> unit
172 :    
173 : blume 275 fun saveEval (exp, env, error) =
174 : blume 267 exp env
175 :     handle exn =>
176 : blume 275 (error ("expression raises exception: " ^ General.exnMessage exn);
177 :     false)
178 : blume 267
179 : blume 666 fun file_native (s, d, err) =
180 :     SrcPath.native { err = err } { context = d, spec = s }
181 : blume 632 fun file_standard (gp: GeneralParams.info) (s, d, err) =
182 : blume 666 SrcPath.standard { env = #penv (#param gp), err = err }
183 :     { context = d, spec = s }
184 : blume 265 fun cm_symbol s = s
185 : blume 632 fun cm_version (s, error) =
186 :     case Version.fromString s of
187 :     SOME v => v
188 :     | NONE => (error "ill-formed version specification"; Version.zero)
189 : blume 267 val ml_structure = Symbol.strSymbol
190 :     val ml_signature = Symbol.sigSymbol
191 :     val ml_functor = Symbol.fctSymbol
192 :     val ml_funsig = Symbol.fsigSymbol
193 : blume 265
194 : blume 380 fun class s = String.map Char.toLower s
195 :    
196 : blume 282 fun applyTo mc e = e mc
197 :    
198 : blume 340 fun sgl2sll subgroups = let
199 : blume 666 fun sameSL (p, _, _) (p', _, _) = SrcPath.compare (p, p') = EQUAL
200 : blume 340 fun add (x, l) =
201 :     if List.exists (sameSL x) l then l else x :: l
202 : blume 666 fun oneSG (x as (_, gth, _), l) =
203 : blume 652 case gth () of
204 :     GG.GROUP { kind, sublibs, ... } =>
205 :     (case kind of
206 : blume 733 GG.NOLIB _ => foldr add l sublibs
207 : blume 652 | _ => add (x, l))
208 :     | _ => l
209 : blume 340 in
210 : blume 733 foldr oneSG [] subgroups
211 : blume 340 end
212 :    
213 : blume 733 (* Filter out unused stuff and thunkify the group. *)
214 :     fun filt_th_sgl (sgl, imp_syms) = let
215 :     (* Add fake "structure <Pervasive>" so that we are sure not to lose
216 :     * the initgroup when filtering. *)
217 :     val ss = SymbolSet.add (imp_syms, PervAccess.pervStrSym)
218 :     fun add ((_, GG.ERRORGROUP, _), l) = l
219 :     | add ((p, g as GG.GROUP { exports, ... }, rb), l) = let
220 :     fun defined_here sy = SymbolMap.inDomain (exports, sy)
221 :     in
222 :     if SymbolSet.exists defined_here ss then
223 :     (p, fn () => g, rb) :: l
224 :     else l
225 :     end
226 :     in
227 :     foldr add [] sgl
228 :     end
229 :    
230 : blume 771 val \/ = StringSet.union
231 :     infix \/
232 :    
233 : blume 632 fun group arg = let
234 :     val { path = g, privileges = p, exports = e, members = m,
235 : blume 771 gp, curlib, owner, initgroup } = arg
236 : blume 642 val mc = applyTo (MemberCollection.implicit gp initgroup, curlib) m
237 : blume 283 val filter = Option.map (applyTo mc) e
238 : blume 537 val pfsbn = let
239 : blume 587 val { exports, ... } =
240 : blume 632 case initgroup of
241 : blume 587 GG.GROUP x => x
242 :     | GG.ERRORGROUP =>
243 : blume 632 EM.impossible "semant.sml: group: bad init group"
244 : blume 537 in
245 : blume 592 #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
246 : blume 537 end
247 : blume 838 val _ = MemberCollection.mkIndex (gp, g, mc)
248 : blume 733 val (exports, rp, isl) =
249 :     MemberCollection.build (mc, filter, gp, pfsbn ())
250 :     val subgroups = filt_th_sgl (MemberCollection.subgroups mc, isl)
251 : blume 348 val { required = rp', wrapped = wr } = p
252 : blume 280 in
253 : blume 632 if StringSet.isEmpty wr then ()
254 :     else EM.impossible "group with wrapped privileges";
255 : blume 348 GG.GROUP { exports = exports,
256 : blume 771 kind = GG.NOLIB { subgroups = subgroups, owner = owner,
257 :     explicit = Option.isSome e },
258 :     required = rp' \/ rp \/ wr,
259 : blume 305 grouppath = g,
260 : blume 642 sources = MemberCollection.sources mc,
261 : blume 348 sublibs = sgl2sll subgroups }
262 : blume 280 end
263 :    
264 : blume 632 fun library arg = let
265 :     val { path = g, privileges = p, exports = e, members = m,
266 :     version, gp, initgroup } = arg
267 : blume 642 val mc = applyTo (MemberCollection.implicit gp initgroup, SOME g) m
268 : blume 632 val filter = SOME (applyTo mc e)
269 :     val pfsbn = let
270 :     val { exports, ... } =
271 :     case initgroup of
272 :     GG.GROUP x => x
273 :     | GG.ERRORGROUP =>
274 :     EM.impossible "semant.sml: lib: bad init group"
275 :     in
276 :     #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
277 :     end
278 : blume 838 val _ = MemberCollection.mkIndex (gp, g, mc)
279 : blume 733 val (exports, rp, isl) =
280 :     MemberCollection.build (mc, filter, gp, pfsbn ())
281 :     val subgroups = filt_th_sgl (MemberCollection.subgroups mc, isl)
282 : blume 632 val { required = rp', wrapped = wr } = p
283 :     in
284 :     GG.GROUP { exports = exports,
285 :     kind = GG.LIB { version = version,
286 :     kind = GG.DEVELOPED { subgroups = subgroups,
287 :     wrapped = wr } },
288 : blume 771 required = rp' \/ rp \/ wr,
289 : blume 632 grouppath = g,
290 : blume 642 sources = MemberCollection.sources mc,
291 : blume 632 sublibs = sgl2sll subgroups }
292 :     end
293 : blume 265
294 : blume 771 fun proxy arg = let
295 :     val { path = g, members = m, error, privileges = p } = arg
296 :     val { required = rp', wrapped = wr } = p
297 :     val mc = applyTo (MemberCollection.empty, SOME g) m
298 :     fun notone () =
299 :     (error "precisely one sub-group or sub-library required";
300 :     GG.ERRORGROUP)
301 :     fun notexplicit () =
302 :     (error "proxy for component without explicit export list";
303 :     GG.ERRORGROUP)
304 :     in
305 : blume 840 if MemberCollection.is_errorcollection mc then GG.ERRORGROUP
306 :     else if MemberCollection.has_smlfiles mc then notone ()
307 : blume 771 else
308 :     case MemberCollection.subgroups mc of
309 :     [(_, GG.ERRORGROUP, _)] => GG.ERRORGROUP
310 :     | [(p, sg as GG.GROUP grec, rb)] => let
311 :     val { exports, kind, required = rp, ... } = grec
312 :     val sgl = [(p, fn () => sg, rb)]
313 :     fun doit () = let
314 :     val lk = GG.DEVELOPED { subgroups = sgl, wrapped = wr }
315 :     in
316 :     GG.GROUP { exports = exports,
317 :     kind = GG.LIB { version = NONE, kind = lk },
318 :     required = rp \/ rp' \/ wr,
319 :     grouppath = g,
320 :     sources = MemberCollection.sources mc,
321 :     sublibs = sgl2sll sgl }
322 :     end
323 :     in
324 :     case kind of
325 :     GG.LIB _ => doit ()
326 :     | GG.NOLIB { explicit = true, ... } => doit ()
327 :     | _ => notexplicit ()
328 :     end
329 :     | l => notone ()
330 :     end
331 :    
332 : blume 266 local
333 : blume 267 val isMember = StringSet.member
334 : blume 348 fun sanity ({ required, wrapped }, s, error) =
335 :     if isMember (required, s) orelse isMember (wrapped, s) then
336 : blume 283 error ("duplicate privilege name: " ^ s)
337 : blume 266 else ()
338 :     in
339 : blume 283 val initialPrivilegeSpec = { required = StringSet.empty,
340 : blume 348 wrapped = StringSet.empty }
341 :     fun require (a as ({ required, wrapped }, s, _)) =
342 : blume 266 (sanity a;
343 : blume 348 { required = StringSet.add (required, s), wrapped = wrapped })
344 :     fun wrap (a as ({ required, wrapped }, s, _)) =
345 : blume 266 (sanity a;
346 : blume 348 { required = required, wrapped = StringSet.add (wrapped, s) })
347 : blume 266 end
348 : blume 265
349 : blume 367 fun emptyMembers (env, _) = env
350 : blume 632 fun member { gp, rparse, load_plugin } arg (env, curlib) = let
351 :     val coll = MemberCollection.expandOne
352 :     { gp = gp, rparse = rparse curlib,
353 :     load_plugin = load_plugin }
354 :     arg
355 : blume 297 val group = #group arg
356 : blume 299 val error = GroupReg.error (#groupreg gp) group
357 : blume 294 fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
358 : blume 666 fun checkowner (_, GG.GROUP { kind = GG.NOLIB { owner, ... }, ...},
359 :     _) =
360 :     let fun libname NONE = "<toplevel>"
361 : blume 573 | libname (SOME p) = SrcPath.descr p
362 :     fun eq (NONE, NONE) = true
363 :     | eq (SOME p, SOME p') = SrcPath.compare (p, p') = EQUAL
364 :     | eq _ = false
365 :     in
366 :     if eq (curlib, owner) then ()
367 : blume 587 else e0 (concat ["owner of subgroup (", libname owner,
368 : blume 573 ") does not match current library (",
369 : monnier 581 libname curlib, ")"])
370 : blume 573 end
371 :     | checkowner _ = ()
372 : blume 270 in
373 : blume 573 app checkowner (MemberCollection.subgroups coll);
374 : blume 277 MemberCollection.sequential (env, coll, e0)
375 : blume 270 end
376 : blume 367 fun members (m1, m2) (env, curlib) = m2 (m1 (env, curlib), curlib)
377 :     fun guarded_members (c, (m1, m2), error) (env, curlib) =
378 :     if saveEval (c, env, error) then m1 (env, curlib) else m2 (env, curlib)
379 :     fun error_member thunk (env, _) = (thunk (); env)
380 : blume 265
381 : blume 267 fun emptyExports env = SymbolSet.empty
382 : blume 356 fun export (s, error) env =
383 :     if MemberCollection.ml_look env s then SymbolSet.singleton s
384 :     else (error (concat ["exported ",
385 :     Symbol.nameSpaceToString (Symbol.nameSpace s),
386 :     " not defined: ", Symbol.name s]);
387 :     SymbolSet.empty)
388 : blume 267 fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
389 : blume 275 fun guarded_exports (c, (e1, e2), error) env =
390 :     if saveEval (c, env, error) then e1 env else e2 env
391 :     fun error_export thunk env = (thunk (); SymbolSet.empty)
392 : blume 265
393 : blume 632 datatype addsym = PLUS | MINUS
394 :     datatype mulsym = TIMES | DIV | MOD
395 :     datatype eqsym = EQ | NE
396 :     datatype ineqsym = GT | GE | LT | LE
397 :    
398 : blume 265 fun number i _ = i
399 : blume 336 fun variable gp v e = MemberCollection.num_look gp e v
400 : blume 632 fun add (e1, PLUS, e2) e = e1 e + e2 e
401 :     | add (e1, MINUS, e2) e = e1 e - e2 e
402 :     fun mul (e1, TIMES, e2) e = e1 e * e2 e
403 :     | mul (e1, DIV, e2) e = e1 e div e2 e
404 :     | mul (e1, MOD, e2) e = e1 e mod e2 e
405 :     fun sign (PLUS, ex) e = ex e
406 :     | sign (MINUS, ex) e = ~(ex e)
407 : blume 265 fun negate ex e = ~(ex e)
408 :    
409 : blume 267 fun ml_defined s e = MemberCollection.ml_look e s
410 : blume 336 fun cm_defined gp s e = MemberCollection.cm_look gp e s
411 : blume 265 fun conj (e1, e2) e = e1 e andalso e2 e
412 :     fun disj (e1, e2) e = e1 e orelse e2 e
413 : blume 632 fun beq (e1: exp, EQ, e2) e = e1 e = e2 e
414 :     | beq (e1, NE, e2) e = e1 e <> e2 e
415 : blume 265 fun not ex e = Bool.not (ex e)
416 : blume 632 fun ineq (e1, LT, e2) e = e1 e < e2 e
417 :     | ineq (e1, LE, e2) e = e1 e <= e2 e
418 :     | ineq (e1, GT, e2) e = e1 e > e2 e
419 :     | ineq (e1, GE, e2) e = e1 e >= e2 e
420 :     fun eq (e1: aexp, EQ, e2) e = e1 e = e2 e
421 :     | eq (e1, NE, e2) e = e1 e <> e2 e
422 : blume 588
423 :     val string = PrivateTools.STRING
424 :     val subopts = PrivateTools.SUBOPTS
425 : blume 265 end

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