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