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

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