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 268 - (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 266 exception ExplicitError of string
11 : blume 267 exception ExpressionError of exn
12 : blume 266
13 : blume 268 type pathname = AbsPath.t
14 : blume 265 type ml_symbol
15 :     type cm_symbol
16 :    
17 :     type group
18 :    
19 : blume 266 type perms
20 : blume 265 type aexp
21 :     type exp
22 :     type members (* still conditional *)
23 :     type exports (* still conditional *)
24 :    
25 : blume 266 type complainer = string -> unit
26 :    
27 : blume 267 (* getting elements of primitive types (pathnames and symbols) *)
28 : blume 265 val file_native : string * pathname -> pathname
29 :     val file_standard : string * pathname -> pathname
30 :     val cm_symbol : string -> cm_symbol
31 :     val ml_structure : string -> ml_symbol
32 :     val ml_signature : string -> ml_symbol
33 :     val ml_functor : string -> ml_symbol
34 :     val ml_funsig : string -> ml_symbol
35 :    
36 : blume 267 (* getting the full analysis for a group/library (or an alias thereof) *)
37 : blume 265 val alias : pathname -> group
38 : blume 266 val group : perms * exports * members -> group
39 :     val library : perms * exports * members -> group
40 : blume 265
41 : blume 267 (* assembling permission lists *)
42 : blume 266 val initialPerms : perms
43 :     val require : perms * cm_symbol * complainer -> perms
44 :     val grant : perms * cm_symbol * complainer -> perms
45 : blume 265
46 : blume 267 (* constructing member collections *)
47 : blume 265 val emptyMembers : members
48 :     val member : pathname * cm_symbol option -> members
49 :     val members : members * members -> members
50 :     val guarded_members : exp * (members * members) -> members
51 : blume 266 val error_member : string -> members
52 : blume 265
53 : blume 267 (* constructing export lists *)
54 : blume 265 val emptyExports : exports
55 :     val export : ml_symbol -> exports
56 :     val exports : exports * exports -> exports
57 :     val guarded_exports : exp * (exports * exports) -> exports
58 : blume 266 val error_export : string -> exports
59 : blume 265
60 : blume 267 (* arithmetic (number-valued) expression *)
61 : blume 265 val number : int -> aexp
62 :     val variable : cm_symbol -> aexp
63 :     val plus : aexp * aexp -> aexp
64 :     val minus : aexp * aexp -> aexp
65 :     val times : aexp * aexp -> aexp
66 :     val divide : aexp * aexp -> aexp
67 :     val modulus : aexp * aexp -> aexp
68 :     val negate : aexp -> aexp
69 :    
70 : blume 267 (* (bool-valued) expressions *)
71 : blume 265 val ml_defined : ml_symbol -> exp
72 :     val cm_defined : cm_symbol -> exp
73 :     val conj : exp * exp -> exp
74 :     val disj : exp * exp -> exp
75 :     val beq : exp * exp -> exp
76 :     val bne : exp * exp -> exp
77 :     val not : exp -> exp
78 :     val lt : aexp * aexp -> exp
79 :     val le : aexp * aexp -> exp
80 :     val gt : aexp * aexp -> exp
81 :     val ge : aexp * aexp -> exp
82 :     val eq : aexp * aexp -> exp
83 :     val ne : aexp * aexp -> exp
84 :     end
85 :    
86 :     structure CMSemant :> CM_SEMANT = struct
87 :    
88 : blume 266 exception ExplicitError of string
89 : blume 267 exception ExpressionError of exn
90 : blume 266
91 : blume 267 structure Symbol = GenericVC.Symbol
92 :     structure SymPath = GenericVC.SymPath
93 :    
94 : blume 265 type pathname = AbsPath.t
95 : blume 267 type ml_symbol = Symbol.symbol
96 : blume 265 type cm_symbol = string
97 :    
98 :     type group = unit
99 :    
100 : blume 268 type environment = MemberCollection.collection
101 : blume 265
102 : blume 266 type perms = { required : StringSet.set, granted : StringSet.set }
103 : blume 265
104 :     type aexp = environment -> int
105 :     type exp = environment -> bool
106 : blume 267 type members = environment -> MemberCollection.collection
107 :     type exports = environment -> SymbolSet.set
108 : blume 265
109 : blume 266 type complainer = string -> unit
110 :    
111 : blume 267 fun saveEval (exp, env) =
112 :     exp env
113 :     handle exn =>
114 :     raise ExpressionError exn
115 :    
116 : blume 265 fun file_native (s, d) = AbsPath.native { context = d, spec = s }
117 :     fun file_standard (s, d) = AbsPath.standard { context = d, spec = s }
118 :     fun cm_symbol s = s
119 : blume 267 val ml_structure = Symbol.strSymbol
120 :     val ml_signature = Symbol.sigSymbol
121 :     val ml_functor = Symbol.fctSymbol
122 :     val ml_funsig = Symbol.fsigSymbol
123 : blume 265
124 :     fun alias (f: pathname) = ()
125 : blume 266 fun group (p: perms, e: exports, m: members) = ()
126 :     fun library (p: perms, e: exports, m: members) = ()
127 : blume 265
128 : blume 266 local
129 : blume 267 val isMember = StringSet.member
130 : blume 266 fun sanity ({ required, granted }, s, error) =
131 : blume 267 if isMember (required, s) orelse isMember (granted, s) then
132 : blume 266 error ("duplicate permission name: " ^ s)
133 :     else ()
134 :     in
135 :     val initialPerms = { required = StringSet.empty,
136 :     granted = StringSet.empty }
137 :     fun require (a as ({ required, granted }, s, _)) =
138 :     (sanity a;
139 :     { required = StringSet.add (required, s), granted = granted })
140 :     fun grant (a as ({ required, granted }, s, _)) =
141 :     (sanity a;
142 :     { required = required, granted = StringSet.add (granted, s) })
143 :     end
144 : blume 265
145 : blume 268 fun emptyMembers env = env
146 :     fun member (f, c) env =
147 :     MemberCollection.sequential (env, MemberCollection.expandOne (f, c))
148 :     fun members (m1, m2) env = m2 (m1 env)
149 : blume 267 fun guarded_members (c, (m1, m2)) env =
150 :     if saveEval (c, env) then m1 env else m2 env
151 :     fun error_member m env = raise ExplicitError m
152 : blume 265
153 : blume 267 fun emptyExports env = SymbolSet.empty
154 :     fun export s env = SymbolSet.singleton s
155 :     fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
156 :     fun guarded_exports (c, (e1, e2)) env =
157 :     if saveEval (c, env) then e1 env else e2 env
158 : blume 266 fun error_export m env = raise ExplicitError m
159 : blume 265
160 :     fun number i _ = i
161 : blume 267 fun variable v e = MemberCollection.num_look e v
162 : blume 265 fun plus (e1, e2) e = e1 e + e2 e
163 :     fun minus (e1, e2) e = e1 e - e2 e
164 :     fun times (e1, e2) e = e1 e * e2 e
165 :     fun divide (e1, e2) e = e1 e div e2 e
166 :     fun modulus (e1, e2) e = e1 e mod e2 e
167 :     fun negate ex e = ~(ex e)
168 :    
169 : blume 267 fun ml_defined s e = MemberCollection.ml_look e s
170 :     fun cm_defined s e = MemberCollection.cm_look e s
171 : blume 265 fun conj (e1, e2) e = e1 e andalso e2 e
172 :     fun disj (e1, e2) e = e1 e orelse e2 e
173 :     fun beq (e1: exp, e2) e = e1 e = e2 e
174 :     fun bne (e1: exp, e2) e = e1 e <> e2 e
175 :     fun not ex e = Bool.not (ex e)
176 :     fun lt (e1, e2) e = e1 e < e2 e
177 :     fun le (e1, e2) e = e1 e <= e2 e
178 :     fun gt (e1, e2) e = e1 e > e2 e
179 :     fun ge (e1, e2) e = e1 e >= e2 e
180 :     fun eq (e1: aexp, e2) e = e1 e = e2 e
181 :     fun ne (e1: aexp, e2) e = e1 e <> e2 e
182 :     end

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