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/branches/primop-branch-3/compiler/ElabData/modules/moduleid.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/ElabData/modules/moduleid.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 903 - (view) (download)
Original Path: sml/trunk/src/compiler/ElabData/modules/moduleid.sml

1 : blume 903 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* Re-written by M.Blume (3/2000) *)
3 :     (* moduleid.sml *)
4 :    
5 :     signature MODULE_ID = sig
6 :    
7 :     type tycId
8 :     type sigId
9 :     type strId
10 :     type fctId
11 :     type envId
12 :    
13 :     val tycId : Types.gtrec -> tycId
14 :     val sigId : Modules.sigrec -> sigId
15 :     val strId : Modules.strrec -> strId
16 :     val fctId : Modules.fctrec -> fctId
17 :     val envId : Modules.envrec -> envId
18 :    
19 :     val strId2 : Modules.sigrec * Modules.strEntity -> strId
20 :     val fctId2 : Modules.fctSig * Modules.fctEntity -> fctId
21 :    
22 :     val sameTyc : tycId * tycId -> bool
23 :     val sameSig : sigId * sigId -> bool
24 :     val sameStr : strId * strId -> bool
25 :     val sameFct : fctId * fctId -> bool
26 :     val sameEnv : envId * envId -> bool
27 :    
28 :     val freshTyc : tycId -> bool
29 :     val freshSig : sigId -> bool
30 :     val freshStr : strId -> bool
31 :     val freshFct : fctId -> bool
32 :     val freshEnv : envId -> bool
33 :    
34 :     type tmap
35 :    
36 :     val emptyTmap : tmap
37 :    
38 :     val lookTyc : tmap * tycId -> Types.gtrec option
39 :     val lookSig : tmap * sigId -> Modules.sigrec option
40 :     val lookStr : tmap * strId -> Modules.strEntity option
41 :     val lookFct : tmap * fctId -> Modules.fctEntity option
42 :     val lookEnv : tmap * envId -> Modules.envrec option
43 :    
44 :     val insertTyc : tmap * tycId * Types.gtrec -> tmap
45 :     val insertSig : tmap * sigId * Modules.sigrec -> tmap
46 :     val insertStr : tmap * strId * Modules.strEntity -> tmap
47 :     val insertFct : tmap * fctId * Modules.fctEntity -> tmap
48 :     val insertEnv : tmap * envId * Modules.envrec -> tmap
49 :    
50 :     val tycId' : Types.tycon -> tycId
51 :    
52 :     type 'a umap
53 :    
54 :     val emptyUmap : 'a umap
55 :    
56 :     val uLookTyc : 'a umap * tycId -> 'a option
57 :     val uLookSig : 'a umap * sigId -> 'a option
58 :     val uLookStr : 'a umap * strId -> 'a option
59 :     val uLookFct : 'a umap * fctId -> 'a option
60 :     val uLookEnv : 'a umap * envId -> 'a option
61 :    
62 :     val uInsertTyc : 'a umap * tycId * 'a -> 'a umap
63 :     val uInsertSig : 'a umap * sigId * 'a -> 'a umap
64 :     val uInsertStr : 'a umap * strId * 'a -> 'a umap
65 :     val uInsertFct : 'a umap * fctId * 'a -> 'a umap
66 :     val uInsertEnv : 'a umap * envId * 'a -> 'a umap
67 :    
68 :     end (* signature MODULE_ID *)
69 :    
70 :     structure ModuleId : MODULE_ID = struct
71 :    
72 :     structure M = Modules
73 :     structure T = Types
74 :     structure A = Access
75 :     structure ST = Stamps
76 :    
77 :     fun bug m = ErrorMsg.impossible ("ModuleId: " ^ m)
78 :    
79 :     type stamp = ST.stamp
80 :    
81 :     type tycId = stamp
82 :     type sigId = stamp
83 :     type strId = { sign: stamp, rlzn: stamp }
84 :     type fctId = { paramsig: stamp, bodysig: stamp, rlzn: stamp }
85 :     type envId = stamp
86 :    
87 :     val freshTyc = ST.isFresh
88 :     val freshSig = ST.isFresh
89 :     fun freshStr { sign, rlzn } = ST.isFresh sign orelse ST.isFresh rlzn
90 :     fun freshFct { paramsig, bodysig, rlzn } =
91 :     ST.isFresh paramsig orelse ST.isFresh bodysig orelse ST.isFresh rlzn
92 :     val freshEnv = ST.isFresh
93 :    
94 :     fun tycId (r: Types.gtrec) = #stamp r
95 :     fun sigId (s: Modules.sigrec) = #stamp s
96 :     fun strId2 (sign: M.sigrec, rlzn: M.strEntity) =
97 :     { sign = #stamp sign, rlzn = #stamp rlzn }
98 :     fun strId ({ sign = Modules.SIG s, rlzn, ... }: Modules.strrec) =
99 :     { sign = #stamp s, rlzn = #stamp rlzn }
100 :     | strId _ = bug "strId: bad signature"
101 :     fun fctId2 (M.FSIG { paramsig = M.SIG psg, bodysig = M.SIG bsg, ... },
102 :     rlzn: M.fctEntity) =
103 :     { paramsig = #stamp psg, bodysig = #stamp bsg, rlzn = #stamp rlzn }
104 :     | fctId2 _ = bug "fctId2/fctId2: bad funsig"
105 :     fun fctId ({ sign, rlzn, ... }: Modules.fctrec) = fctId2 (sign, rlzn)
106 :     fun envId (e: Modules.envrec) = #stamp e
107 :    
108 :     structure StrKey = struct
109 :     type ord_key = strId
110 :     fun compare (i1: strId, i2: strId) =
111 :     case ST.compare (#sign i1, #sign i2) of
112 :     EQUAL => ST.compare (#rlzn i1, #rlzn i2)
113 :     | unequal => unequal
114 :     end
115 :     structure FctKey = struct
116 :     type ord_key = fctId
117 :     fun compare (i1: fctId, i2: fctId) =
118 :     case ST.compare (#paramsig i1, #paramsig i2) of
119 :     EQUAL => (case ST.compare (#bodysig i1, #bodysig i2) of
120 :     EQUAL => ST.compare (#rlzn i1, #rlzn i2)
121 :     | unequal => unequal)
122 :     | unequal => unequal
123 :     end
124 :    
125 :     structure StampM = RedBlackMapFn (ST)
126 :     structure StrM = RedBlackMapFn (StrKey)
127 :     structure FctM = RedBlackMapFn (FctKey)
128 :    
129 :     val sameTyc = ST.eq
130 :     val sameSig = ST.eq
131 :     fun sameStr (x, y) = StrKey.compare (x, y) = EQUAL
132 :     fun sameFct (x, y) = FctKey.compare (x, y) = EQUAL
133 :     val sameEnv = ST.eq
134 :    
135 :     type tmap = { m_tyc: T.gtrec StampM.map,
136 :     m_sig: M.sigrec StampM.map,
137 :     m_str: M.strEntity StrM.map,
138 :     m_fct: M.fctEntity FctM.map,
139 :     m_env: M.envrec StampM.map }
140 :    
141 :     val emptyTmap = { m_tyc = StampM.empty,
142 :     m_sig = StampM.empty,
143 :     m_str = StrM.empty,
144 :     m_fct = FctM.empty,
145 :     m_env = StampM.empty }
146 :    
147 :     local
148 :     fun look (sel, find) (m as { m_tyc, m_sig, m_str, m_fct, m_env }, k) =
149 :     find (sel m, k)
150 :     in
151 :     fun lookTyc x = look (#m_tyc, StampM.find) x
152 :     fun lookSig x = look (#m_sig, StampM.find) x
153 :     fun lookStr x = look (#m_str, StrM.find) x
154 :     fun lookFct x = look (#m_fct, FctM.find) x
155 :     fun lookEnv x = look (#m_env, StampM.find) x
156 :     end
157 :    
158 :     fun insertTyc ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) =
159 :     { m_tyc = StampM.insert (m_tyc, k, t),
160 :     m_sig = m_sig, m_str = m_str, m_fct = m_fct, m_env = m_env }
161 :    
162 :     fun insertSig ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) =
163 :     { m_sig = StampM.insert (m_sig, k, t),
164 :     m_tyc = m_tyc, m_str = m_str, m_fct = m_fct, m_env = m_env }
165 :    
166 :     fun insertStr ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) =
167 :     { m_str = StrM.insert (m_str, k, t),
168 :     m_tyc = m_tyc, m_sig = m_sig, m_fct = m_fct, m_env = m_env }
169 :    
170 :     fun insertFct ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) =
171 :     { m_fct = FctM.insert (m_fct, k, t),
172 :     m_tyc = m_tyc, m_sig = m_sig, m_str = m_str, m_env = m_env }
173 :    
174 :     fun insertEnv ({ m_tyc, m_sig, m_str, m_fct, m_env }, k, t) =
175 :     { m_env = StampM.insert (m_env, k, t),
176 :     m_tyc = m_tyc, m_sig = m_sig, m_str = m_str, m_fct = m_fct }
177 :    
178 :     fun tycId' (T.GENtyc r) = tycId r
179 :     | tycId' (T.DEFtyc { stamp, ... }) = stamp
180 :     | tycId' _ = bug "tycId': neither GENtyc nor DEFtyc"
181 :    
182 :     (* and now for uniformely typed maps (implementations are shared)... *)
183 :    
184 :     type 'a umap = { m_tyc: 'a StampM.map,
185 :     m_sig: 'a StampM.map,
186 :     m_str: 'a StrM.map,
187 :     m_fct: 'a FctM.map,
188 :     m_env: 'a StampM.map }
189 :    
190 :     val emptyUmap = emptyTmap
191 :    
192 :     val uLookTyc = lookTyc
193 :     val uLookSig = lookSig
194 :     val uLookStr = lookStr
195 :     val uLookFct = lookFct
196 :     val uLookEnv = lookEnv
197 :    
198 :     val uInsertTyc = insertTyc
199 :     val uInsertSig = insertSig
200 :     val uInsertStr = insertStr
201 :     val uInsertFct = insertFct
202 :     val uInsertEnv = insertEnv
203 :    
204 :     end (* structure ModuleId *)

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