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

Legend:
Removed from v.266  
changed lines
  Added in v.267

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