]>
Commit | Line | Data |
---|---|---|
4c2d6a70 AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT LIBRARY COMPONENTS -- | |
4 | -- -- | |
8704d4b3 MH |
5 | -- A D A . C O N T A I N E R S . -- |
6 | -- I N D E F I N I T E _ H A S H E D _ S E T S -- | |
4c2d6a70 AC |
7 | -- -- |
8 | -- B o d y -- | |
9 | -- -- | |
ffabcde5 | 10 | -- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- |
4c2d6a70 AC |
11 | -- -- |
12 | -- This specification is derived from the Ada Reference Manual for use with -- | |
13 | -- GNAT. The copyright notice above, and the license provisions that follow -- | |
14 | -- apply solely to the contents of the part following the private keyword. -- | |
15 | -- -- | |
16 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
17 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
18 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
19 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
20 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
21 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
22 | -- for more details. You should have received a copy of the GNU General -- | |
23 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
cb5fee25 KC |
24 | -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
25 | -- Boston, MA 02110-1301, USA. -- | |
4c2d6a70 AC |
26 | -- -- |
27 | -- As a special exception, if other files instantiate generics from this -- | |
28 | -- unit, or you link this unit with other files to produce an executable, -- | |
29 | -- this unit does not by itself cause the resulting executable to be -- | |
30 | -- covered by the GNU General Public License. This exception does not -- | |
31 | -- however invalidate any other reasons why the executable file might be -- | |
32 | -- covered by the GNU Public License. -- | |
33 | -- -- | |
34 | -- This unit has originally being developed by Matthew J Heaney. -- | |
35 | ------------------------------------------------------------------------------ | |
36 | ||
37 | with Ada.Unchecked_Deallocation; | |
38 | ||
39 | with Ada.Containers.Hash_Tables.Generic_Operations; | |
40 | pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); | |
41 | ||
42 | with Ada.Containers.Hash_Tables.Generic_Keys; | |
43 | pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); | |
44 | ||
4c2d6a70 AC |
45 | with Ada.Containers.Prime_Numbers; |
46 | ||
ffabcde5 MH |
47 | with System; use type System.Address; |
48 | ||
4c2d6a70 AC |
49 | package body Ada.Containers.Indefinite_Hashed_Sets is |
50 | ||
8704d4b3 MH |
51 | ----------------------- |
52 | -- Local Subprograms -- | |
53 | ----------------------- | |
4c2d6a70 | 54 | |
8704d4b3 MH |
55 | function Copy_Node (Source : Node_Access) return Node_Access; |
56 | pragma Inline (Copy_Node); | |
4c2d6a70 | 57 | |
8704d4b3 MH |
58 | function Equivalent_Keys |
59 | (Key : Element_Type; | |
60 | Node : Node_Access) return Boolean; | |
61 | pragma Inline (Equivalent_Keys); | |
4c2d6a70 | 62 | |
8704d4b3 MH |
63 | function Find_Equal_Key |
64 | (R_HT : Hash_Table_Type; | |
65 | L_Node : Node_Access) return Boolean; | |
4c2d6a70 | 66 | |
8704d4b3 MH |
67 | function Find_Equivalent_Key |
68 | (R_HT : Hash_Table_Type; | |
69 | L_Node : Node_Access) return Boolean; | |
4c2d6a70 | 70 | |
8704d4b3 | 71 | procedure Free (X : in out Node_Access); |
4c2d6a70 | 72 | |
8704d4b3 MH |
73 | function Hash_Node (Node : Node_Access) return Hash_Type; |
74 | pragma Inline (Hash_Node); | |
4c2d6a70 | 75 | |
2368f04e MH |
76 | procedure Insert |
77 | (HT : in out Hash_Table_Type; | |
78 | New_Item : Element_Type; | |
79 | Node : out Node_Access; | |
80 | Inserted : out Boolean); | |
81 | ||
8704d4b3 MH |
82 | function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean; |
83 | pragma Inline (Is_In); | |
4c2d6a70 | 84 | |
8704d4b3 MH |
85 | function Next (Node : Node_Access) return Node_Access; |
86 | pragma Inline (Next); | |
4c2d6a70 | 87 | |
8704d4b3 MH |
88 | function Read_Node (Stream : access Root_Stream_Type'Class) |
89 | return Node_Access; | |
90 | pragma Inline (Read_Node); | |
4c2d6a70 | 91 | |
8704d4b3 | 92 | procedure Replace_Element |
ba355842 MH |
93 | (HT : in out Hash_Table_Type; |
94 | Node : Node_Access; | |
95 | New_Item : Element_Type); | |
4c2d6a70 | 96 | |
8704d4b3 MH |
97 | procedure Set_Next (Node : Node_Access; Next : Node_Access); |
98 | pragma Inline (Set_Next); | |
4c2d6a70 | 99 | |
ba355842 MH |
100 | function Vet (Position : Cursor) return Boolean; |
101 | ||
8704d4b3 MH |
102 | procedure Write_Node |
103 | (Stream : access Root_Stream_Type'Class; | |
104 | Node : Node_Access); | |
105 | pragma Inline (Write_Node); | |
4c2d6a70 | 106 | |
8704d4b3 MH |
107 | -------------------------- |
108 | -- Local Instantiations -- | |
109 | -------------------------- | |
4c2d6a70 AC |
110 | |
111 | procedure Free_Element is | |
112 | new Ada.Unchecked_Deallocation (Element_Type, Element_Access); | |
113 | ||
4c2d6a70 AC |
114 | package HT_Ops is |
115 | new Hash_Tables.Generic_Operations | |
8704d4b3 MH |
116 | (HT_Types => HT_Types, |
117 | Hash_Node => Hash_Node, | |
118 | Next => Next, | |
119 | Set_Next => Set_Next, | |
120 | Copy_Node => Copy_Node, | |
121 | Free => Free); | |
4c2d6a70 AC |
122 | |
123 | package Element_Keys is | |
124 | new Hash_Tables.Generic_Keys | |
125 | (HT_Types => HT_Types, | |
4c2d6a70 AC |
126 | Next => Next, |
127 | Set_Next => Set_Next, | |
128 | Key_Type => Element_Type, | |
129 | Hash => Hash, | |
130 | Equivalent_Keys => Equivalent_Keys); | |
131 | ||
8704d4b3 MH |
132 | function Is_Equal is |
133 | new HT_Ops.Generic_Equal (Find_Equal_Key); | |
4c2d6a70 | 134 | |
8704d4b3 MH |
135 | function Is_Equivalent is |
136 | new HT_Ops.Generic_Equal (Find_Equivalent_Key); | |
4c2d6a70 | 137 | |
8704d4b3 MH |
138 | procedure Read_Nodes is |
139 | new HT_Ops.Generic_Read (Read_Node); | |
4c2d6a70 | 140 | |
8704d4b3 MH |
141 | procedure Write_Nodes is |
142 | new HT_Ops.Generic_Write (Write_Node); | |
4c2d6a70 | 143 | |
8704d4b3 MH |
144 | --------- |
145 | -- "=" -- | |
146 | --------- | |
4c2d6a70 | 147 | |
8704d4b3 | 148 | function "=" (Left, Right : Set) return Boolean is |
4c2d6a70 | 149 | begin |
8704d4b3 MH |
150 | return Is_Equal (Left.HT, Right.HT); |
151 | end "="; | |
4c2d6a70 | 152 | |
8704d4b3 MH |
153 | ------------ |
154 | -- Adjust -- | |
155 | ------------ | |
4c2d6a70 | 156 | |
8704d4b3 MH |
157 | procedure Adjust (Container : in out Set) is |
158 | begin | |
159 | HT_Ops.Adjust (Container.HT); | |
160 | end Adjust; | |
4c2d6a70 | 161 | |
8704d4b3 MH |
162 | -------------- |
163 | -- Capacity -- | |
164 | -------------- | |
4c2d6a70 | 165 | |
8704d4b3 | 166 | function Capacity (Container : Set) return Count_Type is |
4c2d6a70 | 167 | begin |
8704d4b3 MH |
168 | return HT_Ops.Capacity (Container.HT); |
169 | end Capacity; | |
4c2d6a70 | 170 | |
8704d4b3 MH |
171 | ----------- |
172 | -- Clear -- | |
173 | ----------- | |
4c2d6a70 | 174 | |
8704d4b3 | 175 | procedure Clear (Container : in out Set) is |
4c2d6a70 | 176 | begin |
8704d4b3 MH |
177 | HT_Ops.Clear (Container.HT); |
178 | end Clear; | |
4c2d6a70 | 179 | |
8704d4b3 MH |
180 | -------------- |
181 | -- Contains -- | |
182 | -------------- | |
4c2d6a70 | 183 | |
8704d4b3 MH |
184 | function Contains (Container : Set; Item : Element_Type) return Boolean is |
185 | begin | |
186 | return Find (Container, Item) /= No_Element; | |
187 | end Contains; | |
4c2d6a70 | 188 | |
8704d4b3 MH |
189 | --------------- |
190 | -- Copy_Node -- | |
191 | --------------- | |
4c2d6a70 | 192 | |
8704d4b3 MH |
193 | function Copy_Node (Source : Node_Access) return Node_Access is |
194 | E : Element_Access := new Element_Type'(Source.Element.all); | |
4c2d6a70 | 195 | begin |
8704d4b3 MH |
196 | return new Node_Type'(Element => E, Next => null); |
197 | exception | |
198 | when others => | |
199 | Free_Element (E); | |
200 | raise; | |
201 | end Copy_Node; | |
4c2d6a70 | 202 | |
8704d4b3 MH |
203 | ------------ |
204 | -- Delete -- | |
205 | ------------ | |
4c2d6a70 | 206 | |
8704d4b3 MH |
207 | procedure Delete |
208 | (Container : in out Set; | |
209 | Item : Element_Type) | |
210 | is | |
211 | X : Node_Access; | |
4c2d6a70 | 212 | |
8704d4b3 MH |
213 | begin |
214 | Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); | |
4c2d6a70 | 215 | |
8704d4b3 | 216 | if X = null then |
ffabcde5 | 217 | raise Constraint_Error with "attempt to delete element not in set"; |
8704d4b3 | 218 | end if; |
4c2d6a70 | 219 | |
8704d4b3 MH |
220 | Free (X); |
221 | end Delete; | |
4c2d6a70 | 222 | |
8704d4b3 MH |
223 | procedure Delete |
224 | (Container : in out Set; | |
225 | Position : in out Cursor) | |
226 | is | |
227 | begin | |
228 | if Position.Node = null then | |
ffabcde5 | 229 | raise Constraint_Error with "Position cursor equals No_Element"; |
8704d4b3 | 230 | end if; |
4c2d6a70 | 231 | |
ba355842 | 232 | if Position.Node.Element = null then |
ffabcde5 | 233 | raise Program_Error with "Position cursor is bad"; |
ba355842 MH |
234 | end if; |
235 | ||
236 | if Position.Container /= Container'Unrestricted_Access then | |
ffabcde5 | 237 | raise Program_Error with "Position cursor designates wrong set"; |
8704d4b3 | 238 | end if; |
4c2d6a70 | 239 | |
8704d4b3 | 240 | if Container.HT.Busy > 0 then |
ffabcde5 MH |
241 | raise Program_Error with |
242 | "attempt to tamper with elements (set is busy)"; | |
8704d4b3 | 243 | end if; |
4c2d6a70 | 244 | |
ffabcde5 MH |
245 | pragma Assert (Vet (Position), "Position cursor is bad"); |
246 | ||
8704d4b3 | 247 | HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); |
4c2d6a70 | 248 | |
8704d4b3 | 249 | Free (Position.Node); |
8704d4b3 MH |
250 | Position.Container := null; |
251 | end Delete; | |
4c2d6a70 | 252 | |
8704d4b3 MH |
253 | ---------------- |
254 | -- Difference -- | |
255 | ---------------- | |
4c2d6a70 | 256 | |
8704d4b3 MH |
257 | procedure Difference |
258 | (Target : in out Set; | |
259 | Source : Set) | |
260 | is | |
261 | Tgt_Node : Node_Access; | |
4c2d6a70 | 262 | |
8704d4b3 MH |
263 | begin |
264 | if Target'Address = Source'Address then | |
265 | Clear (Target); | |
266 | return; | |
267 | end if; | |
4c2d6a70 | 268 | |
8704d4b3 MH |
269 | if Source.Length = 0 then |
270 | return; | |
271 | end if; | |
4c2d6a70 | 272 | |
8704d4b3 | 273 | if Target.HT.Busy > 0 then |
ffabcde5 MH |
274 | raise Program_Error with |
275 | "attempt to tamper with elements (set is busy)"; | |
8704d4b3 | 276 | end if; |
4c2d6a70 | 277 | |
8704d4b3 MH |
278 | -- TODO: This can be written in terms of a loop instead as |
279 | -- active-iterator style, sort of like a passive iterator. | |
4c2d6a70 | 280 | |
8704d4b3 MH |
281 | Tgt_Node := HT_Ops.First (Target.HT); |
282 | while Tgt_Node /= null loop | |
283 | if Is_In (Source.HT, Tgt_Node) then | |
284 | declare | |
285 | X : Node_Access := Tgt_Node; | |
286 | begin | |
287 | Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); | |
288 | HT_Ops.Delete_Node_Sans_Free (Target.HT, X); | |
289 | Free (X); | |
290 | end; | |
4c2d6a70 | 291 | |
8704d4b3 MH |
292 | else |
293 | Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); | |
294 | end if; | |
295 | end loop; | |
296 | end Difference; | |
4c2d6a70 | 297 | |
8704d4b3 MH |
298 | function Difference (Left, Right : Set) return Set is |
299 | Buckets : HT_Types.Buckets_Access; | |
300 | Length : Count_Type; | |
4c2d6a70 | 301 | |
8704d4b3 MH |
302 | begin |
303 | if Left'Address = Right'Address then | |
304 | return Empty_Set; | |
305 | end if; | |
4c2d6a70 | 306 | |
8704d4b3 MH |
307 | if Left.Length = 0 then |
308 | return Empty_Set; | |
309 | end if; | |
4c2d6a70 | 310 | |
8704d4b3 MH |
311 | if Right.Length = 0 then |
312 | return Left; | |
313 | end if; | |
4c2d6a70 | 314 | |
8704d4b3 MH |
315 | declare |
316 | Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); | |
317 | begin | |
318 | Buckets := new Buckets_Type (0 .. Size - 1); | |
319 | end; | |
4c2d6a70 | 320 | |
8704d4b3 | 321 | Length := 0; |
4c2d6a70 | 322 | |
8704d4b3 MH |
323 | Iterate_Left : declare |
324 | procedure Process (L_Node : Node_Access); | |
4c2d6a70 | 325 | |
8704d4b3 MH |
326 | procedure Iterate is |
327 | new HT_Ops.Generic_Iteration (Process); | |
4c2d6a70 | 328 | |
8704d4b3 MH |
329 | ------------- |
330 | -- Process -- | |
331 | ------------- | |
4c2d6a70 | 332 | |
8704d4b3 MH |
333 | procedure Process (L_Node : Node_Access) is |
334 | begin | |
335 | if not Is_In (Right.HT, L_Node) then | |
336 | declare | |
2368f04e MH |
337 | Src : Element_Type renames L_Node.Element.all; |
338 | Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; | |
8704d4b3 | 339 | Bucket : Node_Access renames Buckets (Indx); |
2368f04e | 340 | Tgt : Element_Access := new Element_Type'(Src); |
8704d4b3 | 341 | begin |
2368f04e MH |
342 | Bucket := new Node_Type'(Tgt, Bucket); |
343 | exception | |
344 | when others => | |
345 | Free_Element (Tgt); | |
346 | raise; | |
8704d4b3 | 347 | end; |
4c2d6a70 | 348 | |
8704d4b3 MH |
349 | Length := Length + 1; |
350 | end if; | |
351 | end Process; | |
4c2d6a70 | 352 | |
8704d4b3 | 353 | -- Start of processing for Iterate_Left |
4c2d6a70 | 354 | |
4c2d6a70 | 355 | begin |
8704d4b3 | 356 | Iterate (Left.HT); |
4c2d6a70 AC |
357 | exception |
358 | when others => | |
8704d4b3 | 359 | HT_Ops.Free_Hash_Table (Buckets); |
4c2d6a70 | 360 | raise; |
8704d4b3 | 361 | end Iterate_Left; |
4c2d6a70 | 362 | |
8704d4b3 MH |
363 | return (Controlled with HT => (Buckets, Length, 0, 0)); |
364 | end Difference; | |
365 | ||
366 | ------------- | |
367 | -- Element -- | |
368 | ------------- | |
4c2d6a70 | 369 | |
8704d4b3 | 370 | function Element (Position : Cursor) return Element_Type is |
4c2d6a70 | 371 | begin |
ba355842 | 372 | if Position.Node = null then |
ffabcde5 | 373 | raise Constraint_Error with "Position cursor of equals No_Element"; |
ba355842 MH |
374 | end if; |
375 | ||
376 | if Position.Node.Element = null then -- handle dangling reference | |
ffabcde5 | 377 | raise Program_Error with "Position cursor is bad"; |
ba355842 MH |
378 | end if; |
379 | ||
ffabcde5 MH |
380 | pragma Assert (Vet (Position), "bad cursor in function Element"); |
381 | ||
8704d4b3 MH |
382 | return Position.Node.Element.all; |
383 | end Element; | |
4c2d6a70 | 384 | |
8704d4b3 MH |
385 | --------------------- |
386 | -- Equivalent_Sets -- | |
387 | --------------------- | |
4c2d6a70 | 388 | |
8704d4b3 MH |
389 | function Equivalent_Sets (Left, Right : Set) return Boolean is |
390 | begin | |
391 | return Is_Equivalent (Left.HT, Right.HT); | |
392 | end Equivalent_Sets; | |
4c2d6a70 | 393 | |
8704d4b3 MH |
394 | ------------------------- |
395 | -- Equivalent_Elements -- | |
396 | ------------------------- | |
4c2d6a70 | 397 | |
8704d4b3 MH |
398 | function Equivalent_Elements (Left, Right : Cursor) |
399 | return Boolean is | |
400 | begin | |
ffabcde5 MH |
401 | if Left.Node = null then |
402 | raise Constraint_Error with | |
403 | "Left cursor of Equivalent_Elements equals No_Element"; | |
404 | end if; | |
ba355842 | 405 | |
ffabcde5 MH |
406 | if Right.Node = null then |
407 | raise Constraint_Error with | |
408 | "Right cursor of Equivalent_Elements equals No_Element"; | |
ba355842 MH |
409 | end if; |
410 | ||
ffabcde5 MH |
411 | if Left.Node.Element = null then |
412 | raise Program_Error with | |
413 | "Left cursor of Equivalent_Elements is bad"; | |
ba355842 MH |
414 | end if; |
415 | ||
ffabcde5 MH |
416 | if Right.Node.Element = null then |
417 | raise Program_Error with | |
418 | "Right cursor of Equivalent_Elements is bad"; | |
419 | end if; | |
420 | ||
421 | pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); | |
422 | pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); | |
423 | ||
8704d4b3 MH |
424 | return Equivalent_Elements |
425 | (Left.Node.Element.all, | |
426 | Right.Node.Element.all); | |
427 | end Equivalent_Elements; | |
4c2d6a70 | 428 | |
8704d4b3 MH |
429 | function Equivalent_Elements (Left : Cursor; Right : Element_Type) |
430 | return Boolean is | |
431 | begin | |
ba355842 | 432 | if Left.Node = null then |
ffabcde5 MH |
433 | raise Constraint_Error with |
434 | "Left cursor of Equivalent_Elements equals No_Element"; | |
ba355842 MH |
435 | end if; |
436 | ||
ffabcde5 MH |
437 | if Left.Node.Element = null then |
438 | raise Program_Error with | |
439 | "Left cursor of Equivalent_Elements is bad"; | |
ba355842 MH |
440 | end if; |
441 | ||
ffabcde5 MH |
442 | pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); |
443 | ||
8704d4b3 MH |
444 | return Equivalent_Elements (Left.Node.Element.all, Right); |
445 | end Equivalent_Elements; | |
4c2d6a70 | 446 | |
8704d4b3 MH |
447 | function Equivalent_Elements (Left : Element_Type; Right : Cursor) |
448 | return Boolean is | |
4c2d6a70 | 449 | begin |
ba355842 | 450 | if Right.Node = null then |
ffabcde5 MH |
451 | raise Constraint_Error with |
452 | "Right cursor of Equivalent_Elements equals No_Element"; | |
ba355842 MH |
453 | end if; |
454 | ||
ffabcde5 MH |
455 | if Right.Node.Element = null then |
456 | raise Program_Error with | |
457 | "Right cursor of Equivalent_Elements is bad"; | |
ba355842 MH |
458 | end if; |
459 | ||
ffabcde5 MH |
460 | pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); |
461 | ||
8704d4b3 MH |
462 | return Equivalent_Elements (Left, Right.Node.Element.all); |
463 | end Equivalent_Elements; | |
4c2d6a70 | 464 | |
8704d4b3 MH |
465 | --------------------- |
466 | -- Equivalent_Keys -- | |
467 | --------------------- | |
4c2d6a70 | 468 | |
8704d4b3 MH |
469 | function Equivalent_Keys (Key : Element_Type; Node : Node_Access) |
470 | return Boolean is | |
471 | begin | |
472 | return Equivalent_Elements (Key, Node.Element.all); | |
473 | end Equivalent_Keys; | |
4c2d6a70 | 474 | |
8704d4b3 MH |
475 | ------------- |
476 | -- Exclude -- | |
477 | ------------- | |
4c2d6a70 | 478 | |
8704d4b3 MH |
479 | procedure Exclude |
480 | (Container : in out Set; | |
481 | Item : Element_Type) | |
482 | is | |
483 | X : Node_Access; | |
484 | begin | |
485 | Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); | |
486 | Free (X); | |
487 | end Exclude; | |
4c2d6a70 | 488 | |
8704d4b3 MH |
489 | -------------- |
490 | -- Finalize -- | |
491 | -------------- | |
4c2d6a70 | 492 | |
8704d4b3 MH |
493 | procedure Finalize (Container : in out Set) is |
494 | begin | |
495 | HT_Ops.Finalize (Container.HT); | |
496 | end Finalize; | |
4c2d6a70 | 497 | |
8704d4b3 MH |
498 | ---------- |
499 | -- Find -- | |
500 | ---------- | |
4c2d6a70 | 501 | |
8704d4b3 MH |
502 | function Find |
503 | (Container : Set; | |
504 | Item : Element_Type) return Cursor | |
505 | is | |
506 | Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); | |
4c2d6a70 | 507 | |
8704d4b3 | 508 | begin |
4c2d6a70 | 509 | if Node = null then |
8704d4b3 | 510 | return No_Element; |
4c2d6a70 AC |
511 | end if; |
512 | ||
8704d4b3 MH |
513 | return Cursor'(Container'Unrestricted_Access, Node); |
514 | end Find; | |
4c2d6a70 | 515 | |
8704d4b3 MH |
516 | -------------------- |
517 | -- Find_Equal_Key -- | |
518 | -------------------- | |
4c2d6a70 | 519 | |
8704d4b3 MH |
520 | function Find_Equal_Key |
521 | (R_HT : Hash_Table_Type; | |
522 | L_Node : Node_Access) return Boolean | |
523 | is | |
524 | R_Index : constant Hash_Type := | |
525 | Element_Keys.Index (R_HT, L_Node.Element.all); | |
4c2d6a70 | 526 | |
8704d4b3 | 527 | R_Node : Node_Access := R_HT.Buckets (R_Index); |
4c2d6a70 | 528 | |
8704d4b3 MH |
529 | begin |
530 | loop | |
531 | if R_Node = null then | |
532 | return False; | |
533 | end if; | |
4c2d6a70 | 534 | |
8704d4b3 MH |
535 | if L_Node.Element.all = R_Node.Element.all then |
536 | return True; | |
537 | end if; | |
4c2d6a70 | 538 | |
8704d4b3 MH |
539 | R_Node := Next (R_Node); |
540 | end loop; | |
541 | end Find_Equal_Key; | |
4c2d6a70 | 542 | |
8704d4b3 MH |
543 | ------------------------- |
544 | -- Find_Equivalent_Key -- | |
545 | ------------------------- | |
546 | ||
547 | function Find_Equivalent_Key | |
548 | (R_HT : Hash_Table_Type; | |
549 | L_Node : Node_Access) return Boolean | |
550 | is | |
551 | R_Index : constant Hash_Type := | |
552 | Element_Keys.Index (R_HT, L_Node.Element.all); | |
553 | ||
554 | R_Node : Node_Access := R_HT.Buckets (R_Index); | |
4c2d6a70 AC |
555 | |
556 | begin | |
8704d4b3 MH |
557 | loop |
558 | if R_Node = null then | |
559 | return False; | |
560 | end if; | |
4c2d6a70 | 561 | |
8704d4b3 MH |
562 | if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then |
563 | return True; | |
564 | end if; | |
4c2d6a70 | 565 | |
8704d4b3 MH |
566 | R_Node := Next (R_Node); |
567 | end loop; | |
568 | end Find_Equivalent_Key; | |
4c2d6a70 | 569 | |
8704d4b3 MH |
570 | ----------- |
571 | -- First -- | |
572 | ----------- | |
4c2d6a70 | 573 | |
8704d4b3 MH |
574 | function First (Container : Set) return Cursor is |
575 | Node : constant Node_Access := HT_Ops.First (Container.HT); | |
4c2d6a70 | 576 | |
8704d4b3 MH |
577 | begin |
578 | if Node = null then | |
579 | return No_Element; | |
4c2d6a70 AC |
580 | end if; |
581 | ||
8704d4b3 MH |
582 | return Cursor'(Container'Unrestricted_Access, Node); |
583 | end First; | |
4c2d6a70 | 584 | |
8704d4b3 MH |
585 | ---------- |
586 | -- Free -- | |
587 | ---------- | |
4c2d6a70 | 588 | |
8704d4b3 MH |
589 | procedure Free (X : in out Node_Access) is |
590 | procedure Deallocate is | |
591 | new Ada.Unchecked_Deallocation (Node_Type, Node_Access); | |
4c2d6a70 AC |
592 | |
593 | begin | |
4c2d6a70 | 594 | if X = null then |
8704d4b3 | 595 | return; |
4c2d6a70 AC |
596 | end if; |
597 | ||
ba355842 MH |
598 | X.Next := X; -- detect mischief (in Vet) |
599 | ||
8704d4b3 MH |
600 | begin |
601 | Free_Element (X.Element); | |
602 | exception | |
603 | when others => | |
604 | X.Element := null; | |
605 | Deallocate (X); | |
606 | raise; | |
607 | end; | |
4c2d6a70 | 608 | |
8704d4b3 MH |
609 | Deallocate (X); |
610 | end Free; | |
4c2d6a70 | 611 | |
8704d4b3 MH |
612 | ----------------- |
613 | -- Has_Element -- | |
614 | ----------------- | |
4c2d6a70 | 615 | |
8704d4b3 MH |
616 | function Has_Element (Position : Cursor) return Boolean is |
617 | begin | |
ba355842 MH |
618 | pragma Assert (Vet (Position), "bad cursor in Has_Element"); |
619 | return Position.Node /= null; | |
8704d4b3 | 620 | end Has_Element; |
4c2d6a70 | 621 | |
8704d4b3 MH |
622 | --------------- |
623 | -- Hash_Node -- | |
624 | --------------- | |
625 | ||
626 | function Hash_Node (Node : Node_Access) return Hash_Type is | |
4c2d6a70 | 627 | begin |
8704d4b3 MH |
628 | return Hash (Node.Element.all); |
629 | end Hash_Node; | |
4c2d6a70 | 630 | |
8704d4b3 MH |
631 | ------------- |
632 | -- Include -- | |
633 | ------------- | |
4c2d6a70 | 634 | |
8704d4b3 MH |
635 | procedure Include |
636 | (Container : in out Set; | |
637 | New_Item : Element_Type) | |
638 | is | |
639 | Position : Cursor; | |
640 | Inserted : Boolean; | |
4c2d6a70 | 641 | |
8704d4b3 | 642 | X : Element_Access; |
4c2d6a70 | 643 | |
4c2d6a70 | 644 | begin |
8704d4b3 | 645 | Insert (Container, New_Item, Position, Inserted); |
4c2d6a70 | 646 | |
8704d4b3 MH |
647 | if not Inserted then |
648 | if Container.HT.Lock > 0 then | |
ffabcde5 MH |
649 | raise Program_Error with |
650 | "attempt to tamper with cursors (set is locked)"; | |
8704d4b3 | 651 | end if; |
4c2d6a70 | 652 | |
8704d4b3 | 653 | X := Position.Node.Element; |
4c2d6a70 | 654 | |
8704d4b3 | 655 | Position.Node.Element := new Element_Type'(New_Item); |
4c2d6a70 | 656 | |
8704d4b3 MH |
657 | Free_Element (X); |
658 | end if; | |
659 | end Include; | |
4c2d6a70 | 660 | |
8704d4b3 MH |
661 | ------------ |
662 | -- Insert -- | |
663 | ------------ | |
4c2d6a70 | 664 | |
8704d4b3 MH |
665 | procedure Insert |
666 | (Container : in out Set; | |
667 | New_Item : Element_Type; | |
668 | Position : out Cursor; | |
669 | Inserted : out Boolean) | |
2368f04e MH |
670 | is |
671 | begin | |
672 | Insert (Container.HT, New_Item, Position.Node, Inserted); | |
673 | Position.Container := Container'Unchecked_Access; | |
674 | end Insert; | |
675 | ||
676 | procedure Insert | |
677 | (Container : in out Set; | |
678 | New_Item : Element_Type) | |
679 | is | |
680 | Position : Cursor; | |
681 | Inserted : Boolean; | |
682 | ||
683 | begin | |
684 | Insert (Container, New_Item, Position, Inserted); | |
685 | ||
686 | if not Inserted then | |
ffabcde5 MH |
687 | raise Constraint_Error with |
688 | "attempt to insert element already in set"; | |
2368f04e MH |
689 | end if; |
690 | end Insert; | |
691 | ||
692 | procedure Insert | |
693 | (HT : in out Hash_Table_Type; | |
694 | New_Item : Element_Type; | |
695 | Node : out Node_Access; | |
696 | Inserted : out Boolean) | |
8704d4b3 MH |
697 | is |
698 | function New_Node (Next : Node_Access) return Node_Access; | |
699 | pragma Inline (New_Node); | |
4c2d6a70 | 700 | |
ba355842 | 701 | procedure Local_Insert is |
8704d4b3 | 702 | new Element_Keys.Generic_Conditional_Insert (New_Node); |
4c2d6a70 | 703 | |
8704d4b3 MH |
704 | -------------- |
705 | -- New_Node -- | |
706 | -------------- | |
4c2d6a70 | 707 | |
8704d4b3 MH |
708 | function New_Node (Next : Node_Access) return Node_Access is |
709 | Element : Element_Access := new Element_Type'(New_Item); | |
4c2d6a70 | 710 | |
8704d4b3 MH |
711 | begin |
712 | return new Node_Type'(Element, Next); | |
713 | exception | |
714 | when others => | |
715 | Free_Element (Element); | |
716 | raise; | |
717 | end New_Node; | |
4c2d6a70 | 718 | |
8704d4b3 | 719 | -- Start of processing for Insert |
4c2d6a70 | 720 | |
8704d4b3 | 721 | begin |
ba355842 MH |
722 | if HT_Ops.Capacity (HT) = 0 then |
723 | HT_Ops.Reserve_Capacity (HT, 1); | |
724 | end if; | |
725 | ||
2368f04e | 726 | Local_Insert (HT, New_Item, Node, Inserted); |
ba355842 MH |
727 | |
728 | if Inserted | |
729 | and then HT.Length > HT_Ops.Capacity (HT) | |
730 | then | |
731 | HT_Ops.Reserve_Capacity (HT, HT.Length); | |
8704d4b3 | 732 | end if; |
8704d4b3 | 733 | end Insert; |
4c2d6a70 | 734 | |
8704d4b3 MH |
735 | ------------------ |
736 | -- Intersection -- | |
737 | ------------------ | |
4c2d6a70 | 738 | |
8704d4b3 MH |
739 | procedure Intersection |
740 | (Target : in out Set; | |
741 | Source : Set) | |
742 | is | |
743 | Tgt_Node : Node_Access; | |
4c2d6a70 AC |
744 | |
745 | begin | |
4c2d6a70 AC |
746 | if Target'Address = Source'Address then |
747 | return; | |
748 | end if; | |
749 | ||
8704d4b3 MH |
750 | if Source.Length = 0 then |
751 | Clear (Target); | |
752 | return; | |
753 | end if; | |
4c2d6a70 | 754 | |
8704d4b3 | 755 | if Target.HT.Busy > 0 then |
ffabcde5 MH |
756 | raise Program_Error with |
757 | "attempt to tamper with elements (set is busy)"; | |
8704d4b3 | 758 | end if; |
4c2d6a70 | 759 | |
8704d4b3 MH |
760 | -- TODO: optimize this to use an explicit |
761 | -- loop instead of an active iterator | |
762 | -- (similar to how a passive iterator is | |
763 | -- implemented). | |
764 | -- | |
765 | -- Another possibility is to test which | |
766 | -- set is smaller, and iterate over the | |
767 | -- smaller set. | |
4c2d6a70 | 768 | |
8704d4b3 MH |
769 | Tgt_Node := HT_Ops.First (Target.HT); |
770 | while Tgt_Node /= null loop | |
771 | if Is_In (Source.HT, Tgt_Node) then | |
772 | Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); | |
4c2d6a70 | 773 | |
8704d4b3 MH |
774 | else |
775 | declare | |
776 | X : Node_Access := Tgt_Node; | |
777 | begin | |
778 | Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); | |
779 | HT_Ops.Delete_Node_Sans_Free (Target.HT, X); | |
780 | Free (X); | |
781 | end; | |
782 | end if; | |
783 | end loop; | |
784 | end Intersection; | |
4c2d6a70 | 785 | |
8704d4b3 | 786 | function Intersection (Left, Right : Set) return Set is |
4c2d6a70 AC |
787 | Buckets : HT_Types.Buckets_Access; |
788 | Length : Count_Type; | |
789 | ||
790 | begin | |
4c2d6a70 AC |
791 | if Left'Address = Right'Address then |
792 | return Left; | |
793 | end if; | |
794 | ||
8704d4b3 | 795 | Length := Count_Type'Min (Left.Length, Right.Length); |
4c2d6a70 | 796 | |
8704d4b3 MH |
797 | if Length = 0 then |
798 | return Empty_Set; | |
4c2d6a70 AC |
799 | end if; |
800 | ||
801 | declare | |
8704d4b3 | 802 | Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); |
4c2d6a70 AC |
803 | begin |
804 | Buckets := new Buckets_Type (0 .. Size - 1); | |
805 | end; | |
806 | ||
8704d4b3 MH |
807 | Length := 0; |
808 | ||
809 | Iterate_Left : declare | |
4c2d6a70 AC |
810 | procedure Process (L_Node : Node_Access); |
811 | ||
8704d4b3 MH |
812 | procedure Iterate is |
813 | new HT_Ops.Generic_Iteration (Process); | |
814 | ||
815 | ------------- | |
816 | -- Process -- | |
817 | ------------- | |
818 | ||
4c2d6a70 | 819 | procedure Process (L_Node : Node_Access) is |
4c2d6a70 | 820 | begin |
8704d4b3 MH |
821 | if Is_In (Right.HT, L_Node) then |
822 | declare | |
2368f04e MH |
823 | Src : Element_Type renames L_Node.Element.all; |
824 | ||
825 | Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; | |
8704d4b3 MH |
826 | |
827 | Bucket : Node_Access renames Buckets (Indx); | |
828 | ||
2368f04e MH |
829 | Tgt : Element_Access := new Element_Type'(Src); |
830 | ||
8704d4b3 | 831 | begin |
2368f04e MH |
832 | Bucket := new Node_Type'(Tgt, Bucket); |
833 | exception | |
834 | when others => | |
835 | Free_Element (Tgt); | |
836 | raise; | |
8704d4b3 MH |
837 | end; |
838 | ||
839 | Length := Length + 1; | |
840 | end if; | |
4c2d6a70 AC |
841 | end Process; |
842 | ||
8704d4b3 MH |
843 | -- Start of processing for Iterate_Left |
844 | ||
4c2d6a70 | 845 | begin |
8704d4b3 | 846 | Iterate (Left.HT); |
4c2d6a70 AC |
847 | exception |
848 | when others => | |
849 | HT_Ops.Free_Hash_Table (Buckets); | |
850 | raise; | |
8704d4b3 | 851 | end Iterate_Left; |
4c2d6a70 | 852 | |
8704d4b3 MH |
853 | return (Controlled with HT => (Buckets, Length, 0, 0)); |
854 | end Intersection; | |
4c2d6a70 | 855 | |
8704d4b3 MH |
856 | -------------- |
857 | -- Is_Empty -- | |
858 | -------------- | |
4c2d6a70 | 859 | |
8704d4b3 MH |
860 | function Is_Empty (Container : Set) return Boolean is |
861 | begin | |
ba355842 | 862 | return Container.HT.Length = 0; |
8704d4b3 | 863 | end Is_Empty; |
4c2d6a70 | 864 | |
8704d4b3 MH |
865 | ----------- |
866 | -- Is_In -- | |
867 | ----------- | |
4c2d6a70 | 868 | |
8704d4b3 MH |
869 | function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is |
870 | begin | |
871 | return Element_Keys.Find (HT, Key.Element.all) /= null; | |
872 | end Is_In; | |
4c2d6a70 | 873 | |
8704d4b3 MH |
874 | --------------- |
875 | -- Is_Subset -- | |
876 | --------------- | |
4c2d6a70 | 877 | |
8704d4b3 MH |
878 | function Is_Subset |
879 | (Subset : Set; | |
880 | Of_Set : Set) return Boolean | |
881 | is | |
882 | Subset_Node : Node_Access; | |
4c2d6a70 | 883 | |
8704d4b3 MH |
884 | begin |
885 | if Subset'Address = Of_Set'Address then | |
886 | return True; | |
887 | end if; | |
4c2d6a70 | 888 | |
8704d4b3 MH |
889 | if Subset.Length > Of_Set.Length then |
890 | return False; | |
891 | end if; | |
4c2d6a70 | 892 | |
8704d4b3 MH |
893 | -- TODO: rewrite this to loop in the |
894 | -- style of a passive iterator. | |
4c2d6a70 | 895 | |
8704d4b3 MH |
896 | Subset_Node := HT_Ops.First (Subset.HT); |
897 | while Subset_Node /= null loop | |
898 | if not Is_In (Of_Set.HT, Subset_Node) then | |
899 | return False; | |
900 | end if; | |
4c2d6a70 | 901 | |
8704d4b3 MH |
902 | Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node); |
903 | end loop; | |
4c2d6a70 | 904 | |
8704d4b3 MH |
905 | return True; |
906 | end Is_Subset; | |
4c2d6a70 | 907 | |
8704d4b3 MH |
908 | ------------- |
909 | -- Iterate -- | |
910 | ------------- | |
4c2d6a70 | 911 | |
8704d4b3 MH |
912 | procedure Iterate |
913 | (Container : Set; | |
914 | Process : not null access procedure (Position : Cursor)) | |
915 | is | |
916 | procedure Process_Node (Node : Node_Access); | |
917 | pragma Inline (Process_Node); | |
4c2d6a70 | 918 | |
8704d4b3 MH |
919 | procedure Iterate is |
920 | new HT_Ops.Generic_Iteration (Process_Node); | |
4c2d6a70 | 921 | |
8704d4b3 MH |
922 | ------------------ |
923 | -- Process_Node -- | |
924 | ------------------ | |
4c2d6a70 | 925 | |
8704d4b3 MH |
926 | procedure Process_Node (Node : Node_Access) is |
927 | begin | |
928 | Process (Cursor'(Container'Unrestricted_Access, Node)); | |
929 | end Process_Node; | |
4c2d6a70 | 930 | |
8704d4b3 | 931 | HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; |
8704d4b3 MH |
932 | |
933 | -- Start of processing for Iterate | |
4c2d6a70 | 934 | |
4c2d6a70 | 935 | begin |
ba355842 MH |
936 | -- TODO: resolve whether HT_Ops.Generic_Iteration should |
937 | -- manipulate busy bit. | |
4c2d6a70 | 938 | |
ba355842 | 939 | Iterate (HT); |
8704d4b3 | 940 | end Iterate; |
4c2d6a70 | 941 | |
8704d4b3 MH |
942 | ------------ |
943 | -- Length -- | |
944 | ------------ | |
4c2d6a70 | 945 | |
8704d4b3 | 946 | function Length (Container : Set) return Count_Type is |
4c2d6a70 | 947 | begin |
8704d4b3 MH |
948 | return Container.HT.Length; |
949 | end Length; | |
4c2d6a70 | 950 | |
8704d4b3 MH |
951 | ---------- |
952 | -- Move -- | |
953 | ---------- | |
4c2d6a70 | 954 | |
8704d4b3 MH |
955 | procedure Move (Target : in out Set; Source : in out Set) is |
956 | begin | |
957 | HT_Ops.Move (Target => Target.HT, Source => Source.HT); | |
958 | end Move; | |
4c2d6a70 | 959 | |
8704d4b3 MH |
960 | ---------- |
961 | -- Next -- | |
962 | ---------- | |
4c2d6a70 | 963 | |
8704d4b3 MH |
964 | function Next (Node : Node_Access) return Node_Access is |
965 | begin | |
966 | return Node.Next; | |
967 | end Next; | |
4c2d6a70 | 968 | |
8704d4b3 MH |
969 | function Next (Position : Cursor) return Cursor is |
970 | begin | |
971 | if Position.Node = null then | |
8704d4b3 MH |
972 | return No_Element; |
973 | end if; | |
4c2d6a70 | 974 | |
ba355842 | 975 | if Position.Node.Element = null then |
ffabcde5 | 976 | raise Program_Error with "bad cursor in Next"; |
ba355842 MH |
977 | end if; |
978 | ||
ffabcde5 MH |
979 | pragma Assert (Vet (Position), "bad cursor in Next"); |
980 | ||
8704d4b3 MH |
981 | declare |
982 | HT : Hash_Table_Type renames Position.Container.HT; | |
983 | Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); | |
4c2d6a70 | 984 | |
8704d4b3 MH |
985 | begin |
986 | if Node = null then | |
987 | return No_Element; | |
4c2d6a70 AC |
988 | end if; |
989 | ||
8704d4b3 MH |
990 | return Cursor'(Position.Container, Node); |
991 | end; | |
992 | end Next; | |
4c2d6a70 | 993 | |
8704d4b3 MH |
994 | procedure Next (Position : in out Cursor) is |
995 | begin | |
996 | Position := Next (Position); | |
997 | end Next; | |
4c2d6a70 | 998 | |
8704d4b3 MH |
999 | ------------- |
1000 | -- Overlap -- | |
1001 | ------------- | |
4c2d6a70 | 1002 | |
8704d4b3 MH |
1003 | function Overlap (Left, Right : Set) return Boolean is |
1004 | Left_Node : Node_Access; | |
4c2d6a70 AC |
1005 | |
1006 | begin | |
8704d4b3 MH |
1007 | if Right.Length = 0 then |
1008 | return False; | |
1009 | end if; | |
4c2d6a70 AC |
1010 | |
1011 | if Left'Address = Right'Address then | |
8704d4b3 | 1012 | return True; |
4c2d6a70 AC |
1013 | end if; |
1014 | ||
8704d4b3 MH |
1015 | Left_Node := HT_Ops.First (Left.HT); |
1016 | while Left_Node /= null loop | |
1017 | if Is_In (Right.HT, Left_Node) then | |
1018 | return True; | |
1019 | end if; | |
4c2d6a70 | 1020 | |
8704d4b3 MH |
1021 | Left_Node := HT_Ops.Next (Left.HT, Left_Node); |
1022 | end loop; | |
4c2d6a70 | 1023 | |
8704d4b3 MH |
1024 | return False; |
1025 | end Overlap; | |
4c2d6a70 | 1026 | |
8704d4b3 MH |
1027 | ------------------- |
1028 | -- Query_Element -- | |
1029 | ------------------- | |
4c2d6a70 | 1030 | |
8704d4b3 MH |
1031 | procedure Query_Element |
1032 | (Position : Cursor; | |
1033 | Process : not null access procedure (Element : Element_Type)) | |
1034 | is | |
ba355842 | 1035 | begin |
ba355842 | 1036 | if Position.Node = null then |
ffabcde5 MH |
1037 | raise Constraint_Error with |
1038 | "Position cursor of Query_Element equals No_Element"; | |
ba355842 | 1039 | end if; |
4c2d6a70 | 1040 | |
ba355842 | 1041 | if Position.Node.Element = null then |
ffabcde5 | 1042 | raise Program_Error with "bad cursor in Query_Element"; |
ba355842 | 1043 | end if; |
4c2d6a70 | 1044 | |
ffabcde5 MH |
1045 | pragma Assert (Vet (Position), "bad cursor in Query_Element"); |
1046 | ||
ba355842 MH |
1047 | declare |
1048 | HT : Hash_Table_Type renames | |
1049 | Position.Container'Unrestricted_Access.all.HT; | |
1050 | ||
1051 | B : Natural renames HT.Busy; | |
1052 | L : Natural renames HT.Lock; | |
4c2d6a70 | 1053 | |
4c2d6a70 | 1054 | begin |
ba355842 MH |
1055 | B := B + 1; |
1056 | L := L + 1; | |
4c2d6a70 | 1057 | |
ba355842 MH |
1058 | begin |
1059 | Process (Position.Node.Element.all); | |
1060 | exception | |
1061 | when others => | |
1062 | L := L - 1; | |
1063 | B := B - 1; | |
1064 | raise; | |
1065 | end; | |
1066 | ||
1067 | L := L - 1; | |
1068 | B := B - 1; | |
1069 | end; | |
8704d4b3 | 1070 | end Query_Element; |
4c2d6a70 | 1071 | |
8704d4b3 MH |
1072 | ---------- |
1073 | -- Read -- | |
1074 | ---------- | |
4c2d6a70 | 1075 | |
8704d4b3 MH |
1076 | procedure Read |
1077 | (Stream : access Root_Stream_Type'Class; | |
1078 | Container : out Set) | |
1079 | is | |
1080 | begin | |
1081 | Read_Nodes (Stream, Container.HT); | |
1082 | end Read; | |
4c2d6a70 | 1083 | |
2368f04e MH |
1084 | procedure Read |
1085 | (Stream : access Root_Stream_Type'Class; | |
1086 | Item : out Cursor) | |
1087 | is | |
1088 | begin | |
ffabcde5 | 1089 | raise Program_Error with "attempt to stream set cursor"; |
2368f04e MH |
1090 | end Read; |
1091 | ||
8704d4b3 MH |
1092 | --------------- |
1093 | -- Read_Node -- | |
1094 | --------------- | |
4c2d6a70 | 1095 | |
8704d4b3 MH |
1096 | function Read_Node |
1097 | (Stream : access Root_Stream_Type'Class) return Node_Access | |
1098 | is | |
1099 | X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); | |
4c2d6a70 AC |
1100 | |
1101 | begin | |
8704d4b3 MH |
1102 | return new Node_Type'(X, null); |
1103 | exception | |
1104 | when others => | |
1105 | Free_Element (X); | |
1106 | raise; | |
1107 | end Read_Node; | |
4c2d6a70 | 1108 | |
8704d4b3 MH |
1109 | ------------- |
1110 | -- Replace -- | |
1111 | ------------- | |
4c2d6a70 | 1112 | |
8704d4b3 MH |
1113 | procedure Replace |
1114 | (Container : in out Set; | |
1115 | New_Item : Element_Type) | |
1116 | is | |
1117 | Node : constant Node_Access := | |
1118 | Element_Keys.Find (Container.HT, New_Item); | |
4c2d6a70 | 1119 | |
8704d4b3 | 1120 | X : Element_Access; |
4c2d6a70 | 1121 | |
8704d4b3 MH |
1122 | begin |
1123 | if Node = null then | |
ffabcde5 MH |
1124 | raise Constraint_Error with |
1125 | "attempt to replace element not in set"; | |
8704d4b3 | 1126 | end if; |
4c2d6a70 | 1127 | |
8704d4b3 | 1128 | if Container.HT.Lock > 0 then |
ffabcde5 MH |
1129 | raise Program_Error with |
1130 | "attempt to tamper with cursors (set is locked)"; | |
8704d4b3 | 1131 | end if; |
4c2d6a70 | 1132 | |
8704d4b3 | 1133 | X := Node.Element; |
4c2d6a70 | 1134 | |
8704d4b3 | 1135 | Node.Element := new Element_Type'(New_Item); |
4c2d6a70 | 1136 | |
8704d4b3 MH |
1137 | Free_Element (X); |
1138 | end Replace; | |
4c2d6a70 | 1139 | |
8704d4b3 MH |
1140 | --------------------- |
1141 | -- Replace_Element -- | |
1142 | --------------------- | |
1143 | ||
1144 | procedure Replace_Element | |
ba355842 MH |
1145 | (HT : in out Hash_Table_Type; |
1146 | Node : Node_Access; | |
1147 | New_Item : Element_Type) | |
8704d4b3 MH |
1148 | is |
1149 | begin | |
ba355842 MH |
1150 | if Equivalent_Elements (Node.Element.all, New_Item) then |
1151 | pragma Assert (Hash (Node.Element.all) = Hash (New_Item)); | |
4c2d6a70 | 1152 | |
8704d4b3 | 1153 | if HT.Lock > 0 then |
ffabcde5 MH |
1154 | raise Program_Error with |
1155 | "attempt to tamper with cursors (set is locked)"; | |
4c2d6a70 AC |
1156 | end if; |
1157 | ||
8704d4b3 MH |
1158 | declare |
1159 | X : Element_Access := Node.Element; | |
1160 | begin | |
ba355842 | 1161 | Node.Element := new Element_Type'(New_Item); -- OK if fails |
8704d4b3 MH |
1162 | Free_Element (X); |
1163 | end; | |
4c2d6a70 | 1164 | |
8704d4b3 MH |
1165 | return; |
1166 | end if; | |
4c2d6a70 | 1167 | |
8704d4b3 | 1168 | if HT.Busy > 0 then |
ffabcde5 MH |
1169 | raise Program_Error with |
1170 | "attempt to tamper with elements (set is busy)"; | |
8704d4b3 | 1171 | end if; |
4c2d6a70 | 1172 | |
8704d4b3 | 1173 | HT_Ops.Delete_Node_Sans_Free (HT, Node); |
4c2d6a70 | 1174 | |
8704d4b3 MH |
1175 | Insert_New_Element : declare |
1176 | function New_Node (Next : Node_Access) return Node_Access; | |
1177 | pragma Inline (New_Node); | |
4c2d6a70 | 1178 | |
8704d4b3 MH |
1179 | procedure Insert is |
1180 | new Element_Keys.Generic_Conditional_Insert (New_Node); | |
4c2d6a70 | 1181 | |
8704d4b3 MH |
1182 | ------------------------ |
1183 | -- Insert_New_Element -- | |
1184 | ------------------------ | |
4c2d6a70 | 1185 | |
8704d4b3 MH |
1186 | function New_Node (Next : Node_Access) return Node_Access is |
1187 | begin | |
ba355842 | 1188 | Node.Element := new Element_Type'(New_Item); -- OK if fails |
8704d4b3 MH |
1189 | Node.Next := Next; |
1190 | return Node; | |
1191 | end New_Node; | |
4c2d6a70 | 1192 | |
8704d4b3 MH |
1193 | Result : Node_Access; |
1194 | Inserted : Boolean; | |
4c2d6a70 | 1195 | |
8704d4b3 MH |
1196 | X : Element_Access := Node.Element; |
1197 | ||
1198 | -- Start of processing for Insert_New_Element | |
4c2d6a70 | 1199 | |
4c2d6a70 | 1200 | begin |
8704d4b3 MH |
1201 | Attempt_Insert : begin |
1202 | Insert | |
1203 | (HT => HT, | |
ba355842 | 1204 | Key => New_Item, |
8704d4b3 MH |
1205 | Node => Result, |
1206 | Inserted => Inserted); | |
1207 | exception | |
1208 | when others => | |
1209 | Inserted := False; -- Assignment failed | |
1210 | end Attempt_Insert; | |
4c2d6a70 | 1211 | |
8704d4b3 | 1212 | if Inserted then |
8704d4b3 MH |
1213 | Free_Element (X); -- Just propagate if fails |
1214 | return; | |
1215 | end if; | |
1216 | end Insert_New_Element; | |
4c2d6a70 | 1217 | |
8704d4b3 | 1218 | Reinsert_Old_Element : |
4c2d6a70 | 1219 | declare |
8704d4b3 MH |
1220 | function New_Node (Next : Node_Access) return Node_Access; |
1221 | pragma Inline (New_Node); | |
4c2d6a70 | 1222 | |
8704d4b3 MH |
1223 | procedure Insert is |
1224 | new Element_Keys.Generic_Conditional_Insert (New_Node); | |
4c2d6a70 | 1225 | |
8704d4b3 MH |
1226 | -------------- |
1227 | -- New_Node -- | |
1228 | -------------- | |
4c2d6a70 | 1229 | |
8704d4b3 MH |
1230 | function New_Node (Next : Node_Access) return Node_Access is |
1231 | begin | |
1232 | Node.Next := Next; | |
1233 | return Node; | |
1234 | end New_Node; | |
4c2d6a70 | 1235 | |
8704d4b3 MH |
1236 | Result : Node_Access; |
1237 | Inserted : Boolean; | |
1238 | ||
1239 | -- Start of processing for Reinsert_Old_Element | |
4c2d6a70 | 1240 | |
4c2d6a70 | 1241 | begin |
8704d4b3 MH |
1242 | Insert |
1243 | (HT => HT, | |
1244 | Key => Node.Element.all, | |
1245 | Node => Result, | |
1246 | Inserted => Inserted); | |
4c2d6a70 AC |
1247 | exception |
1248 | when others => | |
8704d4b3 MH |
1249 | null; |
1250 | end Reinsert_Old_Element; | |
4c2d6a70 | 1251 | |
ffabcde5 | 1252 | raise Program_Error with "attempt to replace existing element"; |
8704d4b3 | 1253 | end Replace_Element; |
4c2d6a70 | 1254 | |
8704d4b3 | 1255 | procedure Replace_Element |
ba355842 | 1256 | (Container : in out Set; |
8704d4b3 | 1257 | Position : Cursor; |
ba355842 | 1258 | New_Item : Element_Type) |
8704d4b3 | 1259 | is |
8704d4b3 MH |
1260 | begin |
1261 | if Position.Node = null then | |
ffabcde5 | 1262 | raise Constraint_Error with "Position cursor equals No_Element"; |
8704d4b3 | 1263 | end if; |
4c2d6a70 | 1264 | |
ba355842 | 1265 | if Position.Node.Element = null then |
ffabcde5 | 1266 | raise Program_Error with "bad cursor in Replace_Element"; |
ba355842 MH |
1267 | end if; |
1268 | ||
1269 | if Position.Container /= Container'Unrestricted_Access then | |
ffabcde5 MH |
1270 | raise Program_Error with |
1271 | "Position cursor designates wrong set"; | |
8704d4b3 MH |
1272 | end if; |
1273 | ||
ffabcde5 MH |
1274 | pragma Assert (Vet (Position), "bad cursor in Replace_Element"); |
1275 | ||
ba355842 | 1276 | Replace_Element (Container.HT, Position.Node, New_Item); |
8704d4b3 MH |
1277 | end Replace_Element; |
1278 | ||
1279 | ---------------------- | |
1280 | -- Reserve_Capacity -- | |
1281 | ---------------------- | |
1282 | ||
1283 | procedure Reserve_Capacity | |
1284 | (Container : in out Set; | |
1285 | Capacity : Count_Type) | |
1286 | is | |
1287 | begin | |
1288 | HT_Ops.Reserve_Capacity (Container.HT, Capacity); | |
1289 | end Reserve_Capacity; | |
4c2d6a70 | 1290 | |
8704d4b3 MH |
1291 | -------------- |
1292 | -- Set_Next -- | |
1293 | -------------- | |
4c2d6a70 | 1294 | |
8704d4b3 | 1295 | procedure Set_Next (Node : Node_Access; Next : Node_Access) is |
4c2d6a70 | 1296 | begin |
8704d4b3 MH |
1297 | Node.Next := Next; |
1298 | end Set_Next; | |
4c2d6a70 | 1299 | |
8704d4b3 MH |
1300 | -------------------------- |
1301 | -- Symmetric_Difference -- | |
1302 | -------------------------- | |
1303 | ||
1304 | procedure Symmetric_Difference | |
1305 | (Target : in out Set; | |
1306 | Source : Set) | |
1307 | is | |
1308 | begin | |
4c2d6a70 AC |
1309 | if Target'Address = Source'Address then |
1310 | Clear (Target); | |
1311 | return; | |
1312 | end if; | |
1313 | ||
8704d4b3 | 1314 | if Target.HT.Busy > 0 then |
ffabcde5 MH |
1315 | raise Program_Error with |
1316 | "attempt to tamper with elements (set is busy)"; | |
8704d4b3 | 1317 | end if; |
4c2d6a70 | 1318 | |
8704d4b3 MH |
1319 | declare |
1320 | N : constant Count_Type := Target.Length + Source.Length; | |
1321 | begin | |
1322 | if N > HT_Ops.Capacity (Target.HT) then | |
1323 | HT_Ops.Reserve_Capacity (Target.HT, N); | |
1324 | end if; | |
1325 | end; | |
4c2d6a70 | 1326 | |
8704d4b3 MH |
1327 | if Target.Length = 0 then |
1328 | Iterate_Source_When_Empty_Target : declare | |
4c2d6a70 AC |
1329 | procedure Process (Src_Node : Node_Access); |
1330 | ||
8704d4b3 MH |
1331 | procedure Iterate is |
1332 | new HT_Ops.Generic_Iteration (Process); | |
1333 | ||
1334 | ------------- | |
1335 | -- Process -- | |
1336 | ------------- | |
1337 | ||
4c2d6a70 AC |
1338 | procedure Process (Src_Node : Node_Access) is |
1339 | E : Element_Type renames Src_Node.Element.all; | |
8704d4b3 MH |
1340 | B : Buckets_Type renames Target.HT.Buckets.all; |
1341 | J : constant Hash_Type := Hash (E) mod B'Length; | |
1342 | N : Count_Type renames Target.HT.Length; | |
1343 | ||
4c2d6a70 AC |
1344 | begin |
1345 | declare | |
1346 | X : Element_Access := new Element_Type'(E); | |
1347 | begin | |
8704d4b3 | 1348 | B (J) := new Node_Type'(X, B (J)); |
4c2d6a70 AC |
1349 | exception |
1350 | when others => | |
1351 | Free_Element (X); | |
1352 | raise; | |
1353 | end; | |
1354 | ||
1355 | N := N + 1; | |
1356 | end Process; | |
1357 | ||
8704d4b3 MH |
1358 | -- Start of processing for Iterate_Source_When_Empty_Target |
1359 | ||
4c2d6a70 | 1360 | begin |
8704d4b3 MH |
1361 | Iterate (Source.HT); |
1362 | end Iterate_Source_When_Empty_Target; | |
4c2d6a70 AC |
1363 | |
1364 | else | |
8704d4b3 | 1365 | Iterate_Source : declare |
4c2d6a70 AC |
1366 | procedure Process (Src_Node : Node_Access); |
1367 | ||
8704d4b3 MH |
1368 | procedure Iterate is |
1369 | new HT_Ops.Generic_Iteration (Process); | |
1370 | ||
1371 | ------------- | |
1372 | -- Process -- | |
1373 | ------------- | |
1374 | ||
4c2d6a70 AC |
1375 | procedure Process (Src_Node : Node_Access) is |
1376 | E : Element_Type renames Src_Node.Element.all; | |
8704d4b3 MH |
1377 | B : Buckets_Type renames Target.HT.Buckets.all; |
1378 | J : constant Hash_Type := Hash (E) mod B'Length; | |
1379 | N : Count_Type renames Target.HT.Length; | |
4c2d6a70 | 1380 | |
8704d4b3 MH |
1381 | begin |
1382 | if B (J) = null then | |
4c2d6a70 AC |
1383 | declare |
1384 | X : Element_Access := new Element_Type'(E); | |
1385 | begin | |
8704d4b3 | 1386 | B (J) := new Node_Type'(X, null); |
4c2d6a70 AC |
1387 | exception |
1388 | when others => | |
1389 | Free_Element (X); | |
1390 | raise; | |
1391 | end; | |
1392 | ||
1393 | N := N + 1; | |
1394 | ||
8704d4b3 | 1395 | elsif Equivalent_Elements (E, B (J).Element.all) then |
4c2d6a70 | 1396 | declare |
8704d4b3 | 1397 | X : Node_Access := B (J); |
4c2d6a70 | 1398 | begin |
8704d4b3 | 1399 | B (J) := B (J).Next; |
4c2d6a70 AC |
1400 | N := N - 1; |
1401 | Free (X); | |
1402 | end; | |
1403 | ||
1404 | else | |
4c2d6a70 | 1405 | declare |
8704d4b3 | 1406 | Prev : Node_Access := B (J); |
4c2d6a70 | 1407 | Curr : Node_Access := Prev.Next; |
8704d4b3 | 1408 | |
4c2d6a70 AC |
1409 | begin |
1410 | while Curr /= null loop | |
8704d4b3 | 1411 | if Equivalent_Elements (E, Curr.Element.all) then |
4c2d6a70 AC |
1412 | Prev.Next := Curr.Next; |
1413 | N := N - 1; | |
1414 | Free (Curr); | |
1415 | return; | |
1416 | end if; | |
1417 | ||
1418 | Prev := Curr; | |
1419 | Curr := Prev.Next; | |
1420 | end loop; | |
1421 | ||
1422 | declare | |
1423 | X : Element_Access := new Element_Type'(E); | |
1424 | begin | |
8704d4b3 | 1425 | B (J) := new Node_Type'(X, B (J)); |
4c2d6a70 AC |
1426 | exception |
1427 | when others => | |
1428 | Free_Element (X); | |
1429 | raise; | |
1430 | end; | |
1431 | ||
1432 | N := N + 1; | |
1433 | end; | |
4c2d6a70 AC |
1434 | end if; |
1435 | end Process; | |
1436 | ||
8704d4b3 | 1437 | -- Start of processing for Iterate_Source |
4c2d6a70 | 1438 | |
8704d4b3 MH |
1439 | begin |
1440 | Iterate (Source.HT); | |
1441 | end Iterate_Source; | |
4c2d6a70 | 1442 | end if; |
4c2d6a70 AC |
1443 | end Symmetric_Difference; |
1444 | ||
4c2d6a70 | 1445 | function Symmetric_Difference (Left, Right : Set) return Set is |
4c2d6a70 AC |
1446 | Buckets : HT_Types.Buckets_Access; |
1447 | Length : Count_Type; | |
1448 | ||
1449 | begin | |
4c2d6a70 AC |
1450 | if Left'Address = Right'Address then |
1451 | return Empty_Set; | |
1452 | end if; | |
1453 | ||
1454 | if Right.Length = 0 then | |
1455 | return Left; | |
1456 | end if; | |
1457 | ||
1458 | if Left.Length = 0 then | |
1459 | return Right; | |
1460 | end if; | |
1461 | ||
1462 | declare | |
1463 | Size : constant Hash_Type := | |
8704d4b3 | 1464 | Prime_Numbers.To_Prime (Left.Length + Right.Length); |
4c2d6a70 AC |
1465 | begin |
1466 | Buckets := new Buckets_Type (0 .. Size - 1); | |
1467 | end; | |
1468 | ||
1469 | Length := 0; | |
1470 | ||
8704d4b3 | 1471 | Iterate_Left : declare |
4c2d6a70 AC |
1472 | procedure Process (L_Node : Node_Access); |
1473 | ||
8704d4b3 MH |
1474 | procedure Iterate is |
1475 | new HT_Ops.Generic_Iteration (Process); | |
1476 | ||
1477 | ------------- | |
1478 | -- Process -- | |
1479 | ------------- | |
1480 | ||
4c2d6a70 AC |
1481 | procedure Process (L_Node : Node_Access) is |
1482 | begin | |
8704d4b3 | 1483 | if not Is_In (Right.HT, L_Node) then |
4c2d6a70 AC |
1484 | declare |
1485 | E : Element_Type renames L_Node.Element.all; | |
8704d4b3 | 1486 | J : constant Hash_Type := Hash (E) mod Buckets'Length; |
4c2d6a70 | 1487 | |
8704d4b3 | 1488 | begin |
4c2d6a70 AC |
1489 | declare |
1490 | X : Element_Access := new Element_Type'(E); | |
1491 | begin | |
8704d4b3 | 1492 | Buckets (J) := new Node_Type'(X, Buckets (J)); |
4c2d6a70 AC |
1493 | exception |
1494 | when others => | |
1495 | Free_Element (X); | |
1496 | raise; | |
1497 | end; | |
1498 | ||
1499 | Length := Length + 1; | |
1500 | end; | |
1501 | end if; | |
1502 | end Process; | |
1503 | ||
8704d4b3 MH |
1504 | -- Start of processing for Iterate_Left |
1505 | ||
4c2d6a70 | 1506 | begin |
8704d4b3 | 1507 | Iterate (Left.HT); |
4c2d6a70 AC |
1508 | exception |
1509 | when others => | |
1510 | HT_Ops.Free_Hash_Table (Buckets); | |
1511 | raise; | |
8704d4b3 | 1512 | end Iterate_Left; |
4c2d6a70 | 1513 | |
8704d4b3 | 1514 | Iterate_Right : declare |
4c2d6a70 AC |
1515 | procedure Process (R_Node : Node_Access); |
1516 | ||
8704d4b3 MH |
1517 | procedure Iterate is |
1518 | new HT_Ops.Generic_Iteration (Process); | |
1519 | ||
1520 | ------------- | |
1521 | -- Process -- | |
1522 | ------------- | |
1523 | ||
4c2d6a70 AC |
1524 | procedure Process (R_Node : Node_Access) is |
1525 | begin | |
8704d4b3 | 1526 | if not Is_In (Left.HT, R_Node) then |
4c2d6a70 AC |
1527 | declare |
1528 | E : Element_Type renames R_Node.Element.all; | |
8704d4b3 | 1529 | J : constant Hash_Type := Hash (E) mod Buckets'Length; |
4c2d6a70 | 1530 | |
8704d4b3 | 1531 | begin |
4c2d6a70 AC |
1532 | declare |
1533 | X : Element_Access := new Element_Type'(E); | |
1534 | begin | |
8704d4b3 | 1535 | Buckets (J) := new Node_Type'(X, Buckets (J)); |
4c2d6a70 AC |
1536 | exception |
1537 | when others => | |
1538 | Free_Element (X); | |
1539 | raise; | |
1540 | end; | |
1541 | ||
1542 | Length := Length + 1; | |
4c2d6a70 AC |
1543 | end; |
1544 | end if; | |
1545 | end Process; | |
1546 | ||
8704d4b3 MH |
1547 | -- Start of processing for Iterate_Right |
1548 | ||
4c2d6a70 | 1549 | begin |
8704d4b3 | 1550 | Iterate (Right.HT); |
4c2d6a70 AC |
1551 | exception |
1552 | when others => | |
1553 | HT_Ops.Free_Hash_Table (Buckets); | |
1554 | raise; | |
8704d4b3 | 1555 | end Iterate_Right; |
4c2d6a70 | 1556 | |
8704d4b3 | 1557 | return (Controlled with HT => (Buckets, Length, 0, 0)); |
4c2d6a70 AC |
1558 | end Symmetric_Difference; |
1559 | ||
2368f04e MH |
1560 | ------------ |
1561 | -- To_Set -- | |
1562 | ------------ | |
1563 | ||
1564 | function To_Set (New_Item : Element_Type) return Set is | |
1565 | HT : Hash_Table_Type; | |
1566 | Node : Node_Access; | |
1567 | Inserted : Boolean; | |
1568 | ||
1569 | begin | |
1570 | Insert (HT, New_Item, Node, Inserted); | |
1571 | return Set'(Controlled with HT); | |
1572 | end To_Set; | |
1573 | ||
8704d4b3 MH |
1574 | ----------- |
1575 | -- Union -- | |
1576 | ----------- | |
4c2d6a70 | 1577 | |
8704d4b3 MH |
1578 | procedure Union |
1579 | (Target : in out Set; | |
1580 | Source : Set) | |
1581 | is | |
1582 | procedure Process (Src_Node : Node_Access); | |
4c2d6a70 | 1583 | |
8704d4b3 MH |
1584 | procedure Iterate is |
1585 | new HT_Ops.Generic_Iteration (Process); | |
4c2d6a70 | 1586 | |
8704d4b3 MH |
1587 | ------------- |
1588 | -- Process -- | |
1589 | ------------- | |
4c2d6a70 | 1590 | |
8704d4b3 MH |
1591 | procedure Process (Src_Node : Node_Access) is |
1592 | Src : Element_Type renames Src_Node.Element.all; | |
4c2d6a70 | 1593 | |
8704d4b3 MH |
1594 | function New_Node (Next : Node_Access) return Node_Access; |
1595 | pragma Inline (New_Node); | |
4c2d6a70 | 1596 | |
8704d4b3 MH |
1597 | procedure Insert is |
1598 | new Element_Keys.Generic_Conditional_Insert (New_Node); | |
4c2d6a70 | 1599 | |
8704d4b3 MH |
1600 | -------------- |
1601 | -- New_Node -- | |
1602 | -------------- | |
4c2d6a70 | 1603 | |
8704d4b3 MH |
1604 | function New_Node (Next : Node_Access) return Node_Access is |
1605 | Tgt : Element_Access := new Element_Type'(Src); | |
4c2d6a70 | 1606 | |
8704d4b3 MH |
1607 | begin |
1608 | return new Node_Type'(Tgt, Next); | |
1609 | exception | |
1610 | when others => | |
1611 | Free_Element (Tgt); | |
1612 | raise; | |
1613 | end New_Node; | |
4c2d6a70 | 1614 | |
8704d4b3 MH |
1615 | Tgt_Node : Node_Access; |
1616 | Success : Boolean; | |
4c2d6a70 | 1617 | |
8704d4b3 | 1618 | -- Start of processing for Process |
4c2d6a70 | 1619 | |
8704d4b3 MH |
1620 | begin |
1621 | Insert (Target.HT, Src, Tgt_Node, Success); | |
1622 | end Process; | |
4c2d6a70 | 1623 | |
8704d4b3 | 1624 | -- Start of processing for Union |
4c2d6a70 | 1625 | |
4c2d6a70 | 1626 | begin |
8704d4b3 MH |
1627 | if Target'Address = Source'Address then |
1628 | return; | |
1629 | end if; | |
1630 | ||
1631 | if Target.HT.Busy > 0 then | |
ffabcde5 MH |
1632 | raise Program_Error with |
1633 | "attempt to tamper with elements (set is busy)"; | |
4c2d6a70 AC |
1634 | end if; |
1635 | ||
1636 | declare | |
8704d4b3 | 1637 | N : constant Count_Type := Target.Length + Source.Length; |
4c2d6a70 | 1638 | begin |
8704d4b3 MH |
1639 | if N > HT_Ops.Capacity (Target.HT) then |
1640 | HT_Ops.Reserve_Capacity (Target.HT, N); | |
4c2d6a70 | 1641 | end if; |
4c2d6a70 | 1642 | end; |
4c2d6a70 | 1643 | |
8704d4b3 MH |
1644 | Iterate (Source.HT); |
1645 | end Union; | |
4c2d6a70 | 1646 | |
8704d4b3 MH |
1647 | function Union (Left, Right : Set) return Set is |
1648 | Buckets : HT_Types.Buckets_Access; | |
1649 | Length : Count_Type; | |
4c2d6a70 | 1650 | |
4c2d6a70 | 1651 | begin |
8704d4b3 MH |
1652 | if Left'Address = Right'Address then |
1653 | return Left; | |
4c2d6a70 AC |
1654 | end if; |
1655 | ||
8704d4b3 MH |
1656 | if Right.Length = 0 then |
1657 | return Left; | |
4c2d6a70 AC |
1658 | end if; |
1659 | ||
8704d4b3 MH |
1660 | if Left.Length = 0 then |
1661 | return Right; | |
1662 | end if; | |
4c2d6a70 | 1663 | |
8704d4b3 MH |
1664 | declare |
1665 | Size : constant Hash_Type := | |
1666 | Prime_Numbers.To_Prime (Left.Length + Right.Length); | |
1667 | begin | |
1668 | Buckets := new Buckets_Type (0 .. Size - 1); | |
1669 | end; | |
4c2d6a70 | 1670 | |
8704d4b3 MH |
1671 | Iterate_Left : declare |
1672 | procedure Process (L_Node : Node_Access); | |
4c2d6a70 | 1673 | |
8704d4b3 MH |
1674 | procedure Iterate is |
1675 | new HT_Ops.Generic_Iteration (Process); | |
4c2d6a70 | 1676 | |
8704d4b3 MH |
1677 | ------------- |
1678 | -- Process -- | |
1679 | ------------- | |
4c2d6a70 | 1680 | |
8704d4b3 | 1681 | procedure Process (L_Node : Node_Access) is |
2368f04e MH |
1682 | Src : Element_Type renames L_Node.Element.all; |
1683 | ||
1684 | J : constant Hash_Type := Hash (Src) mod Buckets'Length; | |
4c2d6a70 | 1685 | |
8704d4b3 | 1686 | Bucket : Node_Access renames Buckets (J); |
4c2d6a70 | 1687 | |
2368f04e MH |
1688 | Tgt : Element_Access := new Element_Type'(Src); |
1689 | ||
8704d4b3 | 1690 | begin |
2368f04e MH |
1691 | Bucket := new Node_Type'(Tgt, Bucket); |
1692 | exception | |
1693 | when others => | |
1694 | Free_Element (Tgt); | |
1695 | raise; | |
8704d4b3 | 1696 | end Process; |
4c2d6a70 | 1697 | |
8704d4b3 | 1698 | -- Start of processing for Process |
4c2d6a70 | 1699 | |
4c2d6a70 | 1700 | begin |
8704d4b3 MH |
1701 | Iterate (Left.HT); |
1702 | exception | |
1703 | when others => | |
1704 | HT_Ops.Free_Hash_Table (Buckets); | |
1705 | raise; | |
1706 | end Iterate_Left; | |
4c2d6a70 | 1707 | |
8704d4b3 | 1708 | Length := Left.Length; |
4c2d6a70 | 1709 | |
8704d4b3 MH |
1710 | Iterate_Right : declare |
1711 | procedure Process (Src_Node : Node_Access); | |
4c2d6a70 | 1712 | |
8704d4b3 MH |
1713 | procedure Iterate is |
1714 | new HT_Ops.Generic_Iteration (Process); | |
4c2d6a70 | 1715 | |
8704d4b3 MH |
1716 | ------------- |
1717 | -- Process -- | |
1718 | ------------- | |
4c2d6a70 | 1719 | |
8704d4b3 MH |
1720 | procedure Process (Src_Node : Node_Access) is |
1721 | Src : Element_Type renames Src_Node.Element.all; | |
1722 | Idx : constant Hash_Type := Hash (Src) mod Buckets'Length; | |
4c2d6a70 | 1723 | |
8704d4b3 | 1724 | Tgt_Node : Node_Access := Buckets (Idx); |
4c2d6a70 | 1725 | |
8704d4b3 MH |
1726 | begin |
1727 | while Tgt_Node /= null loop | |
1728 | if Equivalent_Elements (Src, Tgt_Node.Element.all) then | |
1729 | return; | |
1730 | end if; | |
1731 | Tgt_Node := Next (Tgt_Node); | |
1732 | end loop; | |
4c2d6a70 | 1733 | |
8704d4b3 MH |
1734 | declare |
1735 | Tgt : Element_Access := new Element_Type'(Src); | |
1736 | begin | |
1737 | Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx)); | |
1738 | exception | |
1739 | when others => | |
1740 | Free_Element (Tgt); | |
1741 | raise; | |
1742 | end; | |
4c2d6a70 | 1743 | |
8704d4b3 MH |
1744 | Length := Length + 1; |
1745 | end Process; | |
4c2d6a70 | 1746 | |
8704d4b3 | 1747 | -- Start of processing for Iterate_Right |
4c2d6a70 | 1748 | |
8704d4b3 MH |
1749 | begin |
1750 | Iterate (Right.HT); | |
1751 | exception | |
1752 | when others => | |
1753 | HT_Ops.Free_Hash_Table (Buckets); | |
1754 | raise; | |
1755 | end Iterate_Right; | |
4c2d6a70 | 1756 | |
8704d4b3 MH |
1757 | return (Controlled with HT => (Buckets, Length, 0, 0)); |
1758 | end Union; | |
4c2d6a70 | 1759 | |
ba355842 MH |
1760 | --------- |
1761 | -- Vet -- | |
1762 | --------- | |
1763 | ||
1764 | function Vet (Position : Cursor) return Boolean is | |
1765 | begin | |
1766 | if Position.Node = null then | |
1767 | return Position.Container = null; | |
1768 | end if; | |
1769 | ||
1770 | if Position.Container = null then | |
1771 | return False; | |
1772 | end if; | |
1773 | ||
1774 | if Position.Node.Next = Position.Node then | |
1775 | return False; | |
1776 | end if; | |
1777 | ||
1778 | if Position.Node.Element = null then | |
1779 | return False; | |
1780 | end if; | |
1781 | ||
1782 | declare | |
1783 | HT : Hash_Table_Type renames Position.Container.HT; | |
1784 | X : Node_Access; | |
1785 | ||
1786 | begin | |
1787 | if HT.Length = 0 then | |
1788 | return False; | |
1789 | end if; | |
1790 | ||
1791 | if HT.Buckets = null | |
1792 | or else HT.Buckets'Length = 0 | |
1793 | then | |
1794 | return False; | |
1795 | end if; | |
1796 | ||
1797 | X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all)); | |
1798 | ||
1799 | for J in 1 .. HT.Length loop | |
1800 | if X = Position.Node then | |
1801 | return True; | |
1802 | end if; | |
1803 | ||
1804 | if X = null then | |
1805 | return False; | |
1806 | end if; | |
1807 | ||
1808 | if X = X.Next then -- to prevent unnecessary looping | |
1809 | return False; | |
1810 | end if; | |
1811 | ||
1812 | X := X.Next; | |
1813 | end loop; | |
1814 | ||
1815 | return False; | |
1816 | end; | |
1817 | end Vet; | |
1818 | ||
8704d4b3 MH |
1819 | ----------- |
1820 | -- Write -- | |
1821 | ----------- | |
4c2d6a70 | 1822 | |
8704d4b3 | 1823 | procedure Write |
4c2d6a70 | 1824 | (Stream : access Root_Stream_Type'Class; |
8704d4b3 MH |
1825 | Container : Set) |
1826 | is | |
1827 | begin | |
1828 | Write_Nodes (Stream, Container.HT); | |
1829 | end Write; | |
4c2d6a70 | 1830 | |
2368f04e MH |
1831 | procedure Write |
1832 | (Stream : access Root_Stream_Type'Class; | |
1833 | Item : Cursor) | |
1834 | is | |
1835 | begin | |
ffabcde5 | 1836 | raise Program_Error with "attempt to stream set cursor"; |
2368f04e MH |
1837 | end Write; |
1838 | ||
8704d4b3 MH |
1839 | ---------------- |
1840 | -- Write_Node -- | |
1841 | ---------------- | |
4c2d6a70 | 1842 | |
8704d4b3 MH |
1843 | procedure Write_Node |
1844 | (Stream : access Root_Stream_Type'Class; | |
1845 | Node : Node_Access) | |
1846 | is | |
1847 | begin | |
1848 | Element_Type'Output (Stream, Node.Element.all); | |
1849 | end Write_Node; | |
4c2d6a70 | 1850 | |
8704d4b3 | 1851 | package body Generic_Keys is |
4c2d6a70 | 1852 | |
8704d4b3 MH |
1853 | ----------------------- |
1854 | -- Local Subprograms -- | |
1855 | ----------------------- | |
4c2d6a70 | 1856 | |
8704d4b3 | 1857 | function Equivalent_Key_Node |
4c2d6a70 AC |
1858 | (Key : Key_Type; |
1859 | Node : Node_Access) return Boolean; | |
8704d4b3 | 1860 | pragma Inline (Equivalent_Key_Node); |
4c2d6a70 | 1861 | |
8704d4b3 MH |
1862 | -------------------------- |
1863 | -- Local Instantiations -- | |
1864 | -------------------------- | |
4c2d6a70 AC |
1865 | |
1866 | package Key_Keys is | |
1867 | new Hash_Tables.Generic_Keys | |
1868 | (HT_Types => HT_Types, | |
4c2d6a70 AC |
1869 | Next => Next, |
1870 | Set_Next => Set_Next, | |
1871 | Key_Type => Key_Type, | |
1872 | Hash => Hash, | |
8704d4b3 | 1873 | Equivalent_Keys => Equivalent_Key_Node); |
4c2d6a70 | 1874 | |
8704d4b3 MH |
1875 | -------------- |
1876 | -- Contains -- | |
1877 | -------------- | |
4c2d6a70 | 1878 | |
8704d4b3 MH |
1879 | function Contains |
1880 | (Container : Set; | |
1881 | Key : Key_Type) return Boolean | |
1882 | is | |
4c2d6a70 | 1883 | begin |
8704d4b3 MH |
1884 | return Find (Container, Key) /= No_Element; |
1885 | end Contains; | |
4c2d6a70 | 1886 | |
8704d4b3 MH |
1887 | ------------ |
1888 | -- Delete -- | |
1889 | ------------ | |
4c2d6a70 | 1890 | |
8704d4b3 MH |
1891 | procedure Delete |
1892 | (Container : in out Set; | |
1893 | Key : Key_Type) | |
1894 | is | |
1895 | X : Node_Access; | |
4c2d6a70 | 1896 | |
4c2d6a70 | 1897 | begin |
8704d4b3 MH |
1898 | Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); |
1899 | ||
1900 | if X = null then | |
ffabcde5 | 1901 | raise Constraint_Error with "key not in map"; |
8704d4b3 | 1902 | end if; |
4c2d6a70 | 1903 | |
8704d4b3 MH |
1904 | Free (X); |
1905 | end Delete; | |
4c2d6a70 | 1906 | |
8704d4b3 MH |
1907 | ------------- |
1908 | -- Element -- | |
1909 | ------------- | |
4c2d6a70 | 1910 | |
8704d4b3 MH |
1911 | function Element |
1912 | (Container : Set; | |
1913 | Key : Key_Type) return Element_Type | |
1914 | is | |
1915 | Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); | |
ffabcde5 | 1916 | |
4c2d6a70 | 1917 | begin |
ffabcde5 MH |
1918 | if Node = null then |
1919 | raise Constraint_Error with "key not in map"; | |
1920 | end if; | |
1921 | ||
4c2d6a70 AC |
1922 | return Node.Element.all; |
1923 | end Element; | |
1924 | ||
8704d4b3 MH |
1925 | ------------------------- |
1926 | -- Equivalent_Key_Node -- | |
1927 | ------------------------- | |
4c2d6a70 | 1928 | |
8704d4b3 MH |
1929 | function Equivalent_Key_Node |
1930 | (Key : Key_Type; | |
1931 | Node : Node_Access) return Boolean is | |
4c2d6a70 | 1932 | begin |
ba355842 | 1933 | return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all)); |
8704d4b3 | 1934 | end Equivalent_Key_Node; |
4c2d6a70 | 1935 | |
8704d4b3 MH |
1936 | ------------- |
1937 | -- Exclude -- | |
1938 | ------------- | |
4c2d6a70 | 1939 | |
8704d4b3 MH |
1940 | procedure Exclude |
1941 | (Container : in out Set; | |
1942 | Key : Key_Type) | |
1943 | is | |
4c2d6a70 | 1944 | X : Node_Access; |
4c2d6a70 | 1945 | begin |
8704d4b3 MH |
1946 | Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); |
1947 | Free (X); | |
1948 | end Exclude; | |
4c2d6a70 | 1949 | |
8704d4b3 MH |
1950 | ---------- |
1951 | -- Find -- | |
1952 | ---------- | |
4c2d6a70 | 1953 | |
8704d4b3 MH |
1954 | function Find |
1955 | (Container : Set; | |
1956 | Key : Key_Type) return Cursor | |
1957 | is | |
1958 | Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); | |
1959 | ||
1960 | begin | |
1961 | if Node = null then | |
1962 | return No_Element; | |
4c2d6a70 AC |
1963 | end if; |
1964 | ||
8704d4b3 MH |
1965 | return Cursor'(Container'Unrestricted_Access, Node); |
1966 | end Find; | |
4c2d6a70 | 1967 | |
8704d4b3 MH |
1968 | --------- |
1969 | -- Key -- | |
1970 | --------- | |
4c2d6a70 | 1971 | |
8704d4b3 MH |
1972 | function Key (Position : Cursor) return Key_Type is |
1973 | begin | |
ba355842 | 1974 | if Position.Node = null then |
ffabcde5 MH |
1975 | raise Constraint_Error with |
1976 | "Position cursor equals No_Element"; | |
ba355842 MH |
1977 | end if; |
1978 | ||
1979 | if Position.Node.Element = null then | |
ffabcde5 | 1980 | raise Program_Error with "Position cursor is bad"; |
ba355842 MH |
1981 | end if; |
1982 | ||
ffabcde5 MH |
1983 | pragma Assert (Vet (Position), "bad cursor in function Key"); |
1984 | ||
8704d4b3 MH |
1985 | return Key (Position.Node.Element.all); |
1986 | end Key; | |
4c2d6a70 | 1987 | |
8704d4b3 MH |
1988 | ------------- |
1989 | -- Replace -- | |
1990 | ------------- | |
4c2d6a70 | 1991 | |
8704d4b3 MH |
1992 | procedure Replace |
1993 | (Container : in out Set; | |
1994 | Key : Key_Type; | |
1995 | New_Item : Element_Type) | |
1996 | is | |
1997 | Node : constant Node_Access := | |
1998 | Key_Keys.Find (Container.HT, Key); | |
4c2d6a70 AC |
1999 | |
2000 | begin | |
8704d4b3 | 2001 | if Node = null then |
ffabcde5 MH |
2002 | raise Constraint_Error with |
2003 | "attempt to replace key not in set"; | |
8704d4b3 | 2004 | end if; |
4c2d6a70 | 2005 | |
8704d4b3 MH |
2006 | Replace_Element (Container.HT, Node, New_Item); |
2007 | end Replace; | |
4c2d6a70 | 2008 | |
8704d4b3 | 2009 | procedure Update_Element_Preserving_Key |
4c2d6a70 | 2010 | (Container : in out Set; |
ffabcde5 | 2011 | Position : Cursor; |
4c2d6a70 | 2012 | Process : not null access |
8704d4b3 MH |
2013 | procedure (Element : in out Element_Type)) |
2014 | is | |
ba355842 MH |
2015 | HT : Hash_Table_Type renames Container.HT; |
2016 | Indx : Hash_Type; | |
4c2d6a70 AC |
2017 | |
2018 | begin | |
8704d4b3 | 2019 | if Position.Node = null then |
ffabcde5 MH |
2020 | raise Constraint_Error with |
2021 | "Position cursor equals No_Element"; | |
4c2d6a70 AC |
2022 | end if; |
2023 | ||
ba355842 MH |
2024 | if Position.Node.Element = null |
2025 | or else Position.Node.Next = Position.Node | |
2026 | then | |
ffabcde5 | 2027 | raise Program_Error with "Position cursor is bad"; |
4c2d6a70 AC |
2028 | end if; |
2029 | ||
ba355842 | 2030 | if Position.Container /= Container'Unrestricted_Access then |
ffabcde5 MH |
2031 | raise Program_Error with |
2032 | "Position cursor designates wrong set"; | |
ba355842 MH |
2033 | end if; |
2034 | ||
2035 | if HT.Buckets = null | |
2036 | or else HT.Buckets'Length = 0 | |
2037 | or else HT.Length = 0 | |
2038 | then | |
ffabcde5 | 2039 | raise Program_Error with "Position cursor is bad (set is empty)"; |
ba355842 MH |
2040 | end if; |
2041 | ||
ffabcde5 MH |
2042 | pragma Assert |
2043 | (Vet (Position), | |
2044 | "bad cursor in Update_Element_Preserving_Key"); | |
2045 | ||
ba355842 MH |
2046 | Indx := HT_Ops.Index (HT, Position.Node); |
2047 | ||
4c2d6a70 | 2048 | declare |
8704d4b3 | 2049 | E : Element_Type renames Position.Node.Element.all; |
ba355842 | 2050 | K : constant Key_Type := Key (E); |
4c2d6a70 | 2051 | |
8704d4b3 MH |
2052 | B : Natural renames HT.Busy; |
2053 | L : Natural renames HT.Lock; | |
4c2d6a70 | 2054 | |
4c2d6a70 | 2055 | begin |
8704d4b3 MH |
2056 | B := B + 1; |
2057 | L := L + 1; | |
4c2d6a70 | 2058 | |
8704d4b3 MH |
2059 | begin |
2060 | Process (E); | |
2061 | exception | |
2062 | when others => | |
2063 | L := L - 1; | |
2064 | B := B - 1; | |
2065 | raise; | |
2066 | end; | |
4c2d6a70 | 2067 | |
8704d4b3 MH |
2068 | L := L - 1; |
2069 | B := B - 1; | |
4c2d6a70 | 2070 | |
ba355842 | 2071 | if Equivalent_Keys (K, Key (E)) then |
8704d4b3 MH |
2072 | pragma Assert (Hash (K) = Hash (E)); |
2073 | return; | |
4c2d6a70 | 2074 | end if; |
8704d4b3 | 2075 | end; |
4c2d6a70 | 2076 | |
ba355842 MH |
2077 | if HT.Buckets (Indx) = Position.Node then |
2078 | HT.Buckets (Indx) := Position.Node.Next; | |
2079 | ||
2080 | else | |
2081 | declare | |
2082 | Prev : Node_Access := HT.Buckets (Indx); | |
2083 | ||
2084 | begin | |
2085 | while Prev.Next /= Position.Node loop | |
2086 | Prev := Prev.Next; | |
2087 | ||
2088 | if Prev = null then | |
ffabcde5 MH |
2089 | raise Program_Error with |
2090 | "Position cursor is bad (node not found)"; | |
ba355842 MH |
2091 | end if; |
2092 | end loop; | |
2093 | ||
2094 | Prev.Next := Position.Node.Next; | |
2095 | end; | |
2096 | end if; | |
2097 | ||
2098 | HT.Length := HT.Length - 1; | |
2099 | ||
8704d4b3 MH |
2100 | declare |
2101 | X : Node_Access := Position.Node; | |
ba355842 | 2102 | |
8704d4b3 | 2103 | begin |
8704d4b3 | 2104 | Free (X); |
4c2d6a70 AC |
2105 | end; |
2106 | ||
ffabcde5 | 2107 | raise Program_Error with "key was modified"; |
8704d4b3 | 2108 | end Update_Element_Preserving_Key; |
4c2d6a70 AC |
2109 | |
2110 | end Generic_Keys; | |
2111 | ||
2112 | end Ada.Containers.Indefinite_Hashed_Sets; |