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

Parent Directory | Revision Log

---

Revision 301 - (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	294	type privilegespec = GroupGraph.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 :			val file_standard : 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 :			val grant : 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 :			val variable : cm_symbol -> aexp
74 :			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 :			val cm_defined : cm_symbol -> exp
84 :			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 :			type privilegespec = GG.privilegespec
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 :			fun file_standard (s, d) = AbsPath.standard { context = d, spec = s }
129 :			fun cm_symbol s = s
130 :	blume	267	val ml_structure = Symbol.strSymbol
131 :			val ml_signature = Symbol.sigSymbol
132 :			val ml_functor = Symbol.fctSymbol
133 :			val ml_funsig = Symbol.fsigSymbol
134 :	blume	265
135 :	blume	282	fun applyTo mc e = e mc
136 :
137 :	blume	283	fun emptyGroup path =
138 :	blume	294	GG.GROUP { exports = SymbolMap.empty,
139 :			islib = false,
140 :			privileges = { required = StringSet.empty,
141 :			granted = StringSet.empty },
142 :			grouppath = path,
143 :			subgroups = [] }
144 :	blume	283
145 :	blume	282
146 :	blume	299	fun group (g, p, e, m, error, gp) = let
147 :	blume	282	val mc = applyTo MemberCollection.empty m
148 :	blume	283	val filter = Option.map (applyTo mc) e
149 :	blume	301	val (exports, rp) = MemberCollection.build (mc, filter, error, gp)
150 :	blume	294	val subgroups = MemberCollection.subgroups mc
151 :	blume	301	val { required = rp', granted } = p
152 :			val p' = { required = StringSet.union (rp, rp'), granted = granted }
153 :	blume	280	in
154 :	blume	294	GG.GROUP { exports = exports, islib = false,
155 :	blume	301	privileges = p', grouppath = g,
156 :	blume	294	subgroups = subgroups }
157 :	blume	280	end
158 :
159 :	blume	299	fun library (g, p, e, m, error, gp) = let
160 :	blume	282	val mc = applyTo MemberCollection.empty m
161 :	blume	283	val filter = applyTo mc e
162 :	blume	301	val (exports, rp) = MemberCollection.build (mc, SOME filter, error, gp)
163 :	blume	294	val subgroups = MemberCollection.subgroups mc
164 :	blume	301	val { required = rp', granted } = p
165 :			val p' = { required = StringSet.union (rp, rp'), granted = granted }
166 :	blume	282	in
167 :	blume	294	GG.GROUP { exports = exports, islib = true,
168 :	blume	301	privileges = p', grouppath = g,
169 :	blume	294	subgroups = subgroups }
170 :	blume	282	end
171 :	blume	265
172 :	blume	266	local
173 :	blume	267	val isMember = StringSet.member
174 :	blume	266	fun sanity ({ required, granted }, s, error) =
175 :	blume	267	if isMember (required, s) orelse isMember (granted, s) then
176 :	blume	283	error ("duplicate privilege name: " ^ s)
177 :	blume	266	else ()
178 :			in
179 :	blume	283	val initialPrivilegeSpec = { required = StringSet.empty,
180 :			granted = StringSet.empty }
181 :	blume	266	fun require (a as ({ required, granted }, s, _)) =
182 :			(sanity a;
183 :			{ required = StringSet.add (required, s), granted = granted })
184 :			fun grant (a as ({ required, granted }, s, _)) =
185 :			(sanity a;
186 :			{ required = required, granted = StringSet.add (granted, s) })
187 :			end
188 :	blume	265
189 :	blume	268	fun emptyMembers env = env
190 :	blume	299	fun member (gp, rparse) arg env = let
191 :			val coll = MemberCollection.expandOne (gp, rparse) arg
192 :	blume	297	val group = #group arg
193 :	blume	299	val error = GroupReg.error (#groupreg gp) group
194 :	blume	294	fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
195 :	blume	270	in
196 :	blume	277	MemberCollection.sequential (env, coll, e0)
197 :	blume	270	end
198 :	blume	268	fun members (m1, m2) env = m2 (m1 env)
199 :	blume	275	fun guarded_members (c, (m1, m2), error) env =
200 :			if saveEval (c, env, error) then m1 env else m2 env
201 :			fun error_member thunk env = (thunk (); env)
202 :	blume	265
203 :	blume	267	fun emptyExports env = SymbolSet.empty
204 :			fun export s env = SymbolSet.singleton s
205 :			fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
206 :	blume	275	fun guarded_exports (c, (e1, e2), error) env =
207 :			if saveEval (c, env, error) then e1 env else e2 env
208 :			fun error_export thunk env = (thunk (); SymbolSet.empty)
209 :	blume	265
210 :			fun number i _ = i
211 :	blume	267	fun variable v e = MemberCollection.num_look e v
212 :	blume	265	fun plus (e1, e2) e = e1 e + e2 e
213 :			fun minus (e1, e2) e = e1 e - e2 e
214 :			fun times (e1, e2) e = e1 e * e2 e
215 :			fun divide (e1, e2) e = e1 e div e2 e
216 :			fun modulus (e1, e2) e = e1 e mod e2 e
217 :			fun negate ex e = ~(ex e)
218 :
219 :	blume	267	fun ml_defined s e = MemberCollection.ml_look e s
220 :			fun cm_defined s e = MemberCollection.cm_look e s
221 :	blume	265	fun conj (e1, e2) e = e1 e andalso e2 e
222 :			fun disj (e1, e2) e = e1 e orelse e2 e
223 :			fun beq (e1: exp, e2) e = e1 e = e2 e
224 :			fun bne (e1: exp, e2) e = e1 e <> e2 e
225 :			fun not ex e = Bool.not (ex e)
226 :			fun lt (e1, e2) e = e1 e < e2 e
227 :			fun le (e1, e2) e = e1 e <= e2 e
228 :			fun gt (e1, e2) e = e1 e > e2 e
229 :			fun ge (e1, e2) e = e1 e >= e2 e
230 :			fun eq (e1: aexp, e2) e = e1 e = e2 e
231 :			fun ne (e1: aexp, e2) e = e1 e <> e2 e
232 :			end

---

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