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