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