Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-cohase.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
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 < Source.Length then
252 if Checks and then Capacity /= 0 then
253 raise Capacity_Error
254 with "Requested capacity is less than Source length";
255 end if;
256
257 C := Source.Length;
258 else
259 C := Capacity;
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, Hash_Type'Last);
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 Pos : Hash_Type;
661 Node : constant Node_Access := HT_Ops.First (Container.HT, Pos);
662 begin
663 if Node = null then
664 return No_Element;
665 end if;
666
667 return Cursor'(Container'Unrestricted_Access, Node, Pos);
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; Position : Hash_Type);
981 pragma Inline (Process_Node);
982
983 procedure Iterate is
984 new HT_Ops.Generic_Iteration_With_Position (Process_Node);
985
986 ------------------
987 -- Process_Node --
988 ------------------
989
990 procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
991 begin
992 Process (Cursor'(Container'Unrestricted_Access, Node, Position));
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 Node : Node_Access;
1042 Pos : Hash_Type;
1043 begin
1044 if Position.Node = null then
1045 return No_Element;
1046 end if;
1047
1048 pragma Assert (Vet (Position), "bad cursor in Next");
1049
1050 Pos := Position.Position;
1051 Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos);
1052
1053 if Node = null then
1054 return No_Element;
1055 end if;
1056
1057 return Cursor'(Position.Container, Node, Pos);
1058 end Next;
1059
1060 procedure Next (Position : in out Cursor) is
1061 begin
1062 Position := Next (Position);
1063 end Next;
1064
1065 function Next
1066 (Object : Iterator;
1067 Position : Cursor) return Cursor
1068 is
1069 begin
1070 if Position.Container = null then
1071 return No_Element;
1072 end if;
1073
1074 if Checks and then Position.Container /= Object.Container then
1075 raise Program_Error with
1076 "Position cursor of Next designates wrong set";
1077 end if;
1078
1079 return Next (Position);
1080 end Next;
1081
1082 -------------
1083 -- Overlap --
1084 -------------
1085
1086 function Overlap (Left, Right : Set) return Boolean is
1087 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1088 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1089 Left_Node : Node_Access;
1090
1091 begin
1092 if Right.Length = 0 then
1093 return False;
1094 end if;
1095
1096 if Left'Address = Right'Address then
1097 return True;
1098 end if;
1099
1100 Left_Node := HT_Ops.First (Left_HT);
1101 while Left_Node /= null loop
1102 if Is_In (Right_HT, Left_Node) then
1103 return True;
1104 end if;
1105 Left_Node := HT_Ops.Next (Left_HT, Left_Node);
1106 end loop;
1107
1108 return False;
1109 end Overlap;
1110
1111 ----------------------
1112 -- Pseudo_Reference --
1113 ----------------------
1114
1115 function Pseudo_Reference
1116 (Container : aliased Set'Class) return Reference_Control_Type
1117 is
1118 TC : constant Tamper_Counts_Access :=
1119 Container.HT.TC'Unrestricted_Access;
1120 begin
1121 return R : constant Reference_Control_Type := (Controlled with TC) do
1122 Lock (TC.all);
1123 end return;
1124 end Pseudo_Reference;
1125
1126 -------------------
1127 -- Query_Element --
1128 -------------------
1129
1130 procedure Query_Element
1131 (Position : Cursor;
1132 Process : not null access procedure (Element : Element_Type))
1133 is
1134 begin
1135 if Checks and then Position.Node = null then
1136 raise Constraint_Error with
1137 "Position cursor of Query_Element equals No_Element";
1138 end if;
1139
1140 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1141
1142 declare
1143 HT : Hash_Table_Type renames Position.Container.HT;
1144 Lock : With_Lock (HT.TC'Unrestricted_Access);
1145 begin
1146 Process (Position.Node.Element);
1147 end;
1148 end Query_Element;
1149
1150 ----------
1151 -- Read --
1152 ----------
1153
1154 procedure Read
1155 (Stream : not null access Root_Stream_Type'Class;
1156 Container : out Set)
1157 is
1158 begin
1159 Read_Nodes (Stream, Container.HT);
1160 end Read;
1161
1162 procedure Read
1163 (Stream : not null access Root_Stream_Type'Class;
1164 Item : out Cursor)
1165 is
1166 begin
1167 raise Program_Error with "attempt to stream set cursor";
1168 end Read;
1169
1170 procedure Read
1171 (Stream : not null access Root_Stream_Type'Class;
1172 Item : out Constant_Reference_Type)
1173 is
1174 begin
1175 raise Program_Error with "attempt to stream reference";
1176 end Read;
1177
1178 ---------------
1179 -- Read_Node --
1180 ---------------
1181
1182 function Read_Node (Stream : not null access Root_Stream_Type'Class)
1183 return Node_Access
1184 is
1185 Node : Node_Access := new Node_Type;
1186 begin
1187 Element_Type'Read (Stream, Node.Element);
1188 return Node;
1189 exception
1190 when others =>
1191 Free (Node);
1192 raise;
1193 end Read_Node;
1194
1195 -------------
1196 -- Replace --
1197 -------------
1198
1199 procedure Replace
1200 (Container : in out Set;
1201 New_Item : Element_Type)
1202 is
1203 Node : constant Node_Access :=
1204 Element_Keys.Find (Container.HT, New_Item);
1205
1206 begin
1207 if Checks and then Node = null then
1208 raise Constraint_Error with
1209 "attempt to replace element not in set";
1210 end if;
1211
1212 TE_Check (Container.HT.TC);
1213
1214 Node.Element := New_Item;
1215 end Replace;
1216
1217 procedure Replace_Element
1218 (Container : in out Set;
1219 Position : Cursor;
1220 New_Item : Element_Type)
1221 is
1222 begin
1223 if Checks and then Position.Node = null then
1224 raise Constraint_Error with
1225 "Position cursor equals No_Element";
1226 end if;
1227
1228 if Checks and then Position.Container /= Container'Unrestricted_Access
1229 then
1230 raise Program_Error with
1231 "Position cursor designates wrong set";
1232 end if;
1233
1234 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1235
1236 Replace_Element (Container.HT, Position.Node, New_Item);
1237 end Replace_Element;
1238
1239 ----------------------
1240 -- Reserve_Capacity --
1241 ----------------------
1242
1243 procedure Reserve_Capacity
1244 (Container : in out Set;
1245 Capacity : Count_Type)
1246 is
1247 begin
1248 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1249 end Reserve_Capacity;
1250
1251 --------------
1252 -- Set_Next --
1253 --------------
1254
1255 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1256 begin
1257 Node.Next := Next;
1258 end Set_Next;
1259
1260 --------------------------
1261 -- Symmetric_Difference --
1262 --------------------------
1263
1264 procedure Symmetric_Difference
1265 (Target : in out Set;
1266 Source : Set)
1267 is
1268 Tgt_HT : Hash_Table_Type renames Target.HT;
1269 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all;
1270 begin
1271 if Target'Address = Source'Address then
1272 Clear (Target);
1273 return;
1274 end if;
1275
1276 TC_Check (Tgt_HT.TC);
1277
1278 declare
1279 N : constant Count_Type := Target.Length + Source.Length;
1280 begin
1281 if N > HT_Ops.Capacity (Tgt_HT) then
1282 HT_Ops.Reserve_Capacity (Tgt_HT, N);
1283 end if;
1284 end;
1285
1286 if Target.Length = 0 then
1287 Iterate_Source_When_Empty_Target : declare
1288 procedure Process (Src_Node : Node_Access);
1289
1290 procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1291
1292 -------------
1293 -- Process --
1294 -------------
1295
1296 procedure Process (Src_Node : Node_Access) is
1297 E : Element_Type renames Src_Node.Element;
1298 B : Buckets_Type renames Tgt_HT.Buckets.all;
1299 J : constant Hash_Type := Hash (E) mod B'Length;
1300 N : Count_Type renames Tgt_HT.Length;
1301
1302 begin
1303 B (J) := new Node_Type'(E, B (J));
1304 N := N + 1;
1305 end Process;
1306
1307 -- Per AI05-0022, the container implementation is required to
1308 -- detect element tampering by a generic actual subprogram.
1309
1310 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
1311 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
1312
1313 -- Start of processing for Iterate_Source_When_Empty_Target
1314
1315 begin
1316 Iterate (Src_HT);
1317 end Iterate_Source_When_Empty_Target;
1318
1319 else
1320 Iterate_Source : declare
1321 procedure Process (Src_Node : Node_Access);
1322
1323 procedure Iterate is
1324 new HT_Ops.Generic_Iteration (Process);
1325
1326 -------------
1327 -- Process --
1328 -------------
1329
1330 procedure Process (Src_Node : Node_Access) is
1331 E : Element_Type renames Src_Node.Element;
1332 B : Buckets_Type renames Tgt_HT.Buckets.all;
1333 J : constant Hash_Type := Hash (E) mod B'Length;
1334 N : Count_Type renames Tgt_HT.Length;
1335
1336 begin
1337 if B (J) = null then
1338 B (J) := new Node_Type'(E, null);
1339 N := N + 1;
1340
1341 elsif Equivalent_Elements (E, B (J).Element) then
1342 declare
1343 X : Node_Access := B (J);
1344 begin
1345 B (J) := B (J).Next;
1346 N := N - 1;
1347 Free (X);
1348 end;
1349
1350 else
1351 declare
1352 Prev : Node_Access := B (J);
1353 Curr : Node_Access := Prev.Next;
1354
1355 begin
1356 while Curr /= null loop
1357 if Equivalent_Elements (E, Curr.Element) then
1358 Prev.Next := Curr.Next;
1359 N := N - 1;
1360 Free (Curr);
1361 return;
1362 end if;
1363
1364 Prev := Curr;
1365 Curr := Prev.Next;
1366 end loop;
1367
1368 B (J) := new Node_Type'(E, B (J));
1369 N := N + 1;
1370 end;
1371 end if;
1372 end Process;
1373
1374 -- Per AI05-0022, the container implementation is required to
1375 -- detect element tampering by a generic actual subprogram.
1376
1377 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access);
1378 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access);
1379
1380 -- Start of processing for Iterate_Source
1381
1382 begin
1383 Iterate (Src_HT);
1384 end Iterate_Source;
1385 end if;
1386 end Symmetric_Difference;
1387
1388 function Symmetric_Difference (Left, Right : Set) return Set is
1389 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT;
1390 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT;
1391 Buckets : HT_Types.Buckets_Access;
1392 Length : Count_Type;
1393
1394 begin
1395 if Left'Address = Right'Address then
1396 return Empty_Set;
1397 end if;
1398
1399 if Right.Length = 0 then
1400 return Left;
1401 end if;
1402
1403 if Left.Length = 0 then
1404 return Right;
1405 end if;
1406
1407 declare
1408 Size : constant Hash_Type :=
1409 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1410 begin
1411 Buckets := HT_Ops.New_Buckets (Length => Size);
1412 end;
1413
1414 Length := 0;
1415
1416 Iterate_Left : declare
1417 procedure Process (L_Node : Node_Access);
1418
1419 procedure Iterate is
1420 new HT_Ops.Generic_Iteration (Process);
1421
1422 -------------
1423 -- Process --
1424 -------------
1425
1426 procedure Process (L_Node : Node_Access) is
1427 begin
1428 if not Is_In (Right_HT, L_Node) then
1429 declare
1430 E : Element_Type renames L_Node.Element;
1431
1432 -- Per AI05-0022, the container implementation is required
1433 -- to detect element tampering by a generic actual
1434 -- subprogram, hence the use of Checked_Index instead of a
1435 -- simple invocation of generic formal Hash.
1436
1437 J : constant Hash_Type :=
1438 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node);
1439
1440 begin
1441 Buckets (J) := new Node_Type'(E, Buckets (J));
1442 Length := Length + 1;
1443 end;
1444 end if;
1445 end Process;
1446
1447 -- Start of processing for Iterate_Left
1448
1449 begin
1450 Iterate (Left_HT);
1451
1452 exception
1453 when others =>
1454 HT_Ops.Free_Hash_Table (Buckets);
1455 raise;
1456 end Iterate_Left;
1457
1458 Iterate_Right : declare
1459 procedure Process (R_Node : Node_Access);
1460
1461 procedure Iterate is
1462 new HT_Ops.Generic_Iteration (Process);
1463
1464 -------------
1465 -- Process --
1466 -------------
1467
1468 procedure Process (R_Node : Node_Access) is
1469 begin
1470 if not Is_In (Left_HT, R_Node) then
1471 declare
1472 E : Element_Type renames R_Node.Element;
1473
1474 -- Per AI05-0022, the container implementation is required
1475 -- to detect element tampering by a generic actual
1476 -- subprogram, hence the use of Checked_Index instead of a
1477 -- simple invocation of generic formal Hash.
1478
1479 J : constant Hash_Type :=
1480 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node);
1481
1482 begin
1483 Buckets (J) := new Node_Type'(E, Buckets (J));
1484 Length := Length + 1;
1485 end;
1486 end if;
1487 end Process;
1488
1489 -- Start of processing for Iterate_Right
1490
1491 begin
1492 Iterate (Right_HT);
1493
1494 exception
1495 when others =>
1496 HT_Ops.Free_Hash_Table (Buckets);
1497 raise;
1498 end Iterate_Right;
1499
1500 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
1501 end Symmetric_Difference;
1502
1503 ------------
1504 -- To_Set --
1505 ------------
1506
1507 function To_Set (New_Item : Element_Type) return Set is
1508 HT : Hash_Table_Type;
1509
1510 Node : Node_Access;
1511 Inserted : Boolean;
1512 pragma Unreferenced (Node, Inserted);
1513
1514 begin
1515 Insert (HT, New_Item, Node, Inserted);
1516 return Set'(Controlled with HT);
1517 end To_Set;
1518
1519 -----------
1520 -- Union --
1521 -----------
1522
1523 procedure Union
1524 (Target : in out Set;
1525 Source : Set)
1526 is
1527 procedure Process (Src_Node : Node_Access);
1528
1529 procedure Iterate is
1530 new HT_Ops.Generic_Iteration (Process);
1531
1532 -------------
1533 -- Process --
1534 -------------
1535
1536 procedure Process (Src_Node : Node_Access) is
1537 function New_Node (Next : Node_Access) return Node_Access;
1538 pragma Inline (New_Node);
1539
1540 procedure Insert is
1541 new Element_Keys.Generic_Conditional_Insert (New_Node);
1542
1543 --------------
1544 -- New_Node --
1545 --------------
1546
1547 function New_Node (Next : Node_Access) return Node_Access is
1548 Node : constant Node_Access :=
1549 new Node_Type'(Src_Node.Element, Next);
1550 begin
1551 return Node;
1552 end New_Node;
1553
1554 Tgt_Node : Node_Access;
1555 Success : Boolean;
1556 pragma Unreferenced (Tgt_Node, Success);
1557
1558 -- Start of processing for Process
1559
1560 begin
1561 Insert (Target.HT, Src_Node.Element, Tgt_Node, Success);
1562 end Process;
1563
1564 -- Start of processing for Union
1565
1566 begin
1567 if Target'Address = Source'Address then
1568 return;
1569 end if;
1570
1571 TC_Check (Target.HT.TC);
1572
1573 declare
1574 N : constant Count_Type := Target.Length + Source.Length;
1575 begin
1576 if N > HT_Ops.Capacity (Target.HT) then
1577 HT_Ops.Reserve_Capacity (Target.HT, N);
1578 end if;
1579 end;
1580
1581 Iterate (Source.HT);
1582 end Union;
1583
1584 function Union (Left, Right : Set) return Set is
1585 Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all;
1586 Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all;
1587 Buckets : HT_Types.Buckets_Access;
1588 Length : Count_Type;
1589
1590 begin
1591 if Left'Address = Right'Address then
1592 return Left;
1593 end if;
1594
1595 if Right.Length = 0 then
1596 return Left;
1597 end if;
1598
1599 if Left.Length = 0 then
1600 return Right;
1601 end if;
1602
1603 declare
1604 Size : constant Hash_Type :=
1605 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1606 begin
1607 Buckets := HT_Ops.New_Buckets (Length => Size);
1608 end;
1609
1610 Iterate_Left : declare
1611 procedure Process (L_Node : Node_Access);
1612
1613 procedure Iterate is
1614 new HT_Ops.Generic_Iteration (Process);
1615
1616 -------------
1617 -- Process --
1618 -------------
1619
1620 procedure Process (L_Node : Node_Access) is
1621 J : constant Hash_Type :=
1622 Hash (L_Node.Element) mod Buckets'Length;
1623
1624 begin
1625 Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J));
1626 end Process;
1627
1628 -- Per AI05-0022, the container implementation is required to detect
1629 -- element tampering by a generic actual subprogram, hence the use of
1630 -- Checked_Index instead of a simple invocation of generic formal
1631 -- Hash.
1632
1633 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
1634
1635 -- Start of processing for Iterate_Left
1636
1637 begin
1638 Iterate (Left_HT);
1639 exception
1640 when others =>
1641 HT_Ops.Free_Hash_Table (Buckets);
1642 raise;
1643 end Iterate_Left;
1644
1645 Length := Left.Length;
1646
1647 Iterate_Right : declare
1648 procedure Process (Src_Node : Node_Access);
1649
1650 procedure Iterate is
1651 new HT_Ops.Generic_Iteration (Process);
1652
1653 -------------
1654 -- Process --
1655 -------------
1656
1657 procedure Process (Src_Node : Node_Access) is
1658 J : constant Hash_Type :=
1659 Hash (Src_Node.Element) mod Buckets'Length;
1660
1661 Tgt_Node : Node_Access := Buckets (J);
1662
1663 begin
1664 while Tgt_Node /= null loop
1665 if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then
1666 return;
1667 end if;
1668
1669 Tgt_Node := Next (Tgt_Node);
1670 end loop;
1671
1672 Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J));
1673 Length := Length + 1;
1674 end Process;
1675
1676 -- Per AI05-0022, the container implementation is required to detect
1677 -- element tampering by a generic actual subprogram, hence the use of
1678 -- Checked_Index instead of a simple invocation of generic formal
1679 -- Hash.
1680
1681 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access);
1682 Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access);
1683
1684 -- Start of processing for Iterate_Right
1685
1686 begin
1687 Iterate (Right_HT);
1688 exception
1689 when others =>
1690 HT_Ops.Free_Hash_Table (Buckets);
1691 raise;
1692 end Iterate_Right;
1693
1694 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0)));
1695 end Union;
1696
1697 ---------
1698 -- Vet --
1699 ---------
1700
1701 function Vet (Position : Cursor) return Boolean is
1702 begin
1703 if Position.Node = null then
1704 return Position.Container = null;
1705 end if;
1706
1707 if Position.Container = null then
1708 return False;
1709 end if;
1710
1711 if Position.Node.Next = Position.Node then
1712 return False;
1713 end if;
1714
1715 declare
1716 HT : Hash_Table_Type renames Position.Container.HT;
1717 X : Node_Access;
1718
1719 begin
1720 if HT.Length = 0 then
1721 return False;
1722 end if;
1723
1724 if HT.Buckets = null
1725 or else HT.Buckets'Length = 0
1726 then
1727 return False;
1728 end if;
1729
1730 X := HT.Buckets (Element_Keys.Checked_Index
1731 (HT,
1732 Position.Node.Element));
1733
1734 for J in 1 .. HT.Length loop
1735 if X = Position.Node then
1736 return True;
1737 end if;
1738
1739 if X = null then
1740 return False;
1741 end if;
1742
1743 if X = X.Next then -- to prevent unnecessary looping
1744 return False;
1745 end if;
1746
1747 X := X.Next;
1748 end loop;
1749
1750 return False;
1751 end;
1752 end Vet;
1753
1754 -----------
1755 -- Write --
1756 -----------
1757
1758 procedure Write
1759 (Stream : not null access Root_Stream_Type'Class;
1760 Container : Set)
1761 is
1762 begin
1763 Write_Nodes (Stream, Container.HT);
1764 end Write;
1765
1766 procedure Write
1767 (Stream : not null access Root_Stream_Type'Class;
1768 Item : Cursor)
1769 is
1770 begin
1771 raise Program_Error with "attempt to stream set cursor";
1772 end Write;
1773
1774 procedure Write
1775 (Stream : not null access Root_Stream_Type'Class;
1776 Item : Constant_Reference_Type)
1777 is
1778 begin
1779 raise Program_Error with "attempt to stream reference";
1780 end Write;
1781
1782 ----------------
1783 -- Write_Node --
1784 ----------------
1785
1786 procedure Write_Node
1787 (Stream : not null access Root_Stream_Type'Class;
1788 Node : Node_Access)
1789 is
1790 begin
1791 Element_Type'Write (Stream, Node.Element);
1792 end Write_Node;
1793
1794 package body Generic_Keys is
1795
1796 -----------------------
1797 -- Local Subprograms --
1798 -----------------------
1799
1800 function Equivalent_Key_Node
1801 (Key : Key_Type;
1802 Node : Node_Access) return Boolean;
1803 pragma Inline (Equivalent_Key_Node);
1804
1805 --------------------------
1806 -- Local Instantiations --
1807 --------------------------
1808
1809 package Key_Keys is
1810 new Hash_Tables.Generic_Keys
1811 (HT_Types => HT_Types,
1812 Next => Next,
1813 Set_Next => Set_Next,
1814 Key_Type => Key_Type,
1815 Hash => Hash,
1816 Equivalent_Keys => Equivalent_Key_Node);
1817
1818 ------------------------
1819 -- Constant_Reference --
1820 ------------------------
1821
1822 function Constant_Reference
1823 (Container : aliased Set;
1824 Key : Key_Type) return Constant_Reference_Type
1825 is
1826 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
1827 Node : constant Node_Access := Key_Keys.Find (HT, Key);
1828
1829 begin
1830 if Checks and then Node = null then
1831 raise Constraint_Error with "Key not in set";
1832 end if;
1833
1834 declare
1835 TC : constant Tamper_Counts_Access :=
1836 HT.TC'Unrestricted_Access;
1837 begin
1838 return R : constant Constant_Reference_Type :=
1839 (Element => Node.Element'Access,
1840 Control => (Controlled with TC))
1841 do
1842 Lock (TC.all);
1843 end return;
1844 end;
1845 end Constant_Reference;
1846
1847 --------------
1848 -- Contains --
1849 --------------
1850
1851 function Contains
1852 (Container : Set;
1853 Key : Key_Type) return Boolean
1854 is
1855 begin
1856 return Find (Container, Key) /= No_Element;
1857 end Contains;
1858
1859 ------------
1860 -- Delete --
1861 ------------
1862
1863 procedure Delete
1864 (Container : in out Set;
1865 Key : Key_Type)
1866 is
1867 X : Node_Access;
1868
1869 begin
1870 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1871
1872 if Checks and then X = null then
1873 raise Constraint_Error with "attempt to delete key not in set";
1874 end if;
1875
1876 Free (X);
1877 end Delete;
1878
1879 -------------
1880 -- Element --
1881 -------------
1882
1883 function Element
1884 (Container : Set;
1885 Key : Key_Type) return Element_Type
1886 is
1887 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
1888 Node : constant Node_Access := Key_Keys.Find (HT, Key);
1889
1890 begin
1891 if Checks and then Node = null then
1892 raise Constraint_Error with "key not in set";
1893 end if;
1894
1895 return Node.Element;
1896 end Element;
1897
1898 -------------------------
1899 -- Equivalent_Key_Node --
1900 -------------------------
1901
1902 function Equivalent_Key_Node
1903 (Key : Key_Type;
1904 Node : Node_Access) return Boolean
1905 is
1906 begin
1907 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1908 end Equivalent_Key_Node;
1909
1910 -------------
1911 -- Exclude --
1912 -------------
1913
1914 procedure Exclude
1915 (Container : in out Set;
1916 Key : Key_Type)
1917 is
1918 X : Node_Access;
1919 begin
1920 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1921 Free (X);
1922 end Exclude;
1923
1924 --------------
1925 -- Finalize --
1926 --------------
1927
1928 procedure Finalize (Control : in out Reference_Control_Type) is
1929 begin
1930 if Control.Container /= null then
1931 Impl.Reference_Control_Type (Control).Finalize;
1932
1933 if Checks and then
1934 Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
1935 then
1936 HT_Ops.Delete_Node_At_Index
1937 (Control.Container.HT, Control.Index, Control.Old_Pos.Node);
1938 raise Program_Error with "key not preserved in reference";
1939 end if;
1940
1941 Control.Container := null;
1942 end if;
1943 end Finalize;
1944
1945 ----------
1946 -- Find --
1947 ----------
1948
1949 function Find
1950 (Container : Set;
1951 Key : Key_Type) return Cursor
1952 is
1953 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
1954 Node : constant Node_Access := Key_Keys.Find (HT, Key);
1955 begin
1956 if Node = null then
1957 return No_Element;
1958 else
1959 return Cursor'
1960 (Container'Unrestricted_Access, Node, Hash_Type'Last);
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;