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 274, Fri May 14 05:23:02 1999 UTC revision 286, Fri May 21 07:47:16 1999 UTC
# Line 7  Line 7 
7   *)   *)
8  signature CM_SEMANT = sig  signature CM_SEMANT = sig
9    
     exception ExplicitError of string  
     exception ExpressionError of exn  
   
10      type context = AbsPath.context      type context = AbsPath.context
11      type pathname = AbsPath.t      type pathname = AbsPath.t
12      type ml_symbol      type ml_symbol
# Line 17  Line 14 
14    
15      type group      type group
16    
17      type perms      type privileges
18        type privilegespec
19      type aexp      type aexp
20      type exp      type exp
21      type members                        (* still conditional *)      type members                        (* still conditional *)
# Line 35  Line 33 
33      val ml_funsig : string -> ml_symbol      val ml_funsig : string -> ml_symbol
34    
35      (* getting the full analysis for a group/library *)      (* getting the full analysis for a group/library *)
36      val emptyGroup : group      val emptyGroup : pathname -> group
37      val group : perms * exports * members -> group      val group :
38      val library : perms * exports * members -> group          pathname * privilegespec * exports option * members * complainer
39            -> group
40      (* assembling permission lists *)      val library :
41      val initialPerms : perms          pathname * privilegespec * exports * members * complainer
42      val require : perms * cm_symbol * complainer -> perms          -> group
43      val grant : perms * cm_symbol * complainer -> perms  
44        (* assembling privilege lists *)
45        val initialPrivilegeSpec : privilegespec
46        val require : privilegespec * cm_symbol * complainer -> privilegespec
47        val grant : privilegespec * cm_symbol * complainer -> privilegespec
48    
49      (* constructing member collections *)      (* constructing member collections *)
50      val emptyMembers : members      val emptyMembers : members
51      val member : (pathname -> group)      val member : GeneralParams.params * (pathname -> group)
52          -> { sourcepath: pathname, group: pathname, class: cm_symbol option }          -> { sourcepath: pathname, group: pathname, class: cm_symbol option,
53                 error: string -> (PrettyPrint.ppstream -> unit) -> unit }
54          -> members          -> members
55      val members : members * members -> members      val members : members * members -> members
56      val guarded_members : exp * (members * members) -> members      val guarded_members :
57      val error_member : string -> members          exp * (members * members) * (string -> unit) -> members
58        val error_member : (unit -> unit) -> members
59    
60      (* constructing export lists *)      (* constructing export lists *)
61      val emptyExports : exports      val emptyExports : exports
62      val export : ml_symbol -> exports      val export : ml_symbol -> exports
63      val exports : exports * exports -> exports      val exports : exports * exports -> exports
64      val guarded_exports : exp * (exports * exports) -> exports      val guarded_exports :
65      val error_export : string -> exports          exp * (exports * exports) * (string -> unit) -> exports
66        val error_export : (unit -> unit) -> exports
67    
68      (* arithmetic (number-valued) expression *)      (* arithmetic (number-valued) expression *)
69      val number : int -> aexp      val number : int -> aexp
# Line 88  Line 93 
93    
94  structure CMSemant :> CM_SEMANT = struct  structure CMSemant :> CM_SEMANT = struct
95    
     exception ExplicitError of string  
     exception ExpressionError of exn  
   
     structure Symbol = GenericVC.Symbol  
96      structure SymPath = GenericVC.SymPath      structure SymPath = GenericVC.SymPath
97    
98      type pathname = AbsPath.t      type pathname = AbsPath.t
# Line 99  Line 100 
100      type ml_symbol = Symbol.symbol      type ml_symbol = Symbol.symbol
101      type cm_symbol = string      type cm_symbol = string
102    
103      type group = Dummy.t      type privileges = StringSet.set
104        type privilegespec = { required : privileges, granted : privileges }
105    
106      type environment = MemberCollection.collection      datatype group =
107            GROUP of { exports: DependencyGraph.impexp SymbolMap.map,
108                       islib: bool,
109                       privileges: privilegespec,
110                       grouppath: AbsPath.t }
111    
112      type perms = { required : StringSet.set, granted : StringSet.set }      type environment = MemberCollection.collection
113    
114      type aexp = environment -> int      type aexp = environment -> int
115      type exp = environment -> bool      type exp = environment -> bool
# Line 112  Line 118 
118    
119      type complainer = string -> unit      type complainer = string -> unit
120    
121      fun saveEval (exp, env) =      fun saveEval (exp, env, error) =
122          exp env          exp env
123          handle exn =>          handle exn =>
124              raise ExpressionError exn              (error ("expression raises exception: " ^ General.exnMessage exn);
125                 false)
126    
127      fun file_native (s, d) = AbsPath.native { context = d, spec = s }      fun file_native (s, d) = AbsPath.native { context = d, spec = s }
128      fun file_standard (s, d) = AbsPath.standard { context = d, spec = s }      fun file_standard (s, d) = AbsPath.standard { context = d, spec = s }
# Line 125  Line 132 
132      val ml_functor = Symbol.fctSymbol      val ml_functor = Symbol.fctSymbol
133      val ml_funsig = Symbol.fsigSymbol      val ml_funsig = Symbol.fsigSymbol
134    
135      val emptyGroup = Dummy.v      fun applyTo mc e = e mc
136      fun group (p: perms, e: exports, m: members) =  
137          (ignore (m MemberCollection.empty);      fun emptyGroup path =
138           Dummy.v)          GROUP { exports = SymbolMap.empty,
139      fun library (p: perms, e: exports, m: members) =                  islib = false,
140          (ignore (m MemberCollection.empty);                  privileges = { required = StringSet.empty,
141           Dummy.v)                                 granted = StringSet.empty },
142                    grouppath = path }
143    
144    
145        fun group (g, p, e, m, error) = let
146            val mc = applyTo MemberCollection.empty m
147            val filter = Option.map (applyTo mc) e
148            val exports = MemberCollection.build (mc, filter, error)
149        in
150            GROUP { exports = exports, islib = false,
151                    privileges = p, grouppath = g }
152        end
153    
154        fun library (g, p, e, m, error) = let
155            val mc = applyTo MemberCollection.empty m
156            val filter = applyTo mc e
157            val exports = MemberCollection.build (mc, SOME filter, error)
158        in
159            GROUP { exports = exports, islib = true,
160                    privileges = p, grouppath = g }
161        end
162    
163      local      local
164          val isMember = StringSet.member          val isMember = StringSet.member
165          fun sanity ({ required, granted }, s, error) =          fun sanity ({ required, granted }, s, error) =
166              if isMember (required, s) orelse isMember (granted, s) then              if isMember (required, s) orelse isMember (granted, s) then
167                  error ("duplicate permission name: " ^ s)                  error ("duplicate privilege name: " ^ s)
168              else ()              else ()
169      in      in
170          val initialPerms = { required = StringSet.empty,          val initialPrivilegeSpec = { required = StringSet.empty,
171                               granted = StringSet.empty }                               granted = StringSet.empty }
172          fun require (a as ({ required, granted }, s, _)) =          fun require (a as ({ required, granted }, s, _)) =
173              (sanity a;              (sanity a;
# Line 151  Line 178 
178      end      end
179    
180      (* get the export map from a group *)      (* get the export map from a group *)
181      fun getExports (g: group) = (ignore Dummy.v; SymbolMap.empty)      fun getExports (GROUP { exports, islib, ... }) =
182            { imports = exports,
183              gimports = if islib then SymbolMap.empty else exports }
184    
185      fun emptyMembers env = env      fun emptyMembers env = env
186      fun member rparse arg env = let      fun member (params, rparse) arg env = let
187          val coll = MemberCollection.expandOne (getExports o rparse) arg          val coll = MemberCollection.expandOne (params, getExports o rparse) arg
188            val error = #error arg
189            fun e0 s = error s GenericVC.ErrorMsg.nullErrorBody
190      in      in
191          MemberCollection.sequential (env, coll)          MemberCollection.sequential (env, coll, e0)
192      end      end
193      fun members (m1, m2) env = m2 (m1 env)      fun members (m1, m2) env = m2 (m1 env)
194      fun guarded_members (c, (m1, m2)) env =      fun guarded_members (c, (m1, m2), error) env =
195          if saveEval (c, env) then m1 env else m2 env          if saveEval (c, env, error) then m1 env else m2 env
196      fun error_member m env =      fun error_member thunk env = (thunk (); env)
         (print (m ^ "\n");  
          raise ExplicitError m)  
197    
198      fun emptyExports env = SymbolSet.empty      fun emptyExports env = SymbolSet.empty
199      fun export s env = SymbolSet.singleton s      fun export s env = SymbolSet.singleton s
200      fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)      fun exports (e1, e2) env = SymbolSet.union (e1 env, e2 env)
201      fun guarded_exports (c, (e1, e2)) env =      fun guarded_exports (c, (e1, e2), error) env =
202          if saveEval (c, env) then e1 env else e2 env          if saveEval (c, env, error) then e1 env else e2 env
203      fun error_export m env = raise ExplicitError m      fun error_export thunk env = (thunk (); SymbolSet.empty)
204    
205      fun number i _ = i      fun number i _ = i
206      fun variable v e = MemberCollection.num_look e v      fun variable v e = MemberCollection.num_look e v

Legend:
Removed from v.274  
changed lines
  Added in v.286

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