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/branches/dbm-type-blame/cm/semant/semant.sml
ViewVC logotype

Annotation of /sml/branches/dbm-type-blame/cm/semant/semant.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3594 - (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 879 type region = 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 : blume 986 exports: exports,
48 : blume 632 members: members,
49 :     gp: GeneralParams.info,
50 : blume 666 curlib: SrcPath.file option,
51 : blume 632 initgroup: group } -> group
52 : blume 986
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 265
61 : blume 283 (* assembling privilege lists *)
62 :     val initialPrivilegeSpec : privilegespec
63 :     val require : privilegespec * cm_symbol * complainer -> privilegespec
64 : blume 348 val wrap : privilegespec * cm_symbol * complainer -> privilegespec
65 : blume 265
66 : blume 267 (* constructing member collections *)
67 : blume 265 val emptyMembers : members
68 : blume 297 val member :
69 : blume 632 { gp: GeneralParams.info,
70 : blume 666 rparse: SrcPath.file option ->
71 :     SrcPath.file * Version.t option * SrcPath.rebindings ->
72 :     group,
73 :     load_plugin: SrcPath.dir -> string -> bool }
74 : blume 587 -> { name: string,
75 : blume 756 mkpath: unit -> SrcPath.prefile,
76 : blume 666 group: SrcPath.file * region,
77 : blume 587 class: cm_class option,
78 : blume 588 tooloptions: toolopt list option,
79 : blume 735 local_registry: toolregistry,
80 : blume 666 context: SrcPath.dir }
81 : blume 270 -> members
82 : blume 265 val members : members * members -> members
83 : blume 443 val guarded_members :
84 :     exp * (members * members) * (string -> unit) -> members
85 : blume 275 val error_member : (unit -> unit) -> members
86 : blume 265
87 : blume 986 (* constructing symbol sets *)
88 :     val export : ml_symbol * complainer -> exports
89 :     val union : exports * exports -> exports
90 :     val difference : exports * exports -> exports
91 :     val intersection : exports * exports -> exports
92 : blume 2258 val exportsource : (unit -> SrcPath.file option) * complainer -> exports
93 :     val exportgroup : (unit -> SrcPath.file option) * complainer -> exports
94 :     val exportlibrary : (unit -> SrcPath.file) * complainer *
95 : blume 986 { hasoptions: bool,
96 :     elab: unit -> members,
97 :     curlib: SrcPath.file option }
98 :     -> exports
99 :    
100 : blume 267 (* constructing export lists *)
101 : blume 265 val emptyExports : exports
102 : blume 986 val guarded_exports : exp * (exports * exports) * complainer -> exports
103 :     val default_group_exports : exports
104 : blume 275 val error_export : (unit -> unit) -> exports
105 : blume 265
106 : blume 632 (* groups of operator symbols (to make grammar smaller) *)
107 :     type addsym
108 :     val PLUS : addsym
109 :     val MINUS : addsym
110 :    
111 :     type mulsym
112 :     val TIMES : mulsym
113 :     val DIV : mulsym
114 :     val MOD : mulsym
115 :    
116 :     type eqsym
117 :     val EQ : eqsym
118 :     val NE : eqsym
119 :    
120 :     type ineqsym
121 :     val GT : ineqsym
122 :     val GE : ineqsym
123 :     val LT : ineqsym
124 :     val LE : ineqsym
125 :    
126 : blume 267 (* arithmetic (number-valued) expression *)
127 : blume 265 val number : int -> aexp
128 : blume 336 val variable : GeneralParams.info -> cm_symbol -> aexp
129 : blume 632 val add : aexp * addsym * aexp -> aexp
130 :     val mul : aexp * mulsym * aexp -> aexp
131 :     val sign : addsym * aexp -> aexp
132 : blume 265 val negate : aexp -> aexp
133 :    
134 : blume 267 (* (bool-valued) expressions *)
135 : dbm 3594 val boolean : bool -> exp
136 : blume 265 val ml_defined : ml_symbol -> exp
137 : blume 336 val cm_defined : GeneralParams.info -> cm_symbol -> exp
138 : blume 265 val conj : exp * exp -> exp
139 :     val disj : exp * exp -> exp
140 : blume 632 val beq : exp * eqsym * exp -> exp
141 : blume 265 val not : exp -> exp
142 : blume 632 val ineq : aexp * ineqsym * aexp -> exp
143 :     val eq : aexp * eqsym * aexp -> exp
144 : blume 588
145 :     (* tool options *)
146 : blume 756 val string : { name: string, mkpath: unit -> SrcPath.prefile } -> toolopt
147 : blume 588 val subopts : { name: string, opts: toolopt list } -> toolopt
148 : blume 265 end
149 :    
150 :     structure CMSemant :> CM_SEMANT = struct
151 :    
152 : blume 879 structure SymPath = SymPath
153 :     structure EM = ErrorMsg
154 : blume 294 structure GG = GroupGraph
155 : blume 986 structure MC = MemberCollection
156 : blume 267
157 : blume 666 type context = SrcPath.dir
158 : blume 879 type region = SourceMap.region
159 : blume 267 type ml_symbol = Symbol.symbol
160 : blume 265 type cm_symbol = string
161 : blume 380 type cm_class = string
162 : blume 632 type cm_version = Version.t
163 : blume 265
164 : blume 294 type group = GG.group
165 : blume 348 type privilegespec = { required: GG.privileges, wrapped: GG.privileges }
166 : blume 265
167 : blume 986 type environment = MC.collection
168 : blume 265
169 : blume 986 type exports = environment -> (environment -> unit) SymbolMap.map
170 :    
171 : blume 265 type aexp = environment -> int
172 :     type exp = environment -> bool
173 : blume 986 type members = environment * SrcPath.file option -> MC.collection
174 : blume 265
175 : blume 588 type toolopt = PrivateTools.toolopt
176 : blume 735 type toolregistry = PrivateTools.registry
177 : blume 588
178 : blume 735 val newToolRegistry = PrivateTools.newRegistry
179 :    
180 : blume 266 type complainer = string -> unit
181 :    
182 : blume 275 fun saveEval (exp, env, error) =
183 : blume 267 exp env
184 :     handle exn =>
185 : blume 275 (error ("expression raises exception: " ^ General.exnMessage exn);
186 :     false)
187 : blume 267
188 : blume 666 fun file_native (s, d, err) =
189 :     SrcPath.native { err = err } { context = d, spec = s }
190 : blume 632 fun file_standard (gp: GeneralParams.info) (s, d, err) =
191 : blume 666 SrcPath.standard { env = #penv (#param gp), err = err }
192 :     { context = d, spec = s }
193 : blume 265 fun cm_symbol s = s
194 : blume 632 fun cm_version (s, error) =
195 :     case Version.fromString s of
196 :     SOME v => v
197 :     | NONE => (error "ill-formed version specification"; Version.zero)
198 : blume 267 val ml_structure = Symbol.strSymbol
199 :     val ml_signature = Symbol.sigSymbol
200 :     val ml_functor = Symbol.fctSymbol
201 :     val ml_funsig = Symbol.fsigSymbol
202 : blume 265
203 : blume 380 fun class s = String.map Char.toLower s
204 :    
205 : blume 282 fun applyTo mc e = e mc
206 :    
207 : blume 340 fun sgl2sll subgroups = let
208 : blume 666 fun sameSL (p, _, _) (p', _, _) = SrcPath.compare (p, p') = EQUAL
209 : blume 340 fun add (x, l) =
210 :     if List.exists (sameSL x) l then l else x :: l
211 : blume 666 fun oneSG (x as (_, gth, _), l) =
212 : blume 652 case gth () of
213 :     GG.GROUP { kind, sublibs, ... } =>
214 :     (case kind of
215 : blume 733 GG.NOLIB _ => foldr add l sublibs
216 : blume 652 | _ => add (x, l))
217 :     | _ => l
218 : blume 340 in
219 : blume 733 foldr oneSG [] subgroups
220 : blume 340 end
221 :    
222 : blume 733 (* Filter out unused stuff and thunkify the group. *)
223 :     fun filt_th_sgl (sgl, imp_syms) = let
224 :     (* Add fake "structure <Pervasive>" so that we are sure not to lose
225 :     * the initgroup when filtering. *)
226 :     val ss = SymbolSet.add (imp_syms, PervAccess.pervStrSym)
227 :     fun add ((_, GG.ERRORGROUP, _), l) = l
228 :     | add ((p, g as GG.GROUP { exports, ... }, rb), l) = let
229 :     fun defined_here sy = SymbolMap.inDomain (exports, sy)
230 :     in
231 :     if SymbolSet.exists defined_here ss then
232 :     (p, fn () => g, rb) :: l
233 :     else l
234 :     end
235 :     in
236 :     foldr add [] sgl
237 :     end
238 :    
239 : blume 771 val \/ = StringSet.union
240 :     infix \/
241 :    
242 : blume 986 fun getExports (mc, e) =
243 :     SymbolMap.foldli (fn (sy, c, s) => (c mc; SymbolSet.add (s, sy)))
244 :     SymbolSet.empty
245 :     (applyTo mc e)
246 :    
247 : blume 632 fun group arg = let
248 :     val { path = g, privileges = p, exports = e, members = m,
249 : mblume 1498 gp, curlib, initgroup } = arg
250 : blume 986 val mc = applyTo (MC.implicit gp initgroup, curlib) m
251 :     val filter = getExports (mc, e)
252 : blume 537 val pfsbn = let
253 : blume 587 val { exports, ... } =
254 : blume 632 case initgroup of
255 : blume 587 GG.GROUP x => x
256 :     | GG.ERRORGROUP =>
257 : mblume 1655 EM.impossible "semant.sml: group: bad init group"
258 : blume 537 in
259 : blume 592 #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
260 : blume 537 end
261 : blume 986 val _ = MC.mkIndex (gp, g, mc)
262 : blume 733 val (exports, rp, isl) =
263 : mblume 1879 MC.build (g, mc, filter, gp, pfsbn ())
264 : blume 986 val subgroups = filt_th_sgl (MC.subgroups mc, isl)
265 : blume 348 val { required = rp', wrapped = wr } = p
266 : blume 280 in
267 : blume 632 if StringSet.isEmpty wr then ()
268 :     else EM.impossible "group with wrapped privileges";
269 : blume 348 GG.GROUP { exports = exports,
270 : mblume 1498 kind = GG.NOLIB { subgroups = subgroups,
271 :     owner = curlib },
272 : blume 771 required = rp' \/ rp \/ wr,
273 : blume 305 grouppath = g,
274 : blume 986 sources = MC.sources mc,
275 : blume 348 sublibs = sgl2sll subgroups }
276 : blume 280 end
277 :    
278 : blume 632 fun library arg = let
279 :     val { path = g, privileges = p, exports = e, members = m,
280 :     version, gp, initgroup } = arg
281 : blume 986 val mc = applyTo (MC.implicit gp initgroup, SOME g) m
282 :     val filter = getExports (mc, e)
283 : blume 632 val pfsbn = let
284 :     val { exports, ... } =
285 :     case initgroup of
286 :     GG.GROUP x => x
287 :     | GG.ERRORGROUP =>
288 :     EM.impossible "semant.sml: lib: bad init group"
289 :     in
290 :     #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
291 :     end
292 : blume 986 val _ = MC.mkIndex (gp, g, mc)
293 : blume 733 val (exports, rp, isl) =
294 : mblume 1879 MC.build (g, mc, filter, gp, pfsbn ())
295 : blume 986 val subgroups = filt_th_sgl (MC.subgroups mc, isl)
296 : blume 632 val { required = rp', wrapped = wr } = p
297 :     in
298 :     GG.GROUP { exports = exports,
299 :     kind = GG.LIB { version = version,
300 :     kind = GG.DEVELOPED { subgroups = subgroups,
301 :     wrapped = wr } },
302 : blume 771 required = rp' \/ rp \/ wr,
303 : blume 632 grouppath = g,
304 : blume 986 sources = MC.sources mc,
305 : blume 632 sublibs = sgl2sll subgroups }
306 :     end
307 : blume 265
308 : blume 266 local
309 : blume 267 val isMember = StringSet.member
310 : blume 348 fun sanity ({ required, wrapped }, s, error) =
311 :     if isMember (required, s) orelse isMember (wrapped, s) then
312 : blume 283 error ("duplicate privilege name: " ^ s)
313 : blume 266 else ()
314 :     in
315 : blume 283 val initialPrivilegeSpec = { required = StringSet.empty,
316 : blume 348 wrapped = StringSet.empty }
317 :     fun require (a as ({ required, wrapped }, s, _)) =
318 : blume 266 (sanity a;
319 : blume 348 { required = StringSet.add (required, s), wrapped = wrapped })
320 :     fun wrap (a as ({ required, wrapped }, s, _)) =
321 : blume 266 (sanity a;
322 : blume 348 { required = required, wrapped = StringSet.add (wrapped, s) })
323 : blume 266 end
324 : blume 265
325 : blume 367 fun emptyMembers (env, _) = env
326 : blume 632 fun member { gp, rparse, load_plugin } arg (env, curlib) = let
327 : blume 986 val coll = MC.expandOne
328 : blume 632 { gp = gp, rparse = rparse curlib,
329 :     load_plugin = load_plugin }
330 :     arg
331 : blume 297 val group = #group arg
332 : blume 299 val error = GroupReg.error (#groupreg gp) group
333 : blume 294 fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
334 : blume 270 in
335 : blume 986 MC.sequential (env, coll, e0)
336 : blume 270 end
337 : blume 367 fun members (m1, m2) (env, curlib) = m2 (m1 (env, curlib), curlib)
338 :     fun guarded_members (c, (m1, m2), error) (env, curlib) =
339 :     if saveEval (c, env, error) then m1 (env, curlib) else m2 (env, curlib)
340 :     fun error_member thunk (env, _) = (thunk (); env)
341 : blume 265
342 : blume 986 fun symerr s = concat ["exported ",
343 :     Symbol.nameSpaceToString (Symbol.nameSpace s),
344 :     " not defined: ", Symbol.name s]
345 :    
346 :     fun export (s, error) env = let
347 :     fun check final_env =
348 :     if MC.ml_look final_env s then ()
349 :     else error (symerr s)
350 :     in
351 :     SymbolMap.singleton (s, check)
352 :     end
353 :    
354 :     fun union (x, y) env = SymbolMap.unionWith #1 (x env, y env)
355 :     fun difference (x, y) env = let
356 :     val ymap = y env
357 :     fun inY (s, _) = SymbolMap.inDomain (ymap, s)
358 :     in
359 :     SymbolMap.filteri (not o inY) (x env)
360 :     end
361 :     fun intersection (x, y) env = SymbolMap.intersectWith #1 (x env, y env)
362 :    
363 :     local
364 :     fun withCheckers (ss, error) = let
365 :     fun add1 (s, m) = let
366 :     fun check final_env =
367 :     if MC.ml_look final_env s then ()
368 :     else error (symerr s)
369 :     in
370 :     SymbolMap.insert (m, s, check)
371 :     end
372 :     in
373 :     SymbolSet.foldl add1 SymbolMap.empty ss
374 :     end
375 : blume 2258 fun exportfile F (foptth, error: string -> unit) (env: environment) =
376 :     withCheckers (F (env, foptth (), error), error)
377 : blume 986 in
378 :     val exportsource =
379 :     exportfile MC.smlexports
380 :     val exportgroup =
381 :     exportfile MC.groupexports
382 : blume 2258 fun exportlibrary (pth, error, { hasoptions, elab, curlib }) env = let
383 : blume 986 fun elab' () = elab () (MC.emptycollection, curlib)
384 : blume 2258 val raw = MC.libraryexports (env, pth(), error, hasoptions, elab')
385 : blume 986 in
386 :     withCheckers (raw, error)
387 :     end
388 :     end
389 :    
390 :     fun emptyExports env = SymbolMap.empty
391 : blume 275 fun guarded_exports (c, (e1, e2), error) env =
392 :     if saveEval (c, env, error) then e1 env else e2 env
393 : blume 986 fun default_group_exports env =
394 : blume 2258 union (exportsource (fn () => NONE, fn s => ()),
395 :     exportgroup (fn () => NONE, fn s => ()))
396 : blume 986 env
397 :     fun error_export thunk env = (thunk (); SymbolMap.empty)
398 : blume 265
399 : blume 632 datatype addsym = PLUS | MINUS
400 :     datatype mulsym = TIMES | DIV | MOD
401 :     datatype eqsym = EQ | NE
402 :     datatype ineqsym = GT | GE | LT | LE
403 :    
404 : blume 265 fun number i _ = i
405 : blume 986 fun variable gp v e = MC.num_look gp e v
406 : blume 632 fun add (e1, PLUS, e2) e = e1 e + e2 e
407 :     | add (e1, MINUS, e2) e = e1 e - e2 e
408 :     fun mul (e1, TIMES, e2) e = e1 e * e2 e
409 :     | mul (e1, DIV, e2) e = e1 e div e2 e
410 :     | mul (e1, MOD, e2) e = e1 e mod e2 e
411 :     fun sign (PLUS, ex) e = ex e
412 :     | sign (MINUS, ex) e = ~(ex e)
413 : blume 265 fun negate ex e = ~(ex e)
414 :    
415 : dbm 3594 fun boolean b _ = b
416 : blume 986 fun ml_defined s e = MC.ml_look e s
417 :     fun cm_defined gp s e = MC.cm_look gp e s
418 : blume 265 fun conj (e1, e2) e = e1 e andalso e2 e
419 :     fun disj (e1, e2) e = e1 e orelse e2 e
420 : blume 632 fun beq (e1: exp, EQ, e2) e = e1 e = e2 e
421 :     | beq (e1, NE, e2) e = e1 e <> e2 e
422 : blume 265 fun not ex e = Bool.not (ex e)
423 : blume 632 fun ineq (e1, LT, e2) e = e1 e < e2 e
424 :     | ineq (e1, LE, e2) e = e1 e <= e2 e
425 :     | ineq (e1, GT, e2) e = e1 e > e2 e
426 :     | ineq (e1, GE, e2) e = e1 e >= e2 e
427 :     fun eq (e1: aexp, EQ, e2) e = e1 e = e2 e
428 :     | eq (e1, NE, e2) e = e1 e <> e2 e
429 : blume 588
430 :     val string = PrivateTools.STRING
431 :     val subopts = PrivateTools.SUBOPTS
432 : blume 265 end

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