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 631, Fri Apr 28 08:30:52 2000 UTC revision 632, Sat Apr 29 15:50:42 2000 UTC
# Line 13  Line 13 
13      type ml_symbol      type ml_symbol
14      type cm_symbol      type cm_symbol
15      type cm_class      type cm_class
16        type cm_version = Version.t
17    
18      type group = GroupGraph.group      type group = GroupGraph.group
19    
# Line 28  Line 29 
29    
30      (* getting elements of primitive types (pathnames and symbols) *)      (* getting elements of primitive types (pathnames and symbols) *)
31      val file_native : string * context -> pathname      val file_native : string * context -> pathname
32      val file_standard : GeneralParams.info -> string * context -> pathname      val file_standard :
33            GeneralParams.info -> string * context * complainer -> pathname
34      val cm_symbol : string -> cm_symbol      val cm_symbol : string -> cm_symbol
35        val cm_version : string * complainer -> cm_version
36      val ml_structure : string -> ml_symbol      val ml_structure : string -> ml_symbol
37      val ml_signature : string -> ml_symbol      val ml_signature : string -> ml_symbol
38      val ml_functor : string -> ml_symbol      val ml_functor : string -> ml_symbol
# Line 37  Line 40 
40      val class : cm_symbol -> cm_class      val class : cm_symbol -> cm_class
41    
42      (* getting the full analysis for a group/library *)      (* getting the full analysis for a group/library *)
43      val group :      val group : { path: pathname,
44          pathname * privilegespec * exports option * members *                    privileges: privilegespec,
45          GeneralParams.info * pathname option * pathname option * complainer *                    exports: exports option,
46          GroupGraph.group                (* init group *)                    members: members,
47          -> group                    gp: GeneralParams.info,
48      val library :                    curlib: pathname option,
49          pathname * privilegespec * exports * members *                    owner: pathname option,
50          GeneralParams.info *                    error: complainer,
51          GroupGraph.group                (* init group *)                    initgroup: group } -> group
52          -> group      val library : { path: pathname,
53                        privileges: privilegespec,
54                        exports: exports,
55                        version : cm_version option,
56                        members: members,
57                        gp: GeneralParams.info,
58                        initgroup: group } -> group
59    
60      (* assembling privilege lists *)      (* assembling privilege lists *)
61      val initialPrivilegeSpec : privilegespec      val initialPrivilegeSpec : privilegespec
# Line 56  Line 65 
65      (* constructing member collections *)      (* constructing member collections *)
66      val emptyMembers : members      val emptyMembers : members
67      val member :      val member :
68          GeneralParams.info * (pathname option -> pathname -> group) *          { gp: GeneralParams.info,
69                               (SrcPath.context -> string -> bool)            rparse: pathname option -> pathname * Version.t option -> group,
70              load_plugin: SrcPath.context -> string -> bool }
71          -> { name: string,          -> { name: string,
72               mkpath: string -> pathname,               mkpath: string -> pathname,
73               group: pathname * region,               group: pathname * region,
# Line 78  Line 88 
88          exp * (exports * exports) * (string -> unit) -> exports          exp * (exports * exports) * (string -> unit) -> exports
89      val error_export : (unit -> unit) -> exports      val error_export : (unit -> unit) -> exports
90    
91        (* groups of operator symbols (to make grammar smaller) *)
92        type addsym
93        val PLUS : addsym
94        val MINUS : addsym
95    
96        type mulsym
97        val TIMES : mulsym
98        val DIV : mulsym
99        val MOD : mulsym
100    
101        type eqsym
102        val EQ : eqsym
103        val NE : eqsym
104    
105        type ineqsym
106        val GT : ineqsym
107        val GE : ineqsym
108        val LT : ineqsym
109        val LE : ineqsym
110    
111      (* arithmetic (number-valued) expression *)      (* arithmetic (number-valued) expression *)
112      val number : int -> aexp      val number : int -> aexp
113      val variable : GeneralParams.info -> cm_symbol -> aexp      val variable : GeneralParams.info -> cm_symbol -> aexp
114      val plus : aexp * aexp -> aexp      val add : aexp * addsym * aexp -> aexp
115      val minus : aexp * aexp -> aexp      val mul : aexp * mulsym * aexp -> aexp
116      val times : aexp * aexp -> aexp      val sign : addsym * aexp -> aexp
     val divide : aexp * aexp -> aexp  
     val modulus : aexp * aexp -> aexp  
117      val negate : aexp -> aexp      val negate : aexp -> aexp
118    
119      (* (bool-valued) expressions *)      (* (bool-valued) expressions *)
# Line 93  Line 121 
121      val cm_defined : GeneralParams.info -> cm_symbol -> exp      val cm_defined : GeneralParams.info -> cm_symbol -> exp
122      val conj : exp * exp -> exp      val conj : exp * exp -> exp
123      val disj : exp * exp -> exp      val disj : exp * exp -> exp
124      val beq : exp * exp -> exp      val beq : exp * eqsym * exp -> exp
     val bne : exp * exp -> exp  
125      val not : exp -> exp      val not : exp -> exp
126      val lt : aexp * aexp -> exp      val ineq : aexp * ineqsym * aexp -> exp
127      val le : aexp * aexp -> exp      val eq : aexp * eqsym * aexp -> exp
     val gt : aexp * aexp -> exp  
     val ge : aexp * aexp -> exp  
     val eq : aexp * aexp -> exp  
     val ne : aexp * aexp -> exp  
128    
129      (* tool options *)      (* tool options *)
130      val string : { name: string, mkpath: string -> pathname } -> toolopt      val string : { name: string, mkpath: string -> pathname } -> toolopt
# Line 120  Line 143 
143      type ml_symbol = Symbol.symbol      type ml_symbol = Symbol.symbol
144      type cm_symbol = string      type cm_symbol = string
145      type cm_class = string      type cm_class = string
146        type cm_version = Version.t
147    
148      type group = GG.group      type group = GG.group
149      type privilegespec = { required: GG.privileges, wrapped: GG.privileges }      type privilegespec = { required: GG.privileges, wrapped: GG.privileges }
# Line 142  Line 166 
166               false)               false)
167    
168      fun file_native (s, d) = SrcPath.native { context = d, spec = s }      fun file_native (s, d) = SrcPath.native { context = d, spec = s }
169      fun file_standard (gp: GeneralParams.info) (s, d) =      fun file_standard (gp: GeneralParams.info) (s, d, err) =
170          SrcPath.standard (#pcmode (#param gp)) { context = d, spec = s }          SrcPath.standard (#pcmode (#param gp)) { context = d, spec = s }
171            handle SrcPath.BadAnchor "" =>
172                   (err "invalid empty anchor in path name"; file_native (s, d))
173                 | SrcPath.BadAnchor a =>
174                   (err (concat ["invalid anchor `", a, "' in path name"]);
175                    file_native (s, d))
176    
177      fun cm_symbol s = s      fun cm_symbol s = s
178        fun cm_version (s, error) =
179            case Version.fromString s of
180                SOME v => v
181              | NONE => (error "ill-formed version specification"; Version.zero)
182      val ml_structure = Symbol.strSymbol      val ml_structure = Symbol.strSymbol
183      val ml_signature = Symbol.sigSymbol      val ml_signature = Symbol.sigSymbol
184      val ml_functor = Symbol.fctSymbol      val ml_functor = Symbol.fctSymbol
# Line 167  Line 201 
201          foldl oneSG [] subgroups          foldl oneSG [] subgroups
202      end      end
203    
204      fun grouplib (isgroup, g, p, e, m, gp, curlib, init_group) = let      fun group arg = let
205          val mc = applyTo (MemberCollection.implicit init_group, curlib) m          val { path = g, privileges = p, exports = e, members = m,
206                  gp, curlib, owner, error, initgroup } = arg
207            val mc = applyTo (MemberCollection.implicit initgroup, curlib) m
208          val filter = Option.map (applyTo mc) e          val filter = Option.map (applyTo mc) e
209          val pfsbn = let          val pfsbn = let
210              val { exports, ... } =              val { exports, ... } =
211                  case init_group of                  case initgroup of
212                      GG.GROUP x => x                      GG.GROUP x => x
213                    | GG.ERRORGROUP =>                    | GG.ERRORGROUP =>
214                      EM.impossible "semant.sml: grouplib: bad init group"                      EM.impossible "semant.sml: group: bad init group"
215          in          in
216              #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))              #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
217          end          end
# Line 184  Line 220 
220          val { required = rp', wrapped = wr } = p          val { required = rp', wrapped = wr } = p
221          val rp'' = StringSet.union (rp', StringSet.union (rp, wr))          val rp'' = StringSet.union (rp', StringSet.union (rp, wr))
222      in      in
223            if StringSet.isEmpty wr then ()
224            else EM.impossible "group with wrapped privileges";
225          GG.GROUP { exports = exports,          GG.GROUP { exports = exports,
226                     kind = case isgroup of                     kind = GG.NOLIB { subgroups = subgroups, owner = owner },
                               NONE => GG.LIB { wrapped = wr,  
                                                subgroups = subgroups }  
                             | SOME owner =>  
                               (if StringSet.isEmpty wr then ()  
                                else EM.impossible  
                                         "group with wrapped privilege";  
                                         GG.NOLIB { subgroups = subgroups,  
                                                    owner = owner }),  
227                     required = rp'',                     required = rp'',
228                     grouppath = g,                     grouppath = g,
229                     sublibs = sgl2sll subgroups }                     sublibs = sgl2sll subgroups }
230      end      end
231    
232      fun group (g, p, e, m, gp, curlib, owner, error, init_group) =      fun library arg = let
233          grouplib (SOME owner, g, p, e, m, gp, curlib, init_group)          val { path = g, privileges = p, exports = e, members = m,
234      fun library (g, p, e, m, gp, init_group) =                version, gp, initgroup } = arg
235          grouplib (NONE, g, p, SOME e, m, gp, SOME g, init_group)          val mc = applyTo (MemberCollection.implicit initgroup, SOME g) m
236            val filter = SOME (applyTo mc e)
237            val pfsbn = let
238                val { exports, ... } =
239                    case initgroup of
240                        GG.GROUP x => x
241                      | GG.ERRORGROUP =>
242                        EM.impossible "semant.sml: lib: bad init group"
243            in
244                #1 (valOf (SymbolMap.find (exports, PervAccess.pervStrSym)))
245            end
246            val (exports, rp) = MemberCollection.build (mc, filter, gp, pfsbn)
247            val subgroups = MemberCollection.subgroups mc
248            val { required = rp', wrapped = wr } = p
249            val rp'' = StringSet.union (rp', StringSet.union (rp, wr))
250        in
251            GG.GROUP { exports = exports,
252                       kind = GG.LIB { version = version,
253                                       kind = GG.DEVELOPED { subgroups = subgroups,
254                                                             wrapped = wr } },
255                       required = rp'',
256                       grouppath = g,
257                       sublibs = sgl2sll subgroups }
258        end
259    
260      local      local
261          val isMember = StringSet.member          val isMember = StringSet.member
# Line 222  Line 275 
275      end      end
276    
277      fun emptyMembers (env, _) = env      fun emptyMembers (env, _) = env
278      fun member (gp, rparse, ldpi) arg (env, curlib) = let      fun member { gp, rparse, load_plugin } arg (env, curlib) = let
279          val coll = MemberCollection.expandOne (gp, rparse curlib, ldpi) arg          val coll = MemberCollection.expandOne
280                           { gp = gp, rparse = rparse curlib,
281                             load_plugin = load_plugin }
282                           arg
283          val group = #group arg          val group = #group arg
284          val error = GroupReg.error (#groupreg gp) group          val error = GroupReg.error (#groupreg gp) group
285          fun e0 s = error EM.COMPLAIN s EM.nullErrorBody          fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
# Line 261  Line 317 
317          if saveEval (c, env, error) then e1 env else e2 env          if saveEval (c, env, error) then e1 env else e2 env
318      fun error_export thunk env = (thunk (); SymbolSet.empty)      fun error_export thunk env = (thunk (); SymbolSet.empty)
319    
320        datatype addsym = PLUS | MINUS
321        datatype mulsym = TIMES | DIV | MOD
322        datatype eqsym = EQ | NE
323        datatype ineqsym = GT | GE | LT | LE
324    
325      fun number i _ = i      fun number i _ = i
326      fun variable gp v e = MemberCollection.num_look gp e v      fun variable gp v e = MemberCollection.num_look gp e v
327      fun plus (e1, e2) e = e1 e + e2 e      fun add (e1, PLUS, e2) e = e1 e + e2 e
328      fun minus (e1, e2) e = e1 e - e2 e        | add (e1, MINUS, e2) e = e1 e - e2 e
329      fun times (e1, e2) e = e1 e * e2 e      fun mul (e1, TIMES, e2) e = e1 e * e2 e
330      fun divide (e1, e2) e = e1 e div e2 e        | mul (e1, DIV, e2) e = e1 e div e2 e
331      fun modulus (e1, e2) e = e1 e mod e2 e        | mul (e1, MOD, e2) e = e1 e mod e2 e
332        fun sign (PLUS, ex) e = ex e
333          | sign (MINUS, ex) e = ~(ex e)
334      fun negate ex e = ~(ex e)      fun negate ex e = ~(ex e)
335    
336      fun ml_defined s e = MemberCollection.ml_look e s      fun ml_defined s e = MemberCollection.ml_look e s
337      fun cm_defined gp s e = MemberCollection.cm_look gp e s      fun cm_defined gp s e = MemberCollection.cm_look gp e s
338      fun conj (e1, e2) e = e1 e andalso e2 e      fun conj (e1, e2) e = e1 e andalso e2 e
339      fun disj (e1, e2) e = e1 e orelse e2 e      fun disj (e1, e2) e = e1 e orelse e2 e
340      fun beq (e1: exp, e2) e = e1 e = e2 e      fun beq (e1: exp, EQ, e2) e = e1 e = e2 e
341      fun bne (e1: exp, e2) e = e1 e <> e2 e        | beq (e1, NE, e2) e = e1 e <> e2 e
342      fun not ex e = Bool.not (ex e)      fun not ex e = Bool.not (ex e)
343      fun lt (e1, e2) e = e1 e < e2 e      fun ineq (e1, LT, e2) e = e1 e < e2 e
344      fun le (e1, e2) e = e1 e <= e2 e        | ineq (e1, LE, e2) e = e1 e <= e2 e
345      fun gt (e1, e2) e = e1 e > e2 e        | ineq (e1, GT, e2) e = e1 e > e2 e
346      fun ge (e1, e2) e = e1 e >= e2 e        | ineq (e1, GE, e2) e = e1 e >= e2 e
347      fun eq (e1: aexp, e2) e = e1 e = e2 e      fun eq (e1: aexp, EQ, e2) e = e1 e = e2 e
348      fun ne (e1: aexp, e2) e = e1 e <> e2 e        | eq (e1, NE, e2) e = e1 e <> e2 e
349    
350      val string = PrivateTools.STRING      val string = PrivateTools.STRING
351      val subopts = PrivateTools.SUBOPTS      val subopts = PrivateTools.SUBOPTS

Legend:
Removed from v.631  
changed lines
  Added in v.632

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