annotate gcc/ada/libgnat/a-chtgbo.adb @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT LIBRARY COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
131
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
9 -- Copyright (C) 2004-2018, Free Software Foundation, Inc. --
111
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNAT is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
kono
parents:
diff changeset
17 -- --
kono
parents:
diff changeset
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
kono
parents:
diff changeset
19 -- additional permissions described in the GCC Runtime Library Exception, --
kono
parents:
diff changeset
20 -- version 3.1, as published by the Free Software Foundation. --
kono
parents:
diff changeset
21 -- --
kono
parents:
diff changeset
22 -- You should have received a copy of the GNU General Public License and --
kono
parents:
diff changeset
23 -- a copy of the GCC Runtime Library Exception along with this program; --
kono
parents:
diff changeset
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
kono
parents:
diff changeset
25 -- <http://www.gnu.org/licenses/>. --
kono
parents:
diff changeset
26 -- --
kono
parents:
diff changeset
27 -- This unit was originally developed by Matthew J Heaney. --
kono
parents:
diff changeset
28 ------------------------------------------------------------------------------
kono
parents:
diff changeset
29
kono
parents:
diff changeset
30 with System; use type System.Address;
kono
parents:
diff changeset
31
kono
parents:
diff changeset
32 package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
kono
parents:
diff changeset
33
kono
parents:
diff changeset
34 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
kono
parents:
diff changeset
35 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
kono
parents:
diff changeset
36 -- See comment in Ada.Containers.Helpers
kono
parents:
diff changeset
37
kono
parents:
diff changeset
38 -------------------
kono
parents:
diff changeset
39 -- Checked_Index --
kono
parents:
diff changeset
40 -------------------
kono
parents:
diff changeset
41
kono
parents:
diff changeset
42 function Checked_Index
kono
parents:
diff changeset
43 (Hash_Table : aliased in out Hash_Table_Type'Class;
kono
parents:
diff changeset
44 Node : Count_Type) return Hash_Type
kono
parents:
diff changeset
45 is
kono
parents:
diff changeset
46 Lock : With_Lock (Hash_Table.TC'Unrestricted_Access);
kono
parents:
diff changeset
47 begin
kono
parents:
diff changeset
48 return Index (Hash_Table, Hash_Table.Nodes (Node));
kono
parents:
diff changeset
49 end Checked_Index;
kono
parents:
diff changeset
50
kono
parents:
diff changeset
51 -----------
kono
parents:
diff changeset
52 -- Clear --
kono
parents:
diff changeset
53 -----------
kono
parents:
diff changeset
54
kono
parents:
diff changeset
55 procedure Clear (HT : in out Hash_Table_Type'Class) is
kono
parents:
diff changeset
56 begin
kono
parents:
diff changeset
57 TC_Check (HT.TC);
kono
parents:
diff changeset
58
kono
parents:
diff changeset
59 HT.Length := 0;
kono
parents:
diff changeset
60 -- HT.Busy := 0;
kono
parents:
diff changeset
61 -- HT.Lock := 0;
kono
parents:
diff changeset
62 HT.Free := -1;
kono
parents:
diff changeset
63 HT.Buckets := (others => 0); -- optimize this somehow ???
kono
parents:
diff changeset
64 end Clear;
kono
parents:
diff changeset
65
kono
parents:
diff changeset
66 --------------------------
kono
parents:
diff changeset
67 -- Delete_Node_At_Index --
kono
parents:
diff changeset
68 --------------------------
kono
parents:
diff changeset
69
kono
parents:
diff changeset
70 procedure Delete_Node_At_Index
kono
parents:
diff changeset
71 (HT : in out Hash_Table_Type'Class;
kono
parents:
diff changeset
72 Indx : Hash_Type;
kono
parents:
diff changeset
73 X : Count_Type)
kono
parents:
diff changeset
74 is
kono
parents:
diff changeset
75 Prev : Count_Type;
kono
parents:
diff changeset
76 Curr : Count_Type;
kono
parents:
diff changeset
77
kono
parents:
diff changeset
78 begin
kono
parents:
diff changeset
79 Prev := HT.Buckets (Indx);
kono
parents:
diff changeset
80
kono
parents:
diff changeset
81 if Checks and then Prev = 0 then
kono
parents:
diff changeset
82 raise Program_Error with
kono
parents:
diff changeset
83 "attempt to delete node from empty hash bucket";
kono
parents:
diff changeset
84 end if;
kono
parents:
diff changeset
85
kono
parents:
diff changeset
86 if Prev = X then
kono
parents:
diff changeset
87 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
kono
parents:
diff changeset
88 HT.Length := HT.Length - 1;
kono
parents:
diff changeset
89 return;
kono
parents:
diff changeset
90 end if;
kono
parents:
diff changeset
91
kono
parents:
diff changeset
92 if Checks and then HT.Length = 1 then
kono
parents:
diff changeset
93 raise Program_Error with
kono
parents:
diff changeset
94 "attempt to delete node not in its proper hash bucket";
kono
parents:
diff changeset
95 end if;
kono
parents:
diff changeset
96
kono
parents:
diff changeset
97 loop
kono
parents:
diff changeset
98 Curr := Next (HT.Nodes (Prev));
kono
parents:
diff changeset
99
kono
parents:
diff changeset
100 if Checks and then Curr = 0 then
kono
parents:
diff changeset
101 raise Program_Error with
kono
parents:
diff changeset
102 "attempt to delete node not in its proper hash bucket";
kono
parents:
diff changeset
103 end if;
kono
parents:
diff changeset
104
kono
parents:
diff changeset
105 Prev := Curr;
kono
parents:
diff changeset
106 end loop;
kono
parents:
diff changeset
107 end Delete_Node_At_Index;
kono
parents:
diff changeset
108
kono
parents:
diff changeset
109 ---------------------------
kono
parents:
diff changeset
110 -- Delete_Node_Sans_Free --
kono
parents:
diff changeset
111 ---------------------------
kono
parents:
diff changeset
112
kono
parents:
diff changeset
113 procedure Delete_Node_Sans_Free
kono
parents:
diff changeset
114 (HT : in out Hash_Table_Type'Class;
kono
parents:
diff changeset
115 X : Count_Type)
kono
parents:
diff changeset
116 is
kono
parents:
diff changeset
117 pragma Assert (X /= 0);
kono
parents:
diff changeset
118
kono
parents:
diff changeset
119 Indx : Hash_Type;
kono
parents:
diff changeset
120 Prev : Count_Type;
kono
parents:
diff changeset
121 Curr : Count_Type;
kono
parents:
diff changeset
122
kono
parents:
diff changeset
123 begin
kono
parents:
diff changeset
124 if Checks and then HT.Length = 0 then
kono
parents:
diff changeset
125 raise Program_Error with
kono
parents:
diff changeset
126 "attempt to delete node from empty hashed container";
kono
parents:
diff changeset
127 end if;
kono
parents:
diff changeset
128
kono
parents:
diff changeset
129 Indx := Checked_Index (HT, X);
kono
parents:
diff changeset
130 Prev := HT.Buckets (Indx);
kono
parents:
diff changeset
131
kono
parents:
diff changeset
132 if Checks and then Prev = 0 then
kono
parents:
diff changeset
133 raise Program_Error with
kono
parents:
diff changeset
134 "attempt to delete node from empty hash bucket";
kono
parents:
diff changeset
135 end if;
kono
parents:
diff changeset
136
kono
parents:
diff changeset
137 if Prev = X then
kono
parents:
diff changeset
138 HT.Buckets (Indx) := Next (HT.Nodes (Prev));
kono
parents:
diff changeset
139 HT.Length := HT.Length - 1;
kono
parents:
diff changeset
140 return;
kono
parents:
diff changeset
141 end if;
kono
parents:
diff changeset
142
kono
parents:
diff changeset
143 if Checks and then HT.Length = 1 then
kono
parents:
diff changeset
144 raise Program_Error with
kono
parents:
diff changeset
145 "attempt to delete node not in its proper hash bucket";
kono
parents:
diff changeset
146 end if;
kono
parents:
diff changeset
147
kono
parents:
diff changeset
148 loop
kono
parents:
diff changeset
149 Curr := Next (HT.Nodes (Prev));
kono
parents:
diff changeset
150
kono
parents:
diff changeset
151 if Checks and then Curr = 0 then
kono
parents:
diff changeset
152 raise Program_Error with
kono
parents:
diff changeset
153 "attempt to delete node not in its proper hash bucket";
kono
parents:
diff changeset
154 end if;
kono
parents:
diff changeset
155
kono
parents:
diff changeset
156 if Curr = X then
kono
parents:
diff changeset
157 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr)));
kono
parents:
diff changeset
158 HT.Length := HT.Length - 1;
kono
parents:
diff changeset
159 return;
kono
parents:
diff changeset
160 end if;
kono
parents:
diff changeset
161
kono
parents:
diff changeset
162 Prev := Curr;
kono
parents:
diff changeset
163 end loop;
kono
parents:
diff changeset
164 end Delete_Node_Sans_Free;
kono
parents:
diff changeset
165
kono
parents:
diff changeset
166 -----------
kono
parents:
diff changeset
167 -- First --
kono
parents:
diff changeset
168 -----------
kono
parents:
diff changeset
169
kono
parents:
diff changeset
170 function First (HT : Hash_Table_Type'Class) return Count_Type is
kono
parents:
diff changeset
171 Indx : Hash_Type;
kono
parents:
diff changeset
172
kono
parents:
diff changeset
173 begin
kono
parents:
diff changeset
174 if HT.Length = 0 then
kono
parents:
diff changeset
175 return 0;
kono
parents:
diff changeset
176 end if;
kono
parents:
diff changeset
177
kono
parents:
diff changeset
178 Indx := HT.Buckets'First;
kono
parents:
diff changeset
179 loop
kono
parents:
diff changeset
180 if HT.Buckets (Indx) /= 0 then
kono
parents:
diff changeset
181 return HT.Buckets (Indx);
kono
parents:
diff changeset
182 end if;
kono
parents:
diff changeset
183
kono
parents:
diff changeset
184 Indx := Indx + 1;
kono
parents:
diff changeset
185 end loop;
kono
parents:
diff changeset
186 end First;
kono
parents:
diff changeset
187
kono
parents:
diff changeset
188 ----------
kono
parents:
diff changeset
189 -- Free --
kono
parents:
diff changeset
190 ----------
kono
parents:
diff changeset
191
kono
parents:
diff changeset
192 procedure Free
kono
parents:
diff changeset
193 (HT : in out Hash_Table_Type'Class;
kono
parents:
diff changeset
194 X : Count_Type)
kono
parents:
diff changeset
195 is
kono
parents:
diff changeset
196 N : Nodes_Type renames HT.Nodes;
kono
parents:
diff changeset
197
kono
parents:
diff changeset
198 begin
kono
parents:
diff changeset
199 -- This subprogram "deallocates" a node by relinking the node off of the
kono
parents:
diff changeset
200 -- active list and onto the free list. Previously it would flag index
kono
parents:
diff changeset
201 -- value 0 as an error. The precondition was weakened, so that index
kono
parents:
diff changeset
202 -- value 0 is now allowed, and this value is interpreted to mean "do
kono
parents:
diff changeset
203 -- nothing". This makes its behavior analogous to the behavior of
kono
parents:
diff changeset
204 -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add
kono
parents:
diff changeset
205 -- special-case checks at the point of call.
kono
parents:
diff changeset
206
kono
parents:
diff changeset
207 if X = 0 then
kono
parents:
diff changeset
208 return;
kono
parents:
diff changeset
209 end if;
kono
parents:
diff changeset
210
kono
parents:
diff changeset
211 pragma Assert (X <= HT.Capacity);
kono
parents:
diff changeset
212
kono
parents:
diff changeset
213 -- pragma Assert (N (X).Prev >= 0); -- node is active
kono
parents:
diff changeset
214 -- Find a way to mark a node as active vs. inactive; we could
kono
parents:
diff changeset
215 -- use a special value in Color_Type for this. ???
kono
parents:
diff changeset
216
kono
parents:
diff changeset
217 -- The hash table actually contains two data structures: a list for
kono
parents:
diff changeset
218 -- the "active" nodes that contain elements that have been inserted
kono
parents:
diff changeset
219 -- onto the container, and another for the "inactive" nodes of the free
kono
parents:
diff changeset
220 -- store.
kono
parents:
diff changeset
221 --
kono
parents:
diff changeset
222 -- We desire that merely declaring an object should have only minimal
kono
parents:
diff changeset
223 -- cost; specially, we want to avoid having to initialize the free
kono
parents:
diff changeset
224 -- store (to fill in the links), especially if the capacity is large.
kono
parents:
diff changeset
225 --
kono
parents:
diff changeset
226 -- The head of the free list is indicated by Container.Free. If its
kono
parents:
diff changeset
227 -- value is non-negative, then the free store has been initialized
kono
parents:
diff changeset
228 -- in the "normal" way: Container.Free points to the head of the list
kono
parents:
diff changeset
229 -- of free (inactive) nodes, and the value 0 means the free list is
kono
parents:
diff changeset
230 -- empty. Each node on the free list has been initialized to point
kono
parents:
diff changeset
231 -- to the next free node (via its Parent component), and the value 0
kono
parents:
diff changeset
232 -- means that this is the last free node.
kono
parents:
diff changeset
233 --
kono
parents:
diff changeset
234 -- If Container.Free is negative, then the links on the free store
kono
parents:
diff changeset
235 -- have not been initialized. In this case the link values are
kono
parents:
diff changeset
236 -- implied: the free store comprises the components of the node array
kono
parents:
diff changeset
237 -- started with the absolute value of Container.Free, and continuing
kono
parents:
diff changeset
238 -- until the end of the array (Nodes'Last).
kono
parents:
diff changeset
239 --
kono
parents:
diff changeset
240 -- ???
kono
parents:
diff changeset
241 -- It might be possible to perform an optimization here. Suppose that
kono
parents:
diff changeset
242 -- the free store can be represented as having two parts: one
kono
parents:
diff changeset
243 -- comprising the non-contiguous inactive nodes linked together
kono
parents:
diff changeset
244 -- in the normal way, and the other comprising the contiguous
kono
parents:
diff changeset
245 -- inactive nodes (that are not linked together, at the end of the
kono
parents:
diff changeset
246 -- nodes array). This would allow us to never have to initialize
kono
parents:
diff changeset
247 -- the free store, except in a lazy way as nodes become inactive.
kono
parents:
diff changeset
248
kono
parents:
diff changeset
249 -- When an element is deleted from the list container, its node
kono
parents:
diff changeset
250 -- becomes inactive, and so we set its Next component to value of
kono
parents:
diff changeset
251 -- the node's index (in the nodes array), to indicate that it is
kono
parents:
diff changeset
252 -- now inactive. This provides a useful way to detect a dangling
kono
parents:
diff changeset
253 -- cursor reference. ???
kono
parents:
diff changeset
254
kono
parents:
diff changeset
255 Set_Next (N (X), Next => X); -- Node is deallocated (not on active list)
kono
parents:
diff changeset
256
kono
parents:
diff changeset
257 if HT.Free >= 0 then
kono
parents:
diff changeset
258 -- The free store has previously been initialized. All we need to
kono
parents:
diff changeset
259 -- do here is link the newly-free'd node onto the free list.
kono
parents:
diff changeset
260
kono
parents:
diff changeset
261 Set_Next (N (X), HT.Free);
kono
parents:
diff changeset
262 HT.Free := X;
kono
parents:
diff changeset
263
kono
parents:
diff changeset
264 elsif X + 1 = abs HT.Free then
kono
parents:
diff changeset
265 -- The free store has not been initialized, and the node becoming
kono
parents:
diff changeset
266 -- inactive immediately precedes the start of the free store. All
kono
parents:
diff changeset
267 -- we need to do is move the start of the free store back by one.
kono
parents:
diff changeset
268
kono
parents:
diff changeset
269 HT.Free := HT.Free + 1;
kono
parents:
diff changeset
270
kono
parents:
diff changeset
271 else
kono
parents:
diff changeset
272 -- The free store has not been initialized, and the node becoming
kono
parents:
diff changeset
273 -- inactive does not immediately precede the free store. Here we
kono
parents:
diff changeset
274 -- first initialize the free store (meaning the links are given
kono
parents:
diff changeset
275 -- values in the traditional way), and then link the newly-free'd
kono
parents:
diff changeset
276 -- node onto the head of the free store.
kono
parents:
diff changeset
277
kono
parents:
diff changeset
278 -- ???
kono
parents:
diff changeset
279 -- See the comments above for an optimization opportunity. If
kono
parents:
diff changeset
280 -- the next link for a node on the free store is negative, then
kono
parents:
diff changeset
281 -- this means the remaining nodes on the free store are
kono
parents:
diff changeset
282 -- physically contiguous, starting as the absolute value of
kono
parents:
diff changeset
283 -- that index value.
kono
parents:
diff changeset
284
kono
parents:
diff changeset
285 HT.Free := abs HT.Free;
kono
parents:
diff changeset
286
kono
parents:
diff changeset
287 if HT.Free > HT.Capacity then
kono
parents:
diff changeset
288 HT.Free := 0;
kono
parents:
diff changeset
289
kono
parents:
diff changeset
290 else
kono
parents:
diff changeset
291 for I in HT.Free .. HT.Capacity - 1 loop
kono
parents:
diff changeset
292 Set_Next (Node => N (I), Next => I + 1);
kono
parents:
diff changeset
293 end loop;
kono
parents:
diff changeset
294
kono
parents:
diff changeset
295 Set_Next (Node => N (HT.Capacity), Next => 0);
kono
parents:
diff changeset
296 end if;
kono
parents:
diff changeset
297
kono
parents:
diff changeset
298 Set_Next (Node => N (X), Next => HT.Free);
kono
parents:
diff changeset
299 HT.Free := X;
kono
parents:
diff changeset
300 end if;
kono
parents:
diff changeset
301 end Free;
kono
parents:
diff changeset
302
kono
parents:
diff changeset
303 ----------------------
kono
parents:
diff changeset
304 -- Generic_Allocate --
kono
parents:
diff changeset
305 ----------------------
kono
parents:
diff changeset
306
kono
parents:
diff changeset
307 procedure Generic_Allocate
kono
parents:
diff changeset
308 (HT : in out Hash_Table_Type'Class;
kono
parents:
diff changeset
309 Node : out Count_Type)
kono
parents:
diff changeset
310 is
kono
parents:
diff changeset
311 N : Nodes_Type renames HT.Nodes;
kono
parents:
diff changeset
312
kono
parents:
diff changeset
313 begin
kono
parents:
diff changeset
314 if HT.Free >= 0 then
kono
parents:
diff changeset
315 Node := HT.Free;
kono
parents:
diff changeset
316
kono
parents:
diff changeset
317 -- We always perform the assignment first, before we
kono
parents:
diff changeset
318 -- change container state, in order to defend against
kono
parents:
diff changeset
319 -- exceptions duration assignment.
kono
parents:
diff changeset
320
kono
parents:
diff changeset
321 Set_Element (N (Node));
kono
parents:
diff changeset
322 HT.Free := Next (N (Node));
kono
parents:
diff changeset
323
kono
parents:
diff changeset
324 else
kono
parents:
diff changeset
325 -- A negative free store value means that the links of the nodes
kono
parents:
diff changeset
326 -- in the free store have not been initialized. In this case, the
kono
parents:
diff changeset
327 -- nodes are physically contiguous in the array, starting at the
kono
parents:
diff changeset
328 -- index that is the absolute value of the Container.Free, and
kono
parents:
diff changeset
329 -- continuing until the end of the array (Nodes'Last).
kono
parents:
diff changeset
330
kono
parents:
diff changeset
331 Node := abs HT.Free;
kono
parents:
diff changeset
332
kono
parents:
diff changeset
333 -- As above, we perform this assignment first, before modifying
kono
parents:
diff changeset
334 -- any container state.
kono
parents:
diff changeset
335
kono
parents:
diff changeset
336 Set_Element (N (Node));
kono
parents:
diff changeset
337 HT.Free := HT.Free - 1;
kono
parents:
diff changeset
338 end if;
kono
parents:
diff changeset
339 end Generic_Allocate;
kono
parents:
diff changeset
340
kono
parents:
diff changeset
341 -------------------
kono
parents:
diff changeset
342 -- Generic_Equal --
kono
parents:
diff changeset
343 -------------------
kono
parents:
diff changeset
344
kono
parents:
diff changeset
345 function Generic_Equal
kono
parents:
diff changeset
346 (L, R : Hash_Table_Type'Class) return Boolean
kono
parents:
diff changeset
347 is
kono
parents:
diff changeset
348 -- Per AI05-0022, the container implementation is required to detect
kono
parents:
diff changeset
349 -- element tampering by a generic actual subprogram.
kono
parents:
diff changeset
350
kono
parents:
diff changeset
351 Lock_L : With_Lock (L.TC'Unrestricted_Access);
kono
parents:
diff changeset
352 Lock_R : With_Lock (R.TC'Unrestricted_Access);
kono
parents:
diff changeset
353
kono
parents:
diff changeset
354 L_Index : Hash_Type;
kono
parents:
diff changeset
355 L_Node : Count_Type;
kono
parents:
diff changeset
356
kono
parents:
diff changeset
357 N : Count_Type;
kono
parents:
diff changeset
358
kono
parents:
diff changeset
359 begin
kono
parents:
diff changeset
360 if L'Address = R'Address then
kono
parents:
diff changeset
361 return True;
kono
parents:
diff changeset
362 end if;
kono
parents:
diff changeset
363
kono
parents:
diff changeset
364 if L.Length /= R.Length then
kono
parents:
diff changeset
365 return False;
kono
parents:
diff changeset
366 end if;
kono
parents:
diff changeset
367
kono
parents:
diff changeset
368 if L.Length = 0 then
kono
parents:
diff changeset
369 return True;
kono
parents:
diff changeset
370 end if;
kono
parents:
diff changeset
371
kono
parents:
diff changeset
372 -- Find the first node of hash table L
kono
parents:
diff changeset
373
kono
parents:
diff changeset
374 L_Index := L.Buckets'First;
kono
parents:
diff changeset
375 loop
kono
parents:
diff changeset
376 L_Node := L.Buckets (L_Index);
kono
parents:
diff changeset
377 exit when L_Node /= 0;
kono
parents:
diff changeset
378 L_Index := L_Index + 1;
kono
parents:
diff changeset
379 end loop;
kono
parents:
diff changeset
380
kono
parents:
diff changeset
381 -- For each node of hash table L, search for an equivalent node in hash
kono
parents:
diff changeset
382 -- table R.
kono
parents:
diff changeset
383
kono
parents:
diff changeset
384 N := L.Length;
kono
parents:
diff changeset
385 loop
kono
parents:
diff changeset
386 if not Find (HT => R, Key => L.Nodes (L_Node)) then
kono
parents:
diff changeset
387 return False;
kono
parents:
diff changeset
388 end if;
kono
parents:
diff changeset
389
kono
parents:
diff changeset
390 N := N - 1;
kono
parents:
diff changeset
391
kono
parents:
diff changeset
392 L_Node := Next (L.Nodes (L_Node));
kono
parents:
diff changeset
393
kono
parents:
diff changeset
394 if L_Node = 0 then
kono
parents:
diff changeset
395
kono
parents:
diff changeset
396 -- We have exhausted the nodes in this bucket
kono
parents:
diff changeset
397
kono
parents:
diff changeset
398 if N = 0 then
kono
parents:
diff changeset
399 return True;
kono
parents:
diff changeset
400 end if;
kono
parents:
diff changeset
401
kono
parents:
diff changeset
402 -- Find the next bucket
kono
parents:
diff changeset
403
kono
parents:
diff changeset
404 loop
kono
parents:
diff changeset
405 L_Index := L_Index + 1;
kono
parents:
diff changeset
406 L_Node := L.Buckets (L_Index);
kono
parents:
diff changeset
407 exit when L_Node /= 0;
kono
parents:
diff changeset
408 end loop;
kono
parents:
diff changeset
409 end if;
kono
parents:
diff changeset
410 end loop;
kono
parents:
diff changeset
411 end Generic_Equal;
kono
parents:
diff changeset
412
kono
parents:
diff changeset
413 -----------------------
kono
parents:
diff changeset
414 -- Generic_Iteration --
kono
parents:
diff changeset
415 -----------------------
kono
parents:
diff changeset
416
kono
parents:
diff changeset
417 procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
kono
parents:
diff changeset
418 Node : Count_Type;
kono
parents:
diff changeset
419
kono
parents:
diff changeset
420 begin
kono
parents:
diff changeset
421 if HT.Length = 0 then
kono
parents:
diff changeset
422 return;
kono
parents:
diff changeset
423 end if;
kono
parents:
diff changeset
424
kono
parents:
diff changeset
425 for Indx in HT.Buckets'Range loop
kono
parents:
diff changeset
426 Node := HT.Buckets (Indx);
kono
parents:
diff changeset
427 while Node /= 0 loop
kono
parents:
diff changeset
428 Process (Node);
kono
parents:
diff changeset
429 Node := Next (HT.Nodes (Node));
kono
parents:
diff changeset
430 end loop;
kono
parents:
diff changeset
431 end loop;
kono
parents:
diff changeset
432 end Generic_Iteration;
kono
parents:
diff changeset
433
kono
parents:
diff changeset
434 ------------------
kono
parents:
diff changeset
435 -- Generic_Read --
kono
parents:
diff changeset
436 ------------------
kono
parents:
diff changeset
437
kono
parents:
diff changeset
438 procedure Generic_Read
kono
parents:
diff changeset
439 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
440 HT : out Hash_Table_Type'Class)
kono
parents:
diff changeset
441 is
kono
parents:
diff changeset
442 N : Count_Type'Base;
kono
parents:
diff changeset
443
kono
parents:
diff changeset
444 begin
kono
parents:
diff changeset
445 Clear (HT);
kono
parents:
diff changeset
446
kono
parents:
diff changeset
447 Count_Type'Base'Read (Stream, N);
kono
parents:
diff changeset
448
kono
parents:
diff changeset
449 if Checks and then N < 0 then
kono
parents:
diff changeset
450 raise Program_Error with "stream appears to be corrupt";
kono
parents:
diff changeset
451 end if;
kono
parents:
diff changeset
452
kono
parents:
diff changeset
453 if N = 0 then
kono
parents:
diff changeset
454 return;
kono
parents:
diff changeset
455 end if;
kono
parents:
diff changeset
456
kono
parents:
diff changeset
457 if Checks and then N > HT.Capacity then
kono
parents:
diff changeset
458 raise Capacity_Error with "too many elements in stream";
kono
parents:
diff changeset
459 end if;
kono
parents:
diff changeset
460
kono
parents:
diff changeset
461 for J in 1 .. N loop
kono
parents:
diff changeset
462 declare
kono
parents:
diff changeset
463 Node : constant Count_Type := New_Node (Stream);
kono
parents:
diff changeset
464 Indx : constant Hash_Type := Checked_Index (HT, Node);
kono
parents:
diff changeset
465 B : Count_Type renames HT.Buckets (Indx);
kono
parents:
diff changeset
466 begin
kono
parents:
diff changeset
467 Set_Next (HT.Nodes (Node), Next => B);
kono
parents:
diff changeset
468 B := Node;
kono
parents:
diff changeset
469 end;
kono
parents:
diff changeset
470
kono
parents:
diff changeset
471 HT.Length := HT.Length + 1;
kono
parents:
diff changeset
472 end loop;
kono
parents:
diff changeset
473 end Generic_Read;
kono
parents:
diff changeset
474
kono
parents:
diff changeset
475 -------------------
kono
parents:
diff changeset
476 -- Generic_Write --
kono
parents:
diff changeset
477 -------------------
kono
parents:
diff changeset
478
kono
parents:
diff changeset
479 procedure Generic_Write
kono
parents:
diff changeset
480 (Stream : not null access Root_Stream_Type'Class;
kono
parents:
diff changeset
481 HT : Hash_Table_Type'Class)
kono
parents:
diff changeset
482 is
kono
parents:
diff changeset
483 procedure Write (Node : Count_Type);
kono
parents:
diff changeset
484 pragma Inline (Write);
kono
parents:
diff changeset
485
kono
parents:
diff changeset
486 procedure Write is new Generic_Iteration (Write);
kono
parents:
diff changeset
487
kono
parents:
diff changeset
488 -----------
kono
parents:
diff changeset
489 -- Write --
kono
parents:
diff changeset
490 -----------
kono
parents:
diff changeset
491
kono
parents:
diff changeset
492 procedure Write (Node : Count_Type) is
kono
parents:
diff changeset
493 begin
kono
parents:
diff changeset
494 Write (Stream, HT.Nodes (Node));
kono
parents:
diff changeset
495 end Write;
kono
parents:
diff changeset
496
kono
parents:
diff changeset
497 begin
kono
parents:
diff changeset
498 Count_Type'Base'Write (Stream, HT.Length);
kono
parents:
diff changeset
499 Write (HT);
kono
parents:
diff changeset
500 end Generic_Write;
kono
parents:
diff changeset
501
kono
parents:
diff changeset
502 -----------
kono
parents:
diff changeset
503 -- Index --
kono
parents:
diff changeset
504 -----------
kono
parents:
diff changeset
505
kono
parents:
diff changeset
506 function Index
kono
parents:
diff changeset
507 (Buckets : Buckets_Type;
kono
parents:
diff changeset
508 Node : Node_Type) return Hash_Type is
kono
parents:
diff changeset
509 begin
kono
parents:
diff changeset
510 return Buckets'First + Hash_Node (Node) mod Buckets'Length;
kono
parents:
diff changeset
511 end Index;
kono
parents:
diff changeset
512
kono
parents:
diff changeset
513 function Index
kono
parents:
diff changeset
514 (HT : Hash_Table_Type'Class;
kono
parents:
diff changeset
515 Node : Node_Type) return Hash_Type is
kono
parents:
diff changeset
516 begin
kono
parents:
diff changeset
517 return Index (HT.Buckets, Node);
kono
parents:
diff changeset
518 end Index;
kono
parents:
diff changeset
519
kono
parents:
diff changeset
520 ----------
kono
parents:
diff changeset
521 -- Next --
kono
parents:
diff changeset
522 ----------
kono
parents:
diff changeset
523
kono
parents:
diff changeset
524 function Next
kono
parents:
diff changeset
525 (HT : Hash_Table_Type'Class;
kono
parents:
diff changeset
526 Node : Count_Type) return Count_Type
kono
parents:
diff changeset
527 is
kono
parents:
diff changeset
528 Result : Count_Type;
kono
parents:
diff changeset
529 First : Hash_Type;
kono
parents:
diff changeset
530
kono
parents:
diff changeset
531 begin
kono
parents:
diff changeset
532 Result := Next (HT.Nodes (Node));
kono
parents:
diff changeset
533
kono
parents:
diff changeset
534 if Result /= 0 then -- another node in same bucket
kono
parents:
diff changeset
535 return Result;
kono
parents:
diff changeset
536 end if;
kono
parents:
diff changeset
537
kono
parents:
diff changeset
538 -- This was the last node in the bucket, so move to the next
kono
parents:
diff changeset
539 -- bucket, and start searching for next node from there.
kono
parents:
diff changeset
540
kono
parents:
diff changeset
541 First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1;
kono
parents:
diff changeset
542 for Indx in First .. HT.Buckets'Last loop
kono
parents:
diff changeset
543 Result := HT.Buckets (Indx);
kono
parents:
diff changeset
544
kono
parents:
diff changeset
545 if Result /= 0 then -- bucket is not empty
kono
parents:
diff changeset
546 return Result;
kono
parents:
diff changeset
547 end if;
kono
parents:
diff changeset
548 end loop;
kono
parents:
diff changeset
549
kono
parents:
diff changeset
550 return 0;
kono
parents:
diff changeset
551 end Next;
kono
parents:
diff changeset
552
kono
parents:
diff changeset
553 end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;