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