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 348 - (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 270 type context = AbsPath.context
11 : blume 268 type pathname = AbsPath.t
12 : blume 297 type region = GenericVC.SourceMap.region
13 : blume 265 type ml_symbol
14 :     type cm_symbol
15 :    
16 : blume 294 type group = GroupGraph.group
17 : blume 265
18 : blume 305 type privilegespec
19 : blume 265 type aexp
20 :     type exp
21 :     type members (* still conditional *)
22 :     type exports (* still conditional *)
23 :    
24 : blume 266 type complainer = string -> unit
25 :    
26 : blume 267 (* getting elements of primitive types (pathnames and symbols) *)
27 : blume 270 val file_native : string * context -> pathname
28 : blume 318 val file_standard : GeneralParams.info -> string * context -> pathname
29 : blume 265 val cm_symbol : string -> cm_symbol
30 :     val ml_structure : string -> ml_symbol
31 :     val ml_signature : string -> ml_symbol
32 :     val ml_functor : string -> ml_symbol
33 :     val ml_funsig : string -> ml_symbol
34 :    
35 : blume 270 (* getting the full analysis for a group/library *)
36 : blume 283 val emptyGroup : pathname -> group
37 :     val group :
38 : blume 297 pathname * privilegespec * exports option * members * complainer *
39 : blume 299 GeneralParams.info
40 : blume 283 -> group
41 :     val library :
42 : blume 297 pathname * privilegespec * exports * members * complainer *
43 : blume 299 GeneralParams.info
44 : blume 283 -> group
45 : blume 265
46 : blume 283 (* assembling privilege lists *)
47 :     val initialPrivilegeSpec : privilegespec
48 :     val require : privilegespec * cm_symbol * complainer -> privilegespec
49 : blume 348 val wrap : privilegespec * cm_symbol * complainer -> privilegespec
50 : blume 265
51 : blume 267 (* constructing member collections *)
52 : blume 265 val emptyMembers : members
53 : blume 297 val member :
54 : blume 299 GeneralParams.info * (pathname -> group)
55 : blume 297 -> { sourcepath: pathname, group: pathname * region,
56 :     class: cm_symbol option }
57 : blume 270 -> members
58 : blume 265 val members : members * members -> members
59 : blume 275 val guarded_members :
60 :     exp * (members * members) * (string -> unit) -> members
61 :     val error_member : (unit -> unit) -> members
62 : blume 265
63 : blume 267 (* constructing export lists *)
64 : blume 265 val emptyExports : exports
65 :     val export : ml_symbol -> exports
66 :     val exports : exports * exports -> exports
67 : blume 275 val guarded_exports :
68 :     exp * (exports * exports) * (string -> unit) -> exports
69 :     val error_export : (unit -> unit) -> exports
70 : blume 265
71 : blume 267 (* arithmetic (number-valued) expression *)
72 : blume 265 val number : int -> aexp
73 : blume 336 val variable : GeneralParams.info -> cm_symbol -> aexp
74 : blume 265 val plus : aexp * aexp -> aexp
75 :     val minus : aexp * aexp -> aexp
76 :     val times : aexp * aexp -> aexp
77 :     val divide : aexp * aexp -> aexp
78 :     val modulus : aexp * aexp -> aexp
79 :     val negate : aexp -> aexp
80 :    
81 : blume 267 (* (bool-valued) expressions *)
82 : blume 265 val ml_defined : ml_symbol -> exp
83 : blume 336 val cm_defined : GeneralParams.info -> cm_symbol -> exp
84 : blume 265 val conj : exp * exp -> exp
85 :     val disj : exp * exp -> exp
86 :     val beq : exp * exp -> exp
87 :     val bne : exp * exp -> exp
88 :     val not : exp -> exp
89 :     val lt : aexp * aexp -> exp
90 :     val le : aexp * aexp -> exp
91 :     val gt : aexp * aexp -> exp
92 :     val ge : aexp * aexp -> exp
93 :     val eq : aexp * aexp -> exp
94 :     val ne : aexp * aexp -> exp
95 :     end
96 :    
97 :     structure CMSemant :> CM_SEMANT = struct
98 :    
99 : blume 267 structure SymPath = GenericVC.SymPath
100 : blume 294 structure EM = GenericVC.ErrorMsg
101 :     structure GG = GroupGraph
102 : blume 267
103 : blume 265 type pathname = AbsPath.t
104 : blume 270 type context = AbsPath.context
105 : blume 297 type region = GenericVC.SourceMap.region
106 : blume 267 type ml_symbol = Symbol.symbol
107 : blume 265 type cm_symbol = string
108 :    
109 : blume 294 type group = GG.group
110 : blume 348 type privilegespec = { required: GG.privileges, wrapped: GG.privileges }
111 : blume 265
112 : blume 268 type environment = MemberCollection.collection
113 : blume 265
114 :     type aexp = environment -> int
115 :     type exp = environment -> bool
116 : blume 267 type members = environment -> MemberCollection.collection
117 :     type exports = environment -> SymbolSet.set
118 : blume 265
119 : blume 266 type complainer = string -> unit
120 :    
121 : blume 275 fun saveEval (exp, env, error) =
122 : blume 267 exp env
123 :     handle exn =>
124 : blume 275 (error ("expression raises exception: " ^ General.exnMessage exn);
125 :     false)
126 : blume 267
127 : blume 265 fun file_native (s, d) = AbsPath.native { context = d, spec = s }
128 : blume 318 fun file_standard (gp: GeneralParams.info) (s, d) =
129 :     AbsPath.standard (#pcmode (#param gp)) { context = d, spec = s }
130 : blume 265 fun cm_symbol s = s
131 : blume 267 val ml_structure = Symbol.strSymbol
132 :     val ml_signature = Symbol.sigSymbol
133 :     val ml_functor = Symbol.fctSymbol
134 :     val ml_funsig = Symbol.fsigSymbol
135 : blume 265
136 : blume 282 fun applyTo mc e = e mc
137 :    
138 : blume 283 fun emptyGroup path =
139 : blume 294 GG.GROUP { exports = SymbolMap.empty,
140 : blume 348 kind = GG.NOLIB,
141 : blume 305 required = StringSet.empty,
142 : blume 294 grouppath = path,
143 : blume 348 sublibs = [] }
144 : blume 282
145 : blume 340 fun sgl2sll subgroups = let
146 :     fun sameSL (_, GG.GROUP g) (_, GG.GROUP g') =
147 :     AbsPath.compare (#grouppath g, #grouppath g') = EQUAL
148 :     fun add (x, l) =
149 :     if List.exists (sameSL x) l then l else x :: l
150 : blume 348 fun oneSG (x as (_, GG.GROUP { kind, sublibs, ... }), l) =
151 :     case kind of
152 :     GG.NOLIB => foldl add l sublibs
153 :     | _ => add (x, l)
154 : blume 340 in
155 :     foldl oneSG [] subgroups
156 :     end
157 :    
158 : blume 348 fun grouplib (islib, g, p, e, m, error, gp) = let
159 : blume 282 val mc = applyTo MemberCollection.empty m
160 : blume 283 val filter = Option.map (applyTo mc) e
161 : blume 301 val (exports, rp) = MemberCollection.build (mc, filter, error, gp)
162 : blume 294 val subgroups = MemberCollection.subgroups mc
163 : blume 348 val { required = rp', wrapped = wr } = p
164 :     val rp'' = StringSet.union (rp', StringSet.union (rp, wr))
165 : blume 280 in
166 : blume 348 GG.GROUP { exports = exports,
167 :     kind = if islib then GG.LIB wr
168 :     else (if StringSet.isEmpty wr then ()
169 :     else EM.impossible
170 :     "group with wrapped privilege";
171 :     GG.NOLIB),
172 :     required = rp'',
173 : blume 305 grouppath = g,
174 : blume 348 sublibs = sgl2sll subgroups }
175 : blume 280 end
176 :    
177 : blume 348 fun group (g, p, e, m, error, gp) =
178 :     grouplib (false, g, p, e, m, error, gp)
179 :     fun library (g, p, e, m, error, gp) =
180 :     grouplib (true, g, p, SOME e, m, error, gp)
181 : blume 265
182 : blume 266 local
183 : blume 267 val isMember = StringSet.member
184 : blume 348 fun sanity ({ required, wrapped }, s, error) =
185 :     if isMember (required, s) orelse isMember (wrapped, s) then
186 : blume 283 error ("duplicate privilege name: " ^ s)
187 : blume 266 else ()
188 :     in
189 : blume 283 val initialPrivilegeSpec = { required = StringSet.empty,
190 : blume 348 wrapped = StringSet.empty }
191 :     fun require (a as ({ required, wrapped }, s, _)) =
192 : blume 266 (sanity a;
193 : blume 348 { required = StringSet.add (required, s), wrapped = wrapped })
194 :     fun wrap (a as ({ required, wrapped }, s, _)) =
195 : blume 266 (sanity a;
196 : blume 348 { required = required, wrapped = StringSet.add (wrapped, s) })
197 : blume 266 end
198 : blume 265
199 : blume 268 fun emptyMembers env = env
200 : blume 299 fun member (gp, rparse) arg env = let
201 :     val coll = MemberCollection.expandOne (gp, rparse) arg
202 : blume 297 val group = #group arg
203 : blume 299 val error = GroupReg.error (#groupreg gp) group
204 : blume 294 fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
205 : blume 270 in
206 : blume 277 MemberCollection.sequential (env, coll, e0)
207 : blume 270 end
208 : blume 268 fun members (m1, m2) env = m2 (m1 env)
209 : blume 275 fun guarded_members (c, (m1, m2), error) env =
210 :     if saveEval (c, env, error) then m1 env else m2 env
211 :     fun error_member thunk env = (thunk (); env)
212 : blume 265
213 : blume 267 fun emptyExports env = SymbolSet.empty
214 :     fun export s env = SymbolSet.singleton s
215 :     fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
216 : blume 275 fun guarded_exports (c, (e1, e2), error) env =
217 :     if saveEval (c, env, error) then e1 env else e2 env
218 :     fun error_export thunk env = (thunk (); SymbolSet.empty)
219 : blume 265
220 :     fun number i _ = i
221 : blume 336 fun variable gp v e = MemberCollection.num_look gp e v
222 : blume 265 fun plus (e1, e2) e = e1 e + e2 e
223 :     fun minus (e1, e2) e = e1 e - e2 e
224 :     fun times (e1, e2) e = e1 e * e2 e
225 :     fun divide (e1, e2) e = e1 e div e2 e
226 :     fun modulus (e1, e2) e = e1 e mod e2 e
227 :     fun negate ex e = ~(ex e)
228 :    
229 : blume 267 fun ml_defined s e = MemberCollection.ml_look e s
230 : blume 336 fun cm_defined gp s e = MemberCollection.cm_look gp e s
231 : blume 265 fun conj (e1, e2) e = e1 e andalso e2 e
232 :     fun disj (e1, e2) e = e1 e orelse e2 e
233 :     fun beq (e1: exp, e2) e = e1 e = e2 e
234 :     fun bne (e1: exp, e2) e = e1 e <> e2 e
235 :     fun not ex e = Bool.not (ex e)
236 :     fun lt (e1, e2) e = e1 e < e2 e
237 :     fun le (e1, e2) e = e1 e <= e2 e
238 :     fun gt (e1, e2) e = e1 e > e2 e
239 :     fun ge (e1, e2) e = e1 e >= e2 e
240 :     fun eq (e1: aexp, e2) e = e1 e = e2 e
241 :     fun ne (e1: aexp, e2) e = e1 e <> e2 e
242 :     end

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