Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/semant/semant.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 265, Fri May 7 08:42:54 1999 UTC revision 282, Wed May 19 05:14:03 1999 UTC
# Line 1  Line 1 
1    (*
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  signature CM_SEMANT = sig  signature CM_SEMANT = sig
9    
10      type pathname      type context = AbsPath.context
11        type pathname = AbsPath.t
12      type ml_symbol      type ml_symbol
13      type cm_symbol      type cm_symbol
14    
15      type group      type group
16    
17      type perm      type perms
18        type permspec
19      type aexp      type aexp
20      type exp      type exp
21      type members                        (* still conditional *)      type members                        (* still conditional *)
22      type exports                        (* still conditional *)      type exports                        (* still conditional *)
23    
24      val file_native : string * pathname -> pathname      type complainer = string -> unit
25      val file_standard : string * pathname -> pathname  
26        (* getting elements of primitive types (pathnames and symbols) *)
27        val file_native : string * context -> pathname
28        val file_standard : string * context -> pathname
29      val cm_symbol : string -> cm_symbol      val cm_symbol : string -> cm_symbol
30      val ml_structure : string -> ml_symbol      val ml_structure : string -> ml_symbol
31      val ml_signature : string -> ml_symbol      val ml_signature : string -> ml_symbol
32      val ml_functor : string -> ml_symbol      val ml_functor : string -> ml_symbol
33      val ml_funsig : string -> ml_symbol      val ml_funsig : string -> ml_symbol
34    
35      val alias : pathname -> group      (* getting the full analysis for a group/library *)
36      val group : perm list * exports * members -> group      val emptyGroup : group
37      val library : perm list * exports * members -> group      val group : permspec * exports option * members -> group
38        val library : permspec * exports * members -> group
39      val require : cm_symbol -> perm  
40      val grant : cm_symbol -> perm      (* assembling permission lists *)
41        val initialPermSpec : permspec
42        val require : permspec * cm_symbol * complainer -> permspec
43        val grant : permspec * cm_symbol * complainer -> permspec
44    
45        (* constructing member collections *)
46      val emptyMembers : members      val emptyMembers : members
47      val member : pathname * cm_symbol option -> members      val member : (pathname -> group)
48            -> { sourcepath: pathname, group: pathname, class: cm_symbol option,
49                 error: string -> (PrettyPrint.ppstream -> unit) -> unit }
50            -> members
51      val members : members * members -> members      val members : members * members -> members
52      val guarded_members : exp * (members * members) -> members      val guarded_members :
53            exp * (members * members) * (string -> unit) -> members
54        val error_member : (unit -> unit) -> members
55    
56        (* constructing export lists *)
57      val emptyExports : exports      val emptyExports : exports
58      val export : ml_symbol -> exports      val export : ml_symbol -> exports
59      val exports : exports * exports -> exports      val exports : exports * exports -> exports
60      val guarded_exports : exp * (exports * exports) -> exports      val guarded_exports :
61            exp * (exports * exports) * (string -> unit) -> exports
62        val error_export : (unit -> unit) -> exports
63    
64        (* arithmetic (number-valued) expression *)
65      val number : int -> aexp      val number : int -> aexp
66      val variable : cm_symbol -> aexp      val variable : cm_symbol -> aexp
67      val plus : aexp * aexp -> aexp      val plus : aexp * aexp -> aexp
# Line 46  Line 71 
71      val modulus : aexp * aexp -> aexp      val modulus : aexp * aexp -> aexp
72      val negate : aexp -> aexp      val negate : aexp -> aexp
73    
74        (* (bool-valued) expressions *)
75      val ml_defined : ml_symbol -> exp      val ml_defined : ml_symbol -> exp
76      val cm_defined : cm_symbol -> exp      val cm_defined : cm_symbol -> exp
77      val conj : exp * exp -> exp      val conj : exp * exp -> exp
# Line 59  Line 85 
85      val ge : aexp * aexp -> exp      val ge : aexp * aexp -> exp
86      val eq : aexp * aexp -> exp      val eq : aexp * aexp -> exp
87      val ne : aexp * aexp -> exp      val ne : aexp * aexp -> exp
   
88  end  end
89    
90  structure CMSemant :> CM_SEMANT = struct  structure CMSemant :> CM_SEMANT = struct
91    
92        structure SymPath = GenericVC.SymPath
93    
94      type pathname = AbsPath.t      type pathname = AbsPath.t
95      type ml_symbol = unit      type context = AbsPath.context
96        type ml_symbol = Symbol.symbol
97      type cm_symbol = string      type cm_symbol = string
98    
99      type group = unit      type group = Dummy.t
100    
101        type environment = MemberCollection.collection
102    
103      type environment = unit      type perms = StringSet.set
104      fun num_look () _ = 0      type permspec = { required : perms, granted : perms }
     fun ml_look () _ = false  
     fun cm_look () _ = false  
   
     datatype perm =  
         REQUIRE of cm_symbol  
       | GRANT of cm_symbol  
105    
106      type aexp = environment -> int      type aexp = environment -> int
107      type exp = environment -> bool      type exp = environment -> bool
108      type members = unit      type members = environment -> MemberCollection.collection
109      type exports = unit      type exports = environment -> SymbolSet.set
110    
111        type complainer = string -> unit
112    
113        fun saveEval (exp, env, error) =
114            exp env
115            handle exn =>
116                (error ("expression raises exception: " ^ General.exnMessage exn);
117                 false)
118    
119      fun file_native (s, d) = AbsPath.native { context = d, spec = s }      fun file_native (s, d) = AbsPath.native { context = d, spec = s }
120      fun file_standard (s, d) = AbsPath.standard { context = d, spec = s }      fun file_standard (s, d) = AbsPath.standard { context = d, spec = s }
121      fun cm_symbol s = s      fun cm_symbol s = s
122      fun ml_structure (s: string) = ()      val ml_structure = Symbol.strSymbol
123      fun ml_signature (s: string) = ()      val ml_signature = Symbol.sigSymbol
124      fun ml_functor (s: string) = ()      val ml_functor = Symbol.fctSymbol
125      fun ml_funsig (s: string) = ()      val ml_funsig = Symbol.fsigSymbol
126    
127      fun alias (f: pathname) = ()      fun applyTo mc e = e mc
128      fun group (p: perm list, e: exports, m: members) = ()  
129      fun library (p: perm list, e: exports, m: members) = ()      val emptyGroup = Dummy.v
130    
131      val require = REQUIRE      fun group (p: permspec, e: exports option, m) = let
132      val grant = GRANT          val mc = applyTo MemberCollection.empty m
133            val exports = Option.map (applyTo mc) e
134      val emptyMembers = ()      in
135      fun member (f: pathname, c: cm_symbol option) = ()          ignore (MemberCollection.build mc);
136      fun members (m1: members, m2: members) = ()          Dummy.v
137      fun guarded_members (c: exp, (m1: members, m2: members)) = ()      end
138    
139      val emptyExports = ()      fun library (p: permspec, e: exports, m) = let
140      fun export (s: ml_symbol) = ()          val mc = applyTo MemberCollection.empty m
141      fun exports (e1: exports, e2: exports) = ()          val exports = applyTo mc e
142      fun guarded_exports (c: exp, (e1: exports, e2: exports)) = ()      in
143            ignore (MemberCollection.build mc);
144            Dummy.v
145        end
146    
147        local
148            val isMember = StringSet.member
149            fun sanity ({ required, granted }, s, error) =
150                if isMember (required, s) orelse isMember (granted, s) then
151                    error ("duplicate permission name: " ^ s)
152                else ()
153        in
154            val initialPermSpec = { required = StringSet.empty,
155                                 granted = StringSet.empty }
156            fun require (a as ({ required, granted }, s, _)) =
157                (sanity a;
158                 { required = StringSet.add (required, s), granted = granted })
159            fun grant (a as ({ required, granted }, s, _)) =
160                (sanity a;
161                 { required = required, granted = StringSet.add (granted, s) })
162        end
163    
164        (* get the export map from a group *)
165        fun getExports (g: group) = (ignore Dummy.v; SymbolMap.empty)
166    
167        fun emptyMembers env = env
168        fun member rparse arg env = let
169            val coll = MemberCollection.expandOne (getExports o rparse) arg
170            val error = #error arg
171            fun e0 s = error s GenericVC.ErrorMsg.nullErrorBody
172        in
173            MemberCollection.sequential (env, coll, e0)
174        end
175        fun members (m1, m2) env = m2 (m1 env)
176        fun guarded_members (c, (m1, m2), error) env =
177            if saveEval (c, env, error) then m1 env else m2 env
178        fun error_member thunk env = (thunk (); env)
179    
180        fun emptyExports env = SymbolSet.empty
181        fun export s env = SymbolSet.singleton s
182        fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
183        fun guarded_exports (c, (e1, e2), error) env =
184            if saveEval (c, env, error) then e1 env else e2 env
185        fun error_export thunk env = (thunk (); SymbolSet.empty)
186    
187      fun number i _ = i      fun number i _ = i
188      fun variable v e = num_look e v      fun variable v e = MemberCollection.num_look e v
189      fun plus (e1, e2) e = e1 e + e2 e      fun plus (e1, e2) e = e1 e + e2 e
190      fun minus (e1, e2) e = e1 e - e2 e      fun minus (e1, e2) e = e1 e - e2 e
191      fun times (e1, e2) e = e1 e * e2 e      fun times (e1, e2) e = e1 e * e2 e
# Line 118  Line 193 
193      fun modulus (e1, e2) e = e1 e mod e2 e      fun modulus (e1, e2) e = e1 e mod e2 e
194      fun negate ex e = ~(ex e)      fun negate ex e = ~(ex e)
195    
196      fun ml_defined s e = ml_look e s      fun ml_defined s e = MemberCollection.ml_look e s
197      fun cm_defined s e = cm_look e s      fun cm_defined s e = MemberCollection.cm_look e s
198      fun conj (e1, e2) e = e1 e andalso e2 e      fun conj (e1, e2) e = e1 e andalso e2 e
199      fun disj (e1, e2) e = e1 e orelse e2 e      fun disj (e1, e2) e = e1 e orelse e2 e
200      fun beq (e1: exp, e2) e = e1 e = e2 e      fun beq (e1: exp, e2) e = e1 e = e2 e

Legend:
Removed from v.265  
changed lines
  Added in v.282

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