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 652 - (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 354 type context = SrcPath.context
11 :     type pathname = SrcPath.t
12 : blume 297 type region = GenericVC.SourceMap.region
13 : blume 265 type ml_symbol
14 :     type cm_symbol
15 : blume 380 type cm_class
16 : blume 632 type cm_version = Version.t
17 : blume 265
18 : blume 294 type group = GroupGraph.group
19 : blume 265
20 : blume 305 type privilegespec
21 : blume 265 type aexp
22 :     type exp
23 :     type members (* still conditional *)
24 :     type exports (* still conditional *)
25 :    
26 : blume 588 type toolopt
27 :    
28 : blume 266 type complainer = string -> unit
29 :    
30 : blume 267 (* getting elements of primitive types (pathnames and symbols) *)
31 : blume 270 val file_native : string * context -> pathname
32 : blume 632 val file_standard :
33 :     GeneralParams.info -> string * context * complainer -> pathname
34 : blume 265 val cm_symbol : string -> cm_symbol
35 : blume 632 val cm_version : string * complainer -> cm_version
36 : blume 265 val ml_structure : string -> ml_symbol
37 :     val ml_signature : string -> ml_symbol
38 :     val ml_functor : string -> ml_symbol
39 :     val ml_funsig : string -> ml_symbol
40 : blume 380 val class : cm_symbol -> cm_class
41 : blume 265
42 : blume 270 (* getting the full analysis for a group/library *)
43 : blume 632 val group : { path: pathname,
44 :     privileges: privilegespec,
45 :     exports: exports option,
46 :     members: members,
47 :     gp: GeneralParams.info,
48 :     curlib: pathname option,
49 :     owner: pathname option,
50 :     error: complainer,
51 :     initgroup: group } -> group
52 :     val library : { path: pathname,
53 :     privileges: privilegespec,
54 :     exports: exports,
55 :     version : cm_version option,
56 :     members: members,
57 :     gp: GeneralParams.info,
58 :     initgroup: group } -> group
59 : blume 265
60 : blume 283 (* assembling privilege lists *)
61 :     val initialPrivilegeSpec : privilegespec
62 :     val require : privilegespec * cm_symbol * complainer -> privilegespec
63 : blume 348 val wrap : privilegespec * cm_symbol * complainer -> privilegespec
64 : blume 265
65 : blume 267 (* constructing member collections *)
66 : blume 265 val emptyMembers : members
67 : blume 297 val member :
68 : blume 632 { gp: GeneralParams.info,
69 :     rparse: pathname option -> pathname * Version.t option -> group,
70 :     load_plugin: SrcPath.context -> string -> bool }
71 : blume 587 -> { name: string,
72 :     mkpath: string -> pathname,
73 :     group: pathname * region,
74 :     class: cm_class option,
75 : blume 588 tooloptions: toolopt list option,
76 : blume 493 context: SrcPath.context }
77 : blume 270 -> members
78 : blume 265 val members : members * members -> members
79 : blume 443 val guarded_members :
80 :     exp * (members * members) * (string -> unit) -> members
81 : blume 275 val error_member : (unit -> unit) -> members
82 : blume 265
83 : blume 267 (* constructing export lists *)
84 : blume 265 val emptyExports : exports
85 : blume 356 val export : ml_symbol * complainer -> exports
86 : blume 265 val exports : exports * exports -> exports
87 : blume 275 val guarded_exports :
88 :     exp * (exports * exports) * (string -> unit) -> exports
89 :     val error_export : (unit -> unit) -> exports
90 : blume 265
91 : blume 632 (* groups of operator symbols (to make grammar smaller) *)
92 :     type addsym
93 :     val PLUS : addsym
94 :     val MINUS : addsym
95 :    
96 :     type mulsym
97 :     val TIMES : mulsym
98 :     val DIV : mulsym
99 :     val MOD : mulsym
100 :    
101 :     type eqsym
102 :     val EQ : eqsym
103 :     val NE : eqsym
104 :    
105 :     type ineqsym
106 :     val GT : ineqsym
107 :     val GE : ineqsym
108 :     val LT : ineqsym
109 :     val LE : ineqsym
110 :    
111 : blume 267 (* arithmetic (number-valued) expression *)
112 : blume 265 val number : int -> aexp
113 : blume 336 val variable : GeneralParams.info -> cm_symbol -> aexp
114 : blume 632 val add : aexp * addsym * aexp -> aexp
115 :     val mul : aexp * mulsym * aexp -> aexp
116 :     val sign : addsym * aexp -> aexp
117 : blume 265 val negate : aexp -> aexp
118 :    
119 : blume 267 (* (bool-valued) expressions *)
120 : blume 265 val ml_defined : ml_symbol -> exp
121 : blume 336 val cm_defined : GeneralParams.info -> cm_symbol -> exp
122 : blume 265 val conj : exp * exp -> exp
123 :     val disj : exp * exp -> exp
124 : blume 632 val beq : exp * eqsym * exp -> exp
125 : blume 265 val not : exp -> exp
126 : blume 632 val ineq : aexp * ineqsym * aexp -> exp
127 :     val eq : aexp * eqsym * aexp -> exp
128 : blume 588
129 :     (* tool options *)
130 :     val string : { name: string, mkpath: string -> pathname } -> toolopt
131 :     val subopts : { name: string, opts: toolopt list } -> toolopt
132 : blume 265 end
133 :    
134 :     structure CMSemant :> CM_SEMANT = struct
135 :    
136 : blume 267 structure SymPath = GenericVC.SymPath
137 : blume 294 structure EM = GenericVC.ErrorMsg
138 :     structure GG = GroupGraph
139 : blume 267
140 : blume 354 type pathname = SrcPath.t
141 :     type context = SrcPath.context
142 : blume 297 type region = GenericVC.SourceMap.region
143 : blume 267 type ml_symbol = Symbol.symbol
144 : blume 265 type cm_symbol = string
145 : blume 380 type cm_class = string
146 : blume 632 type cm_version = Version.t
147 : blume 265
148 : blume 294 type group = GG.group
149 : blume 348 type privilegespec = { required: GG.privileges, wrapped: GG.privileges }
150 : blume 265
151 : blume 268 type environment = MemberCollection.collection
152 : blume 265
153 :     type aexp = environment -> int
154 :     type exp = environment -> bool
155 : blume 367 type members = environment * pathname option -> MemberCollection.collection
156 : blume 267 type exports = environment -> SymbolSet.set
157 : blume 265
158 : blume 588 type toolopt = PrivateTools.toolopt
159 :    
160 : blume 266 type complainer = string -> unit
161 :    
162 : blume 275 fun saveEval (exp, env, error) =
163 : blume 267 exp env
164 :     handle exn =>
165 : blume 275 (error ("expression raises exception: " ^ General.exnMessage exn);
166 :     false)
167 : blume 267
168 : blume 354 fun file_native (s, d) = SrcPath.native { context = d, spec = s }
169 : blume 632 fun file_standard (gp: GeneralParams.info) (s, d, err) =
170 : blume 643 SrcPath.standard (#pcmode (#param gp))
171 :     { context = d, spec = s, err = err }
172 : blume 265 fun cm_symbol s = s
173 : blume 632 fun cm_version (s, error) =
174 :     case Version.fromString s of
175 :     SOME v => v
176 :     | NONE => (error "ill-formed version specification"; Version.zero)
177 : blume 267 val ml_structure = Symbol.strSymbol
178 :     val ml_signature = Symbol.sigSymbol
179 :     val ml_functor = Symbol.fctSymbol
180 :     val ml_funsig = Symbol.fsigSymbol
181 : blume 265
182 : blume 380 fun class s = String.map Char.toLower s
183 :    
184 : blume 282 fun applyTo mc e = e mc
185 :    
186 : blume 340 fun sgl2sll subgroups = let
187 : blume 444 fun sameSL (p, g) (p', g') = SrcPath.compare (p, p') = EQUAL
188 : blume 340 fun add (x, l) =
189 :     if List.exists (sameSL x) l then l else x :: l
190 : blume 652 fun oneSG (x as (_, gth), l) =
191 :     case gth () of
192 :     GG.GROUP { kind, sublibs, ... } =>
193 :     (case kind of
194 :     GG.NOLIB _ => foldl add l sublibs
195 :     | _ => add (x, l))
196 :     | _ => l
197 : blume 340 in
198 :     foldl oneSG [] subgroups
199 :     end
200 :    
201 : blume 632 fun group arg = let
202 :     val { path = g, privileges = p, exports = e, members = m,
203 :     gp, curlib, owner, error, initgroup } = arg
204 : blume 642 val mc = applyTo (MemberCollection.implicit gp initgroup, curlib) m
205 : blume 283 val filter = Option.map (applyTo mc) e
206 : blume 537 val pfsbn = let
207 : blume 587 val { exports, ... } =
208 : blume 632 case initgroup of
209 : blume 587 GG.GROUP x => x
210 :     | GG.ERRORGROUP =>
211 : blume 632 EM.impossible "semant.sml: group: bad init group"
212 : blume 537 in
213 : blume 592 #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
214 : blume 537 end
215 : blume 652 val (exports, rp) = MemberCollection.build (mc, filter, gp, pfsbn ())
216 :     fun thunkify (p, g) = (p, fn () => g)
217 :     val subgroups = map thunkify (MemberCollection.subgroups mc)
218 : blume 348 val { required = rp', wrapped = wr } = p
219 :     val rp'' = StringSet.union (rp', StringSet.union (rp, wr))
220 : blume 280 in
221 : blume 632 if StringSet.isEmpty wr then ()
222 :     else EM.impossible "group with wrapped privileges";
223 : blume 348 GG.GROUP { exports = exports,
224 : blume 632 kind = GG.NOLIB { subgroups = subgroups, owner = owner },
225 : blume 348 required = rp'',
226 : blume 305 grouppath = g,
227 : blume 642 sources = MemberCollection.sources mc,
228 : blume 348 sublibs = sgl2sll subgroups }
229 : blume 280 end
230 :    
231 : blume 632 fun library arg = let
232 :     val { path = g, privileges = p, exports = e, members = m,
233 :     version, gp, initgroup } = arg
234 : blume 642 val mc = applyTo (MemberCollection.implicit gp initgroup, SOME g) m
235 : blume 632 val filter = SOME (applyTo mc e)
236 :     val pfsbn = let
237 :     val { exports, ... } =
238 :     case initgroup of
239 :     GG.GROUP x => x
240 :     | GG.ERRORGROUP =>
241 :     EM.impossible "semant.sml: lib: bad init group"
242 :     in
243 :     #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
244 :     end
245 : blume 652 val (exports, rp) = MemberCollection.build (mc, filter, gp, pfsbn ())
246 :     fun thunkify (p, g) = (p, fn () => g)
247 :     val subgroups = map thunkify (MemberCollection.subgroups mc)
248 : blume 632 val { required = rp', wrapped = wr } = p
249 :     val rp'' = StringSet.union (rp', StringSet.union (rp, wr))
250 :     in
251 :     GG.GROUP { exports = exports,
252 :     kind = GG.LIB { version = version,
253 :     kind = GG.DEVELOPED { subgroups = subgroups,
254 :     wrapped = wr } },
255 :     required = rp'',
256 :     grouppath = g,
257 : blume 642 sources = MemberCollection.sources mc,
258 : blume 632 sublibs = sgl2sll subgroups }
259 :     end
260 : blume 265
261 : blume 266 local
262 : blume 267 val isMember = StringSet.member
263 : blume 348 fun sanity ({ required, wrapped }, s, error) =
264 :     if isMember (required, s) orelse isMember (wrapped, s) then
265 : blume 283 error ("duplicate privilege name: " ^ s)
266 : blume 266 else ()
267 :     in
268 : blume 283 val initialPrivilegeSpec = { required = StringSet.empty,
269 : blume 348 wrapped = StringSet.empty }
270 :     fun require (a as ({ required, wrapped }, s, _)) =
271 : blume 266 (sanity a;
272 : blume 348 { required = StringSet.add (required, s), wrapped = wrapped })
273 :     fun wrap (a as ({ required, wrapped }, s, _)) =
274 : blume 266 (sanity a;
275 : blume 348 { required = required, wrapped = StringSet.add (wrapped, s) })
276 : blume 266 end
277 : blume 265
278 : blume 367 fun emptyMembers (env, _) = env
279 : blume 632 fun member { gp, rparse, load_plugin } arg (env, curlib) = let
280 :     val coll = MemberCollection.expandOne
281 :     { gp = gp, rparse = rparse curlib,
282 :     load_plugin = load_plugin }
283 :     arg
284 : blume 297 val group = #group arg
285 : blume 299 val error = GroupReg.error (#groupreg gp) group
286 : blume 294 fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
287 : blume 573 fun checkowner (_, GG.GROUP { kind = GG.NOLIB { owner, ... }, ...}) =
288 :     let fun libname NONE = "<toplevel>"
289 :     | libname (SOME p) = SrcPath.descr p
290 :     fun eq (NONE, NONE) = true
291 :     | eq (SOME p, SOME p') = SrcPath.compare (p, p') = EQUAL
292 :     | eq _ = false
293 :     in
294 :     if eq (curlib, owner) then ()
295 : blume 587 else e0 (concat ["owner of subgroup (", libname owner,
296 : blume 573 ") does not match current library (",
297 : monnier 581 libname curlib, ")"])
298 : blume 573 end
299 :     | checkowner _ = ()
300 : blume 270 in
301 : blume 573 app checkowner (MemberCollection.subgroups coll);
302 : blume 277 MemberCollection.sequential (env, coll, e0)
303 : blume 270 end
304 : blume 367 fun members (m1, m2) (env, curlib) = m2 (m1 (env, curlib), curlib)
305 :     fun guarded_members (c, (m1, m2), error) (env, curlib) =
306 :     if saveEval (c, env, error) then m1 (env, curlib) else m2 (env, curlib)
307 :     fun error_member thunk (env, _) = (thunk (); env)
308 : blume 265
309 : blume 267 fun emptyExports env = SymbolSet.empty
310 : blume 356 fun export (s, error) env =
311 :     if MemberCollection.ml_look env s then SymbolSet.singleton s
312 :     else (error (concat ["exported ",
313 :     Symbol.nameSpaceToString (Symbol.nameSpace s),
314 :     " not defined: ", Symbol.name s]);
315 :     SymbolSet.empty)
316 : blume 267 fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
317 : blume 275 fun guarded_exports (c, (e1, e2), error) env =
318 :     if saveEval (c, env, error) then e1 env else e2 env
319 :     fun error_export thunk env = (thunk (); SymbolSet.empty)
320 : blume 265
321 : blume 632 datatype addsym = PLUS | MINUS
322 :     datatype mulsym = TIMES | DIV | MOD
323 :     datatype eqsym = EQ | NE
324 :     datatype ineqsym = GT | GE | LT | LE
325 :    
326 : blume 265 fun number i _ = i
327 : blume 336 fun variable gp v e = MemberCollection.num_look gp e v
328 : blume 632 fun add (e1, PLUS, e2) e = e1 e + e2 e
329 :     | add (e1, MINUS, e2) e = e1 e - e2 e
330 :     fun mul (e1, TIMES, e2) e = e1 e * e2 e
331 :     | mul (e1, DIV, e2) e = e1 e div e2 e
332 :     | mul (e1, MOD, e2) e = e1 e mod e2 e
333 :     fun sign (PLUS, ex) e = ex e
334 :     | sign (MINUS, ex) e = ~(ex e)
335 : blume 265 fun negate ex e = ~(ex e)
336 :    
337 : blume 267 fun ml_defined s e = MemberCollection.ml_look e s
338 : blume 336 fun cm_defined gp s e = MemberCollection.cm_look gp e s
339 : blume 265 fun conj (e1, e2) e = e1 e andalso e2 e
340 :     fun disj (e1, e2) e = e1 e orelse e2 e
341 : blume 632 fun beq (e1: exp, EQ, e2) e = e1 e = e2 e
342 :     | beq (e1, NE, e2) e = e1 e <> e2 e
343 : blume 265 fun not ex e = Bool.not (ex e)
344 : blume 632 fun ineq (e1, LT, e2) e = e1 e < e2 e
345 :     | ineq (e1, LE, e2) e = e1 e <= e2 e
346 :     | ineq (e1, GT, e2) e = e1 e > e2 e
347 :     | ineq (e1, GE, e2) e = e1 e >= e2 e
348 :     fun eq (e1: aexp, EQ, e2) e = e1 e = e2 e
349 :     | eq (e1, NE, e2) e = e1 e <> e2 e
350 : blume 588
351 :     val string = PrivateTools.STRING
352 :     val subopts = PrivateTools.SUBOPTS
353 : blume 265 end

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