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

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