2010-07-27 Paolo Carlini <paolo.carlini@oracle.com>
[official-gcc/alias-decl.git] / gcc / ada / a-cihase.adb
blobc901e646e66ae99278ddf250c52292ab039f9c50
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_SETS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2009, 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 ------------------------------------------------------------------------------
30 with Ada.Unchecked_Deallocation;
32 with Ada.Containers.Hash_Tables.Generic_Operations;
33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
35 with Ada.Containers.Hash_Tables.Generic_Keys;
36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
38 with Ada.Containers.Prime_Numbers;
40 with System; use type System.Address;
42 package body Ada.Containers.Indefinite_Hashed_Sets is
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Assign (Node : Node_Access; Item : Element_Type);
49 pragma Inline (Assign);
51 function Copy_Node (Source : Node_Access) return Node_Access;
52 pragma Inline (Copy_Node);
54 function Equivalent_Keys
55 (Key : Element_Type;
56 Node : Node_Access) return Boolean;
57 pragma Inline (Equivalent_Keys);
59 function Find_Equal_Key
60 (R_HT : Hash_Table_Type;
61 L_Node : Node_Access) return Boolean;
63 function Find_Equivalent_Key
64 (R_HT : Hash_Table_Type;
65 L_Node : Node_Access) return Boolean;
67 procedure Free (X : in out Node_Access);
69 function Hash_Node (Node : Node_Access) return Hash_Type;
70 pragma Inline (Hash_Node);
72 procedure Insert
73 (HT : in out Hash_Table_Type;
74 New_Item : Element_Type;
75 Node : out Node_Access;
76 Inserted : out Boolean);
78 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean;
79 pragma Inline (Is_In);
81 function Next (Node : Node_Access) return Node_Access;
82 pragma Inline (Next);
84 function Read_Node (Stream : not null access Root_Stream_Type'Class)
85 return Node_Access;
86 pragma Inline (Read_Node);
88 procedure Set_Next (Node : Node_Access; Next : Node_Access);
89 pragma Inline (Set_Next);
91 function Vet (Position : Cursor) return Boolean;
93 procedure Write_Node
94 (Stream : not null access Root_Stream_Type'Class;
95 Node : Node_Access);
96 pragma Inline (Write_Node);
98 --------------------------
99 -- Local Instantiations --
100 --------------------------
102 procedure Free_Element is
103 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
105 package HT_Ops is new Hash_Tables.Generic_Operations
106 (HT_Types => HT_Types,
107 Hash_Node => Hash_Node,
108 Next => Next,
109 Set_Next => Set_Next,
110 Copy_Node => Copy_Node,
111 Free => Free);
113 package Element_Keys is new Hash_Tables.Generic_Keys
114 (HT_Types => HT_Types,
115 Next => Next,
116 Set_Next => Set_Next,
117 Key_Type => Element_Type,
118 Hash => Hash,
119 Equivalent_Keys => Equivalent_Keys);
121 function Is_Equal is
122 new HT_Ops.Generic_Equal (Find_Equal_Key);
124 function Is_Equivalent is
125 new HT_Ops.Generic_Equal (Find_Equivalent_Key);
127 procedure Read_Nodes is
128 new HT_Ops.Generic_Read (Read_Node);
130 procedure Replace_Element is
131 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
133 procedure Write_Nodes is
134 new HT_Ops.Generic_Write (Write_Node);
136 ---------
137 -- "=" --
138 ---------
140 function "=" (Left, Right : Set) return Boolean is
141 begin
142 return Is_Equal (Left.HT, Right.HT);
143 end "=";
145 ------------
146 -- Adjust --
147 ------------
149 procedure Adjust (Container : in out Set) is
150 begin
151 HT_Ops.Adjust (Container.HT);
152 end Adjust;
154 ------------
155 -- Assign --
156 ------------
158 procedure Assign (Node : Node_Access; Item : Element_Type) is
159 X : Element_Access := Node.Element;
160 begin
161 Node.Element := new Element_Type'(Item);
162 Free_Element (X);
163 end Assign;
165 --------------
166 -- Capacity --
167 --------------
169 function Capacity (Container : Set) return Count_Type is
170 begin
171 return HT_Ops.Capacity (Container.HT);
172 end Capacity;
174 -----------
175 -- Clear --
176 -----------
178 procedure Clear (Container : in out Set) is
179 begin
180 HT_Ops.Clear (Container.HT);
181 end Clear;
183 --------------
184 -- Contains --
185 --------------
187 function Contains (Container : Set; Item : Element_Type) return Boolean is
188 begin
189 return Find (Container, Item) /= No_Element;
190 end Contains;
192 ---------------
193 -- Copy_Node --
194 ---------------
196 function Copy_Node (Source : Node_Access) return Node_Access is
197 E : Element_Access := new Element_Type'(Source.Element.all);
198 begin
199 return new Node_Type'(Element => E, Next => null);
200 exception
201 when others =>
202 Free_Element (E);
203 raise;
204 end Copy_Node;
206 ------------
207 -- Delete --
208 ------------
210 procedure Delete
211 (Container : in out Set;
212 Item : Element_Type)
214 X : Node_Access;
216 begin
217 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
219 if X = null then
220 raise Constraint_Error with "attempt to delete element not in set";
221 end if;
223 Free (X);
224 end Delete;
226 procedure Delete
227 (Container : in out Set;
228 Position : in out Cursor)
230 begin
231 if Position.Node = null then
232 raise Constraint_Error with "Position cursor equals No_Element";
233 end if;
235 if Position.Node.Element = null then
236 raise Program_Error with "Position cursor is bad";
237 end if;
239 if Position.Container /= Container'Unrestricted_Access then
240 raise Program_Error with "Position cursor designates wrong set";
241 end if;
243 if Container.HT.Busy > 0 then
244 raise Program_Error with
245 "attempt to tamper with elements (set is busy)";
246 end if;
248 pragma Assert (Vet (Position), "Position cursor is bad");
250 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
252 Free (Position.Node);
253 Position.Container := null;
254 end Delete;
256 ----------------
257 -- Difference --
258 ----------------
260 procedure Difference
261 (Target : in out Set;
262 Source : Set)
264 Tgt_Node : Node_Access;
266 begin
267 if Target'Address = Source'Address then
268 Clear (Target);
269 return;
270 end if;
272 if Source.HT.Length = 0 then
273 return;
274 end if;
276 if Target.HT.Busy > 0 then
277 raise Program_Error with
278 "attempt to tamper with elements (set is busy)";
279 end if;
281 if Source.HT.Length < Target.HT.Length then
282 declare
283 Src_Node : Node_Access;
285 begin
286 Src_Node := HT_Ops.First (Source.HT);
287 while Src_Node /= null loop
288 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
290 if Tgt_Node /= null then
291 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
292 Free (Tgt_Node);
293 end if;
295 Src_Node := HT_Ops.Next (Source.HT, Src_Node);
296 end loop;
297 end;
299 else
300 Tgt_Node := HT_Ops.First (Target.HT);
301 while Tgt_Node /= null loop
302 if Is_In (Source.HT, Tgt_Node) then
303 declare
304 X : Node_Access := Tgt_Node;
305 begin
306 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
307 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
308 Free (X);
309 end;
311 else
312 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
313 end if;
314 end loop;
315 end if;
316 end Difference;
318 function Difference (Left, Right : Set) return Set is
319 Buckets : HT_Types.Buckets_Access;
320 Length : Count_Type;
322 begin
323 if Left'Address = Right'Address then
324 return Empty_Set;
325 end if;
327 if Left.Length = 0 then
328 return Empty_Set;
329 end if;
331 if Right.Length = 0 then
332 return Left;
333 end if;
335 declare
336 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
337 begin
338 Buckets := HT_Ops.New_Buckets (Length => Size);
339 end;
341 Length := 0;
343 Iterate_Left : declare
344 procedure Process (L_Node : Node_Access);
346 procedure Iterate is
347 new HT_Ops.Generic_Iteration (Process);
349 -------------
350 -- Process --
351 -------------
353 procedure Process (L_Node : Node_Access) is
354 begin
355 if not Is_In (Right.HT, L_Node) then
356 declare
357 Src : Element_Type renames L_Node.Element.all;
358 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
359 Bucket : Node_Access renames Buckets (Indx);
360 Tgt : Element_Access := new Element_Type'(Src);
361 begin
362 Bucket := new Node_Type'(Tgt, Bucket);
363 exception
364 when others =>
365 Free_Element (Tgt);
366 raise;
367 end;
369 Length := Length + 1;
370 end if;
371 end Process;
373 -- Start of processing for Iterate_Left
375 begin
376 Iterate (Left.HT);
377 exception
378 when others =>
379 HT_Ops.Free_Hash_Table (Buckets);
380 raise;
381 end Iterate_Left;
383 return (Controlled with HT => (Buckets, Length, 0, 0));
384 end Difference;
386 -------------
387 -- Element --
388 -------------
390 function Element (Position : Cursor) return Element_Type is
391 begin
392 if Position.Node = null then
393 raise Constraint_Error with "Position cursor of equals No_Element";
394 end if;
396 if Position.Node.Element = null then -- handle dangling reference
397 raise Program_Error with "Position cursor is bad";
398 end if;
400 pragma Assert (Vet (Position), "bad cursor in function Element");
402 return Position.Node.Element.all;
403 end Element;
405 ---------------------
406 -- Equivalent_Sets --
407 ---------------------
409 function Equivalent_Sets (Left, Right : Set) return Boolean is
410 begin
411 return Is_Equivalent (Left.HT, Right.HT);
412 end Equivalent_Sets;
414 -------------------------
415 -- Equivalent_Elements --
416 -------------------------
418 function Equivalent_Elements (Left, Right : Cursor)
419 return Boolean is
420 begin
421 if Left.Node = null then
422 raise Constraint_Error with
423 "Left cursor of Equivalent_Elements equals No_Element";
424 end if;
426 if Right.Node = null then
427 raise Constraint_Error with
428 "Right cursor of Equivalent_Elements equals No_Element";
429 end if;
431 if Left.Node.Element = null then
432 raise Program_Error with
433 "Left cursor of Equivalent_Elements is bad";
434 end if;
436 if Right.Node.Element = null then
437 raise Program_Error with
438 "Right cursor of Equivalent_Elements is bad";
439 end if;
441 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
442 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
444 return Equivalent_Elements
445 (Left.Node.Element.all,
446 Right.Node.Element.all);
447 end Equivalent_Elements;
449 function Equivalent_Elements (Left : Cursor; Right : Element_Type)
450 return Boolean is
451 begin
452 if Left.Node = null then
453 raise Constraint_Error with
454 "Left cursor of Equivalent_Elements equals No_Element";
455 end if;
457 if Left.Node.Element = null then
458 raise Program_Error with
459 "Left cursor of Equivalent_Elements is bad";
460 end if;
462 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
464 return Equivalent_Elements (Left.Node.Element.all, Right);
465 end Equivalent_Elements;
467 function Equivalent_Elements (Left : Element_Type; Right : Cursor)
468 return Boolean is
469 begin
470 if Right.Node = null then
471 raise Constraint_Error with
472 "Right cursor of Equivalent_Elements equals No_Element";
473 end if;
475 if Right.Node.Element = null then
476 raise Program_Error with
477 "Right cursor of Equivalent_Elements is bad";
478 end if;
480 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
482 return Equivalent_Elements (Left, Right.Node.Element.all);
483 end Equivalent_Elements;
485 ---------------------
486 -- Equivalent_Keys --
487 ---------------------
489 function Equivalent_Keys (Key : Element_Type; Node : Node_Access)
490 return Boolean is
491 begin
492 return Equivalent_Elements (Key, Node.Element.all);
493 end Equivalent_Keys;
495 -------------
496 -- Exclude --
497 -------------
499 procedure Exclude
500 (Container : in out Set;
501 Item : Element_Type)
503 X : Node_Access;
504 begin
505 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
506 Free (X);
507 end Exclude;
509 --------------
510 -- Finalize --
511 --------------
513 procedure Finalize (Container : in out Set) is
514 begin
515 HT_Ops.Finalize (Container.HT);
516 end Finalize;
518 ----------
519 -- Find --
520 ----------
522 function Find
523 (Container : Set;
524 Item : Element_Type) return Cursor
526 Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
528 begin
529 if Node = null then
530 return No_Element;
531 end if;
533 return Cursor'(Container'Unrestricted_Access, Node);
534 end Find;
536 --------------------
537 -- Find_Equal_Key --
538 --------------------
540 function Find_Equal_Key
541 (R_HT : Hash_Table_Type;
542 L_Node : Node_Access) return Boolean
544 R_Index : constant Hash_Type :=
545 Element_Keys.Index (R_HT, L_Node.Element.all);
547 R_Node : Node_Access := R_HT.Buckets (R_Index);
549 begin
550 loop
551 if R_Node = null then
552 return False;
553 end if;
555 if L_Node.Element.all = R_Node.Element.all then
556 return True;
557 end if;
559 R_Node := Next (R_Node);
560 end loop;
561 end Find_Equal_Key;
563 -------------------------
564 -- Find_Equivalent_Key --
565 -------------------------
567 function Find_Equivalent_Key
568 (R_HT : Hash_Table_Type;
569 L_Node : Node_Access) return Boolean
571 R_Index : constant Hash_Type :=
572 Element_Keys.Index (R_HT, L_Node.Element.all);
574 R_Node : Node_Access := R_HT.Buckets (R_Index);
576 begin
577 loop
578 if R_Node = null then
579 return False;
580 end if;
582 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
583 return True;
584 end if;
586 R_Node := Next (R_Node);
587 end loop;
588 end Find_Equivalent_Key;
590 -----------
591 -- First --
592 -----------
594 function First (Container : Set) return Cursor is
595 Node : constant Node_Access := HT_Ops.First (Container.HT);
597 begin
598 if Node = null then
599 return No_Element;
600 end if;
602 return Cursor'(Container'Unrestricted_Access, Node);
603 end First;
605 ----------
606 -- Free --
607 ----------
609 procedure Free (X : in out Node_Access) is
610 procedure Deallocate is
611 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
613 begin
614 if X = null then
615 return;
616 end if;
618 X.Next := X; -- detect mischief (in Vet)
620 begin
621 Free_Element (X.Element);
622 exception
623 when others =>
624 X.Element := null;
625 Deallocate (X);
626 raise;
627 end;
629 Deallocate (X);
630 end Free;
632 -----------------
633 -- Has_Element --
634 -----------------
636 function Has_Element (Position : Cursor) return Boolean is
637 begin
638 pragma Assert (Vet (Position), "bad cursor in Has_Element");
639 return Position.Node /= null;
640 end Has_Element;
642 ---------------
643 -- Hash_Node --
644 ---------------
646 function Hash_Node (Node : Node_Access) return Hash_Type is
647 begin
648 return Hash (Node.Element.all);
649 end Hash_Node;
651 -------------
652 -- Include --
653 -------------
655 procedure Include
656 (Container : in out Set;
657 New_Item : Element_Type)
659 Position : Cursor;
660 Inserted : Boolean;
662 X : Element_Access;
664 begin
665 Insert (Container, New_Item, Position, Inserted);
667 if not Inserted then
668 if Container.HT.Lock > 0 then
669 raise Program_Error with
670 "attempt to tamper with cursors (set is locked)";
671 end if;
673 X := Position.Node.Element;
675 Position.Node.Element := new Element_Type'(New_Item);
677 Free_Element (X);
678 end if;
679 end Include;
681 ------------
682 -- Insert --
683 ------------
685 procedure Insert
686 (Container : in out Set;
687 New_Item : Element_Type;
688 Position : out Cursor;
689 Inserted : out Boolean)
691 begin
692 Insert (Container.HT, New_Item, Position.Node, Inserted);
693 Position.Container := Container'Unchecked_Access;
694 end Insert;
696 procedure Insert
697 (Container : in out Set;
698 New_Item : Element_Type)
700 Position : Cursor;
701 pragma Unreferenced (Position);
703 Inserted : Boolean;
705 begin
706 Insert (Container, New_Item, Position, Inserted);
708 if not Inserted then
709 raise Constraint_Error with
710 "attempt to insert element already in set";
711 end if;
712 end Insert;
714 procedure Insert
715 (HT : in out Hash_Table_Type;
716 New_Item : Element_Type;
717 Node : out Node_Access;
718 Inserted : out Boolean)
720 function New_Node (Next : Node_Access) return Node_Access;
721 pragma Inline (New_Node);
723 procedure Local_Insert is
724 new Element_Keys.Generic_Conditional_Insert (New_Node);
726 --------------
727 -- New_Node --
728 --------------
730 function New_Node (Next : Node_Access) return Node_Access is
731 Element : Element_Access := new Element_Type'(New_Item);
733 begin
734 return new Node_Type'(Element, Next);
735 exception
736 when others =>
737 Free_Element (Element);
738 raise;
739 end New_Node;
741 -- Start of processing for Insert
743 begin
744 if HT_Ops.Capacity (HT) = 0 then
745 HT_Ops.Reserve_Capacity (HT, 1);
746 end if;
748 Local_Insert (HT, New_Item, Node, Inserted);
750 if Inserted
751 and then HT.Length > HT_Ops.Capacity (HT)
752 then
753 HT_Ops.Reserve_Capacity (HT, HT.Length);
754 end if;
755 end Insert;
757 ------------------
758 -- Intersection --
759 ------------------
761 procedure Intersection
762 (Target : in out Set;
763 Source : Set)
765 Tgt_Node : Node_Access;
767 begin
768 if Target'Address = Source'Address then
769 return;
770 end if;
772 if Source.Length = 0 then
773 Clear (Target);
774 return;
775 end if;
777 if Target.HT.Busy > 0 then
778 raise Program_Error with
779 "attempt to tamper with elements (set is busy)";
780 end if;
782 Tgt_Node := HT_Ops.First (Target.HT);
783 while Tgt_Node /= null loop
784 if Is_In (Source.HT, Tgt_Node) then
785 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
787 else
788 declare
789 X : Node_Access := Tgt_Node;
790 begin
791 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
792 HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
793 Free (X);
794 end;
795 end if;
796 end loop;
797 end Intersection;
799 function Intersection (Left, Right : Set) return Set is
800 Buckets : HT_Types.Buckets_Access;
801 Length : Count_Type;
803 begin
804 if Left'Address = Right'Address then
805 return Left;
806 end if;
808 Length := Count_Type'Min (Left.Length, Right.Length);
810 if Length = 0 then
811 return Empty_Set;
812 end if;
814 declare
815 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
816 begin
817 Buckets := HT_Ops.New_Buckets (Length => Size);
818 end;
820 Length := 0;
822 Iterate_Left : declare
823 procedure Process (L_Node : Node_Access);
825 procedure Iterate is
826 new HT_Ops.Generic_Iteration (Process);
828 -------------
829 -- Process --
830 -------------
832 procedure Process (L_Node : Node_Access) is
833 begin
834 if Is_In (Right.HT, L_Node) then
835 declare
836 Src : Element_Type renames L_Node.Element.all;
838 Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
840 Bucket : Node_Access renames Buckets (Indx);
842 Tgt : Element_Access := new Element_Type'(Src);
844 begin
845 Bucket := new Node_Type'(Tgt, Bucket);
846 exception
847 when others =>
848 Free_Element (Tgt);
849 raise;
850 end;
852 Length := Length + 1;
853 end if;
854 end Process;
856 -- Start of processing for Iterate_Left
858 begin
859 Iterate (Left.HT);
860 exception
861 when others =>
862 HT_Ops.Free_Hash_Table (Buckets);
863 raise;
864 end Iterate_Left;
866 return (Controlled with HT => (Buckets, Length, 0, 0));
867 end Intersection;
869 --------------
870 -- Is_Empty --
871 --------------
873 function Is_Empty (Container : Set) return Boolean is
874 begin
875 return Container.HT.Length = 0;
876 end Is_Empty;
878 -----------
879 -- Is_In --
880 -----------
882 function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is
883 begin
884 return Element_Keys.Find (HT, Key.Element.all) /= null;
885 end Is_In;
887 ---------------
888 -- Is_Subset --
889 ---------------
891 function Is_Subset
892 (Subset : Set;
893 Of_Set : Set) return Boolean
895 Subset_Node : Node_Access;
897 begin
898 if Subset'Address = Of_Set'Address then
899 return True;
900 end if;
902 if Subset.Length > Of_Set.Length then
903 return False;
904 end if;
906 Subset_Node := HT_Ops.First (Subset.HT);
907 while Subset_Node /= null loop
908 if not Is_In (Of_Set.HT, Subset_Node) then
909 return False;
910 end if;
912 Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
913 end loop;
915 return True;
916 end Is_Subset;
918 -------------
919 -- Iterate --
920 -------------
922 procedure Iterate
923 (Container : Set;
924 Process : not null access procedure (Position : Cursor))
926 procedure Process_Node (Node : Node_Access);
927 pragma Inline (Process_Node);
929 procedure Iterate is
930 new HT_Ops.Generic_Iteration (Process_Node);
932 ------------------
933 -- Process_Node --
934 ------------------
936 procedure Process_Node (Node : Node_Access) is
937 begin
938 Process (Cursor'(Container'Unrestricted_Access, Node));
939 end Process_Node;
941 B : Natural renames Container'Unrestricted_Access.HT.Busy;
943 -- Start of processing for Iterate
945 begin
946 B := B + 1;
948 begin
949 Iterate (Container.HT);
950 exception
951 when others =>
952 B := B - 1;
953 raise;
954 end;
956 B := B - 1;
957 end Iterate;
959 ------------
960 -- Length --
961 ------------
963 function Length (Container : Set) return Count_Type is
964 begin
965 return Container.HT.Length;
966 end Length;
968 ----------
969 -- Move --
970 ----------
972 procedure Move (Target : in out Set; Source : in out Set) is
973 begin
974 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
975 end Move;
977 ----------
978 -- Next --
979 ----------
981 function Next (Node : Node_Access) return Node_Access is
982 begin
983 return Node.Next;
984 end Next;
986 function Next (Position : Cursor) return Cursor is
987 begin
988 if Position.Node = null then
989 return No_Element;
990 end if;
992 if Position.Node.Element = null then
993 raise Program_Error with "bad cursor in Next";
994 end if;
996 pragma Assert (Vet (Position), "bad cursor in Next");
998 declare
999 HT : Hash_Table_Type renames Position.Container.HT;
1000 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1002 begin
1003 if Node = null then
1004 return No_Element;
1005 end if;
1007 return Cursor'(Position.Container, Node);
1008 end;
1009 end Next;
1011 procedure Next (Position : in out Cursor) is
1012 begin
1013 Position := Next (Position);
1014 end Next;
1016 -------------
1017 -- Overlap --
1018 -------------
1020 function Overlap (Left, Right : Set) return Boolean is
1021 Left_Node : Node_Access;
1023 begin
1024 if Right.Length = 0 then
1025 return False;
1026 end if;
1028 if Left'Address = Right'Address then
1029 return True;
1030 end if;
1032 Left_Node := HT_Ops.First (Left.HT);
1033 while Left_Node /= null loop
1034 if Is_In (Right.HT, Left_Node) then
1035 return True;
1036 end if;
1038 Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1039 end loop;
1041 return False;
1042 end Overlap;
1044 -------------------
1045 -- Query_Element --
1046 -------------------
1048 procedure Query_Element
1049 (Position : Cursor;
1050 Process : not null access procedure (Element : Element_Type))
1052 begin
1053 if Position.Node = null then
1054 raise Constraint_Error with
1055 "Position cursor of Query_Element equals No_Element";
1056 end if;
1058 if Position.Node.Element = null then
1059 raise Program_Error with "bad cursor in Query_Element";
1060 end if;
1062 pragma Assert (Vet (Position), "bad cursor in Query_Element");
1064 declare
1065 HT : Hash_Table_Type renames
1066 Position.Container'Unrestricted_Access.all.HT;
1068 B : Natural renames HT.Busy;
1069 L : Natural renames HT.Lock;
1071 begin
1072 B := B + 1;
1073 L := L + 1;
1075 begin
1076 Process (Position.Node.Element.all);
1077 exception
1078 when others =>
1079 L := L - 1;
1080 B := B - 1;
1081 raise;
1082 end;
1084 L := L - 1;
1085 B := B - 1;
1086 end;
1087 end Query_Element;
1089 ----------
1090 -- Read --
1091 ----------
1093 procedure Read
1094 (Stream : not null access Root_Stream_Type'Class;
1095 Container : out Set)
1097 begin
1098 Read_Nodes (Stream, Container.HT);
1099 end Read;
1101 procedure Read
1102 (Stream : not null access Root_Stream_Type'Class;
1103 Item : out Cursor)
1105 begin
1106 raise Program_Error with "attempt to stream set cursor";
1107 end Read;
1109 ---------------
1110 -- Read_Node --
1111 ---------------
1113 function Read_Node
1114 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1116 X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1118 begin
1119 return new Node_Type'(X, null);
1120 exception
1121 when others =>
1122 Free_Element (X);
1123 raise;
1124 end Read_Node;
1126 -------------
1127 -- Replace --
1128 -------------
1130 procedure Replace
1131 (Container : in out Set;
1132 New_Item : Element_Type)
1134 Node : constant Node_Access :=
1135 Element_Keys.Find (Container.HT, New_Item);
1137 X : Element_Access;
1138 pragma Warnings (Off, X);
1140 begin
1141 if Node = null then
1142 raise Constraint_Error with
1143 "attempt to replace element not in set";
1144 end if;
1146 if Container.HT.Lock > 0 then
1147 raise Program_Error with
1148 "attempt to tamper with cursors (set is locked)";
1149 end if;
1151 X := Node.Element;
1153 Node.Element := new Element_Type'(New_Item);
1155 Free_Element (X);
1156 end Replace;
1158 ---------------------
1159 -- Replace_Element --
1160 ---------------------
1162 procedure Replace_Element
1163 (Container : in out Set;
1164 Position : Cursor;
1165 New_Item : Element_Type)
1167 begin
1168 if Position.Node = null then
1169 raise Constraint_Error with "Position cursor equals No_Element";
1170 end if;
1172 if Position.Node.Element = null then
1173 raise Program_Error with "bad cursor in Replace_Element";
1174 end if;
1176 if Position.Container /= Container'Unrestricted_Access then
1177 raise Program_Error with
1178 "Position cursor designates wrong set";
1179 end if;
1181 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1183 Replace_Element (Container.HT, Position.Node, New_Item);
1184 end Replace_Element;
1186 ----------------------
1187 -- Reserve_Capacity --
1188 ----------------------
1190 procedure Reserve_Capacity
1191 (Container : in out Set;
1192 Capacity : Count_Type)
1194 begin
1195 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1196 end Reserve_Capacity;
1198 --------------
1199 -- Set_Next --
1200 --------------
1202 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1203 begin
1204 Node.Next := Next;
1205 end Set_Next;
1207 --------------------------
1208 -- Symmetric_Difference --
1209 --------------------------
1211 procedure Symmetric_Difference
1212 (Target : in out Set;
1213 Source : Set)
1215 begin
1216 if Target'Address = Source'Address then
1217 Clear (Target);
1218 return;
1219 end if;
1221 if Target.HT.Busy > 0 then
1222 raise Program_Error with
1223 "attempt to tamper with elements (set is busy)";
1224 end if;
1226 declare
1227 N : constant Count_Type := Target.Length + Source.Length;
1228 begin
1229 if N > HT_Ops.Capacity (Target.HT) then
1230 HT_Ops.Reserve_Capacity (Target.HT, N);
1231 end if;
1232 end;
1234 if Target.Length = 0 then
1235 Iterate_Source_When_Empty_Target : declare
1236 procedure Process (Src_Node : Node_Access);
1238 procedure Iterate is
1239 new HT_Ops.Generic_Iteration (Process);
1241 -------------
1242 -- Process --
1243 -------------
1245 procedure Process (Src_Node : Node_Access) is
1246 E : Element_Type renames Src_Node.Element.all;
1247 B : Buckets_Type renames Target.HT.Buckets.all;
1248 J : constant Hash_Type := Hash (E) mod B'Length;
1249 N : Count_Type renames Target.HT.Length;
1251 begin
1252 declare
1253 X : Element_Access := new Element_Type'(E);
1254 begin
1255 B (J) := new Node_Type'(X, B (J));
1256 exception
1257 when others =>
1258 Free_Element (X);
1259 raise;
1260 end;
1262 N := N + 1;
1263 end Process;
1265 -- Start of processing for Iterate_Source_When_Empty_Target
1267 begin
1268 Iterate (Source.HT);
1269 end Iterate_Source_When_Empty_Target;
1271 else
1272 Iterate_Source : declare
1273 procedure Process (Src_Node : Node_Access);
1275 procedure Iterate is
1276 new HT_Ops.Generic_Iteration (Process);
1278 -------------
1279 -- Process --
1280 -------------
1282 procedure Process (Src_Node : Node_Access) is
1283 E : Element_Type renames Src_Node.Element.all;
1284 B : Buckets_Type renames Target.HT.Buckets.all;
1285 J : constant Hash_Type := Hash (E) mod B'Length;
1286 N : Count_Type renames Target.HT.Length;
1288 begin
1289 if B (J) = null then
1290 declare
1291 X : Element_Access := new Element_Type'(E);
1292 begin
1293 B (J) := new Node_Type'(X, null);
1294 exception
1295 when others =>
1296 Free_Element (X);
1297 raise;
1298 end;
1300 N := N + 1;
1302 elsif Equivalent_Elements (E, B (J).Element.all) then
1303 declare
1304 X : Node_Access := B (J);
1305 begin
1306 B (J) := B (J).Next;
1307 N := N - 1;
1308 Free (X);
1309 end;
1311 else
1312 declare
1313 Prev : Node_Access := B (J);
1314 Curr : Node_Access := Prev.Next;
1316 begin
1317 while Curr /= null loop
1318 if Equivalent_Elements (E, Curr.Element.all) then
1319 Prev.Next := Curr.Next;
1320 N := N - 1;
1321 Free (Curr);
1322 return;
1323 end if;
1325 Prev := Curr;
1326 Curr := Prev.Next;
1327 end loop;
1329 declare
1330 X : Element_Access := new Element_Type'(E);
1331 begin
1332 B (J) := new Node_Type'(X, B (J));
1333 exception
1334 when others =>
1335 Free_Element (X);
1336 raise;
1337 end;
1339 N := N + 1;
1340 end;
1341 end if;
1342 end Process;
1344 -- Start of processing for Iterate_Source
1346 begin
1347 Iterate (Source.HT);
1348 end Iterate_Source;
1349 end if;
1350 end Symmetric_Difference;
1352 function Symmetric_Difference (Left, Right : Set) return Set is
1353 Buckets : HT_Types.Buckets_Access;
1354 Length : Count_Type;
1356 begin
1357 if Left'Address = Right'Address then
1358 return Empty_Set;
1359 end if;
1361 if Right.Length = 0 then
1362 return Left;
1363 end if;
1365 if Left.Length = 0 then
1366 return Right;
1367 end if;
1369 declare
1370 Size : constant Hash_Type :=
1371 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1372 begin
1373 Buckets := HT_Ops.New_Buckets (Length => Size);
1374 end;
1376 Length := 0;
1378 Iterate_Left : declare
1379 procedure Process (L_Node : Node_Access);
1381 procedure Iterate is
1382 new HT_Ops.Generic_Iteration (Process);
1384 -------------
1385 -- Process --
1386 -------------
1388 procedure Process (L_Node : Node_Access) is
1389 begin
1390 if not Is_In (Right.HT, L_Node) then
1391 declare
1392 E : Element_Type renames L_Node.Element.all;
1393 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1395 begin
1396 declare
1397 X : Element_Access := new Element_Type'(E);
1398 begin
1399 Buckets (J) := new Node_Type'(X, Buckets (J));
1400 exception
1401 when others =>
1402 Free_Element (X);
1403 raise;
1404 end;
1406 Length := Length + 1;
1407 end;
1408 end if;
1409 end Process;
1411 -- Start of processing for Iterate_Left
1413 begin
1414 Iterate (Left.HT);
1415 exception
1416 when others =>
1417 HT_Ops.Free_Hash_Table (Buckets);
1418 raise;
1419 end Iterate_Left;
1421 Iterate_Right : declare
1422 procedure Process (R_Node : Node_Access);
1424 procedure Iterate is
1425 new HT_Ops.Generic_Iteration (Process);
1427 -------------
1428 -- Process --
1429 -------------
1431 procedure Process (R_Node : Node_Access) is
1432 begin
1433 if not Is_In (Left.HT, R_Node) then
1434 declare
1435 E : Element_Type renames R_Node.Element.all;
1436 J : constant Hash_Type := Hash (E) mod Buckets'Length;
1438 begin
1439 declare
1440 X : Element_Access := new Element_Type'(E);
1441 begin
1442 Buckets (J) := new Node_Type'(X, Buckets (J));
1443 exception
1444 when others =>
1445 Free_Element (X);
1446 raise;
1447 end;
1449 Length := Length + 1;
1450 end;
1451 end if;
1452 end Process;
1454 -- Start of processing for Iterate_Right
1456 begin
1457 Iterate (Right.HT);
1458 exception
1459 when others =>
1460 HT_Ops.Free_Hash_Table (Buckets);
1461 raise;
1462 end Iterate_Right;
1464 return (Controlled with HT => (Buckets, Length, 0, 0));
1465 end Symmetric_Difference;
1467 ------------
1468 -- To_Set --
1469 ------------
1471 function To_Set (New_Item : Element_Type) return Set is
1472 HT : Hash_Table_Type;
1474 Node : Node_Access;
1475 Inserted : Boolean;
1476 pragma Unreferenced (Node, Inserted);
1478 begin
1479 Insert (HT, New_Item, Node, Inserted);
1480 return Set'(Controlled with HT);
1481 end To_Set;
1483 -----------
1484 -- Union --
1485 -----------
1487 procedure Union
1488 (Target : in out Set;
1489 Source : Set)
1491 procedure Process (Src_Node : Node_Access);
1493 procedure Iterate is
1494 new HT_Ops.Generic_Iteration (Process);
1496 -------------
1497 -- Process --
1498 -------------
1500 procedure Process (Src_Node : Node_Access) is
1501 Src : Element_Type renames Src_Node.Element.all;
1503 function New_Node (Next : Node_Access) return Node_Access;
1504 pragma Inline (New_Node);
1506 procedure Insert is
1507 new Element_Keys.Generic_Conditional_Insert (New_Node);
1509 --------------
1510 -- New_Node --
1511 --------------
1513 function New_Node (Next : Node_Access) return Node_Access is
1514 Tgt : Element_Access := new Element_Type'(Src);
1516 begin
1517 return new Node_Type'(Tgt, Next);
1518 exception
1519 when others =>
1520 Free_Element (Tgt);
1521 raise;
1522 end New_Node;
1524 Tgt_Node : Node_Access;
1525 Success : Boolean;
1526 pragma Unreferenced (Tgt_Node, Success);
1528 -- Start of processing for Process
1530 begin
1531 Insert (Target.HT, Src, Tgt_Node, Success);
1532 end Process;
1534 -- Start of processing for Union
1536 begin
1537 if Target'Address = Source'Address then
1538 return;
1539 end if;
1541 if Target.HT.Busy > 0 then
1542 raise Program_Error with
1543 "attempt to tamper with elements (set is busy)";
1544 end if;
1546 declare
1547 N : constant Count_Type := Target.Length + Source.Length;
1548 begin
1549 if N > HT_Ops.Capacity (Target.HT) then
1550 HT_Ops.Reserve_Capacity (Target.HT, N);
1551 end if;
1552 end;
1554 Iterate (Source.HT);
1555 end Union;
1557 function Union (Left, Right : Set) return Set is
1558 Buckets : HT_Types.Buckets_Access;
1559 Length : Count_Type;
1561 begin
1562 if Left'Address = Right'Address then
1563 return Left;
1564 end if;
1566 if Right.Length = 0 then
1567 return Left;
1568 end if;
1570 if Left.Length = 0 then
1571 return Right;
1572 end if;
1574 declare
1575 Size : constant Hash_Type :=
1576 Prime_Numbers.To_Prime (Left.Length + Right.Length);
1577 begin
1578 Buckets := HT_Ops.New_Buckets (Length => Size);
1579 end;
1581 Iterate_Left : declare
1582 procedure Process (L_Node : Node_Access);
1584 procedure Iterate is
1585 new HT_Ops.Generic_Iteration (Process);
1587 -------------
1588 -- Process --
1589 -------------
1591 procedure Process (L_Node : Node_Access) is
1592 Src : Element_Type renames L_Node.Element.all;
1594 J : constant Hash_Type := Hash (Src) mod Buckets'Length;
1596 Bucket : Node_Access renames Buckets (J);
1598 Tgt : Element_Access := new Element_Type'(Src);
1600 begin
1601 Bucket := new Node_Type'(Tgt, Bucket);
1602 exception
1603 when others =>
1604 Free_Element (Tgt);
1605 raise;
1606 end Process;
1608 -- Start of processing for Process
1610 begin
1611 Iterate (Left.HT);
1612 exception
1613 when others =>
1614 HT_Ops.Free_Hash_Table (Buckets);
1615 raise;
1616 end Iterate_Left;
1618 Length := Left.Length;
1620 Iterate_Right : declare
1621 procedure Process (Src_Node : Node_Access);
1623 procedure Iterate is
1624 new HT_Ops.Generic_Iteration (Process);
1626 -------------
1627 -- Process --
1628 -------------
1630 procedure Process (Src_Node : Node_Access) is
1631 Src : Element_Type renames Src_Node.Element.all;
1632 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1634 Tgt_Node : Node_Access := Buckets (Idx);
1636 begin
1637 while Tgt_Node /= null loop
1638 if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1639 return;
1640 end if;
1641 Tgt_Node := Next (Tgt_Node);
1642 end loop;
1644 declare
1645 Tgt : Element_Access := new Element_Type'(Src);
1646 begin
1647 Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1648 exception
1649 when others =>
1650 Free_Element (Tgt);
1651 raise;
1652 end;
1654 Length := Length + 1;
1655 end Process;
1657 -- Start of processing for Iterate_Right
1659 begin
1660 Iterate (Right.HT);
1661 exception
1662 when others =>
1663 HT_Ops.Free_Hash_Table (Buckets);
1664 raise;
1665 end Iterate_Right;
1667 return (Controlled with HT => (Buckets, Length, 0, 0));
1668 end Union;
1670 ---------
1671 -- Vet --
1672 ---------
1674 function Vet (Position : Cursor) return Boolean is
1675 begin
1676 if Position.Node = null then
1677 return Position.Container = null;
1678 end if;
1680 if Position.Container = null then
1681 return False;
1682 end if;
1684 if Position.Node.Next = Position.Node then
1685 return False;
1686 end if;
1688 if Position.Node.Element = null then
1689 return False;
1690 end if;
1692 declare
1693 HT : Hash_Table_Type renames Position.Container.HT;
1694 X : Node_Access;
1696 begin
1697 if HT.Length = 0 then
1698 return False;
1699 end if;
1701 if HT.Buckets = null
1702 or else HT.Buckets'Length = 0
1703 then
1704 return False;
1705 end if;
1707 X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1709 for J in 1 .. HT.Length loop
1710 if X = Position.Node then
1711 return True;
1712 end if;
1714 if X = null then
1715 return False;
1716 end if;
1718 if X = X.Next then -- to prevent unnecessary looping
1719 return False;
1720 end if;
1722 X := X.Next;
1723 end loop;
1725 return False;
1726 end;
1727 end Vet;
1729 -----------
1730 -- Write --
1731 -----------
1733 procedure Write
1734 (Stream : not null access Root_Stream_Type'Class;
1735 Container : Set)
1737 begin
1738 Write_Nodes (Stream, Container.HT);
1739 end Write;
1741 procedure Write
1742 (Stream : not null access Root_Stream_Type'Class;
1743 Item : Cursor)
1745 begin
1746 raise Program_Error with "attempt to stream set cursor";
1747 end Write;
1749 ----------------
1750 -- Write_Node --
1751 ----------------
1753 procedure Write_Node
1754 (Stream : not null access Root_Stream_Type'Class;
1755 Node : Node_Access)
1757 begin
1758 Element_Type'Output (Stream, Node.Element.all);
1759 end Write_Node;
1761 package body Generic_Keys is
1763 -----------------------
1764 -- Local Subprograms --
1765 -----------------------
1767 function Equivalent_Key_Node
1768 (Key : Key_Type;
1769 Node : Node_Access) return Boolean;
1770 pragma Inline (Equivalent_Key_Node);
1772 --------------------------
1773 -- Local Instantiations --
1774 --------------------------
1776 package Key_Keys is
1777 new Hash_Tables.Generic_Keys
1778 (HT_Types => HT_Types,
1779 Next => Next,
1780 Set_Next => Set_Next,
1781 Key_Type => Key_Type,
1782 Hash => Hash,
1783 Equivalent_Keys => Equivalent_Key_Node);
1785 --------------
1786 -- Contains --
1787 --------------
1789 function Contains
1790 (Container : Set;
1791 Key : Key_Type) return Boolean
1793 begin
1794 return Find (Container, Key) /= No_Element;
1795 end Contains;
1797 ------------
1798 -- Delete --
1799 ------------
1801 procedure Delete
1802 (Container : in out Set;
1803 Key : Key_Type)
1805 X : Node_Access;
1807 begin
1808 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1810 if X = null then
1811 raise Constraint_Error with "key not in map";
1812 end if;
1814 Free (X);
1815 end Delete;
1817 -------------
1818 -- Element --
1819 -------------
1821 function Element
1822 (Container : Set;
1823 Key : Key_Type) return Element_Type
1825 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1827 begin
1828 if Node = null then
1829 raise Constraint_Error with "key not in map";
1830 end if;
1832 return Node.Element.all;
1833 end Element;
1835 -------------------------
1836 -- Equivalent_Key_Node --
1837 -------------------------
1839 function Equivalent_Key_Node
1840 (Key : Key_Type;
1841 Node : Node_Access) return Boolean is
1842 begin
1843 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
1844 end Equivalent_Key_Node;
1846 -------------
1847 -- Exclude --
1848 -------------
1850 procedure Exclude
1851 (Container : in out Set;
1852 Key : Key_Type)
1854 X : Node_Access;
1855 begin
1856 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
1857 Free (X);
1858 end Exclude;
1860 ----------
1861 -- Find --
1862 ----------
1864 function Find
1865 (Container : Set;
1866 Key : Key_Type) return Cursor
1868 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
1870 begin
1871 if Node = null then
1872 return No_Element;
1873 end if;
1875 return Cursor'(Container'Unrestricted_Access, Node);
1876 end Find;
1878 ---------
1879 -- Key --
1880 ---------
1882 function Key (Position : Cursor) return Key_Type is
1883 begin
1884 if Position.Node = null then
1885 raise Constraint_Error with
1886 "Position cursor equals No_Element";
1887 end if;
1889 if Position.Node.Element = null then
1890 raise Program_Error with "Position cursor is bad";
1891 end if;
1893 pragma Assert (Vet (Position), "bad cursor in function Key");
1895 return Key (Position.Node.Element.all);
1896 end Key;
1898 -------------
1899 -- Replace --
1900 -------------
1902 procedure Replace
1903 (Container : in out Set;
1904 Key : Key_Type;
1905 New_Item : Element_Type)
1907 Node : constant Node_Access :=
1908 Key_Keys.Find (Container.HT, Key);
1910 begin
1911 if Node = null then
1912 raise Constraint_Error with
1913 "attempt to replace key not in set";
1914 end if;
1916 Replace_Element (Container.HT, Node, New_Item);
1917 end Replace;
1919 procedure Update_Element_Preserving_Key
1920 (Container : in out Set;
1921 Position : Cursor;
1922 Process : not null access
1923 procedure (Element : in out Element_Type))
1925 HT : Hash_Table_Type renames Container.HT;
1926 Indx : Hash_Type;
1928 begin
1929 if Position.Node = null then
1930 raise Constraint_Error with
1931 "Position cursor equals No_Element";
1932 end if;
1934 if Position.Node.Element = null
1935 or else Position.Node.Next = Position.Node
1936 then
1937 raise Program_Error with "Position cursor is bad";
1938 end if;
1940 if Position.Container /= Container'Unrestricted_Access then
1941 raise Program_Error with
1942 "Position cursor designates wrong set";
1943 end if;
1945 if HT.Buckets = null
1946 or else HT.Buckets'Length = 0
1947 or else HT.Length = 0
1948 then
1949 raise Program_Error with "Position cursor is bad (set is empty)";
1950 end if;
1952 pragma Assert
1953 (Vet (Position),
1954 "bad cursor in Update_Element_Preserving_Key");
1956 Indx := HT_Ops.Index (HT, Position.Node);
1958 declare
1959 E : Element_Type renames Position.Node.Element.all;
1960 K : constant Key_Type := Key (E);
1962 B : Natural renames HT.Busy;
1963 L : Natural renames HT.Lock;
1965 begin
1966 B := B + 1;
1967 L := L + 1;
1969 begin
1970 Process (E);
1971 exception
1972 when others =>
1973 L := L - 1;
1974 B := B - 1;
1975 raise;
1976 end;
1978 L := L - 1;
1979 B := B - 1;
1981 if Equivalent_Keys (K, Key (E)) then
1982 pragma Assert (Hash (K) = Hash (E));
1983 return;
1984 end if;
1985 end;
1987 if HT.Buckets (Indx) = Position.Node then
1988 HT.Buckets (Indx) := Position.Node.Next;
1990 else
1991 declare
1992 Prev : Node_Access := HT.Buckets (Indx);
1994 begin
1995 while Prev.Next /= Position.Node loop
1996 Prev := Prev.Next;
1998 if Prev = null then
1999 raise Program_Error with
2000 "Position cursor is bad (node not found)";
2001 end if;
2002 end loop;
2004 Prev.Next := Position.Node.Next;
2005 end;
2006 end if;
2008 HT.Length := HT.Length - 1;
2010 declare
2011 X : Node_Access := Position.Node;
2013 begin
2014 Free (X);
2015 end;
2017 raise Program_Error with "key was modified";
2018 end Update_Element_Preserving_Key;
2020 end Generic_Keys;
2022 end Ada.Containers.Indefinite_Hashed_Sets;