1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . --
6 -- I N D E F I N I T E _ H A S H E D _ M A P S --
10 -- Copyright (C) 2004-2005, Free Software Foundation, Inc. --
12 -- This specification is derived from the Ada Reference Manual for use with --
13 -- GNAT. The copyright notice above, and the license provisions that follow --
14 -- apply solely to the contents of the part following the private keyword. --
16 -- GNAT is free software; you can redistribute it and/or modify it under --
17 -- terms of the GNU General Public License as published by the Free Soft- --
18 -- ware Foundation; either version 2, or (at your option) any later ver- --
19 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
20 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
21 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
22 -- for more details. You should have received a copy of the GNU General --
23 -- Public License distributed with GNAT; see file COPYING. If not, write --
24 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
25 -- Boston, MA 02110-1301, USA. --
27 -- As a special exception, if other files instantiate generics from this --
28 -- unit, or you link this unit with other files to produce an executable, --
29 -- this unit does not by itself cause the resulting executable to be --
30 -- covered by the GNU General Public License. This exception does not --
31 -- however invalidate any other reasons why the executable file might be --
32 -- covered by the GNU Public License. --
34 -- This unit has originally being developed by Matthew J Heaney. --
35 ------------------------------------------------------------------------------
37 with Ada.Containers.Hash_Tables.Generic_Operations;
38 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
40 with Ada.Containers.Hash_Tables.Generic_Keys;
41 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
43 with Ada.Unchecked_Deallocation;
45 package body Ada.Containers.Indefinite_Hashed_Maps is
48 new Ada.Unchecked_Deallocation (Key_Type, Key_Access);
50 procedure Free_Element is
51 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
57 function Copy_Node (Node : Node_Access) return Node_Access;
58 pragma Inline (Copy_Node);
60 function Equivalent_Key_Node
62 Node : Node_Access) return Boolean;
63 pragma Inline (Equivalent_Key_Node);
65 function Find_Equal_Key
66 (R_HT : Hash_Table_Type;
67 L_Node : Node_Access) return Boolean;
69 procedure Free (X : in out Node_Access);
70 -- pragma Inline (Free);
72 function Hash_Node (Node : Node_Access) return Hash_Type;
73 pragma Inline (Hash_Node);
75 function Next (Node : Node_Access) return Node_Access;
79 (Stream : access Root_Stream_Type'Class) return Node_Access;
81 procedure Set_Next (Node : Node_Access; Next : Node_Access);
82 pragma Inline (Set_Next);
84 function Vet (Position : Cursor) return Boolean;
87 (Stream : access Root_Stream_Type'Class;
90 --------------------------
91 -- Local Instantiations --
92 --------------------------
95 new Ada.Containers.Hash_Tables.Generic_Operations
96 (HT_Types => HT_Types,
97 Hash_Node => Hash_Node,
100 Copy_Node => Copy_Node,
104 new Hash_Tables.Generic_Keys
105 (HT_Types => HT_Types,
107 Set_Next => Set_Next,
108 Key_Type => Key_Type,
110 Equivalent_Keys => Equivalent_Key_Node);
116 function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
118 function "=" (Left, Right : Map) return Boolean is
120 return Is_Equal (Left.HT, Right.HT);
127 procedure Adjust (Container : in out Map) is
129 HT_Ops.Adjust (Container.HT);
136 function Capacity (Container : Map) return Count_Type is
138 return HT_Ops.Capacity (Container.HT);
145 procedure Clear (Container : in out Map) is
147 HT_Ops.Clear (Container.HT);
154 function Contains (Container : Map; Key : Key_Type) return Boolean is
156 return Find (Container, Key) /= No_Element;
163 function Copy_Node (Node : Node_Access) return Node_Access is
164 K : Key_Access := new Key_Type'(Node.Key.all);
168 E := new Element_Type'(Node.Element.all);
169 return new Node_Type'(K, E, null);
182 procedure Delete (Container : in out Map; Key : Key_Type) is
186 Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
189 raise Constraint_Error with "attempt to delete key not in map";
195 procedure Delete (Container : in out Map; Position : in out Cursor) is
197 if Position.Node = null then
198 raise Constraint_Error with
199 "Position cursor of Delete equals No_Element";
202 if Position.Container /= Container'Unrestricted_Access then
203 raise Program_Error with
204 "Position cursor of Delete designates wrong map";
207 if Container.HT.Busy > 0 then
208 raise Program_Error with
209 "Delete attempted to tamper with elements (map is busy)";
212 pragma Assert (Vet (Position), "bad cursor in Delete");
214 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
216 Free (Position.Node);
217 Position.Container := null;
224 function Element (Container : Map; Key : Key_Type) return Element_Type is
225 Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
229 raise Constraint_Error with
230 "no element available because key not in map";
233 return Node.Element.all;
236 function Element (Position : Cursor) return Element_Type is
238 if Position.Node = null then
239 raise Constraint_Error with
240 "Position cursor of function Element equals No_Element";
243 if Position.Node.Element = null then
244 raise Program_Error with
245 "Position cursor of function Element is bad";
248 pragma Assert (Vet (Position), "bad cursor in function Element");
250 return Position.Node.Element.all;
253 -------------------------
254 -- Equivalent_Key_Node --
255 -------------------------
257 function Equivalent_Key_Node
259 Node : Node_Access) return Boolean
262 return Equivalent_Keys (Key, Node.Key.all);
263 end Equivalent_Key_Node;
265 ---------------------
266 -- Equivalent_Keys --
267 ---------------------
269 function Equivalent_Keys (Left, Right : Cursor) return Boolean is
271 if Left.Node = null then
272 raise Constraint_Error with
273 "Left cursor of Equivalent_Keys equals No_Element";
276 if Right.Node = null then
277 raise Constraint_Error with
278 "Right cursor of Equivalent_Keys equals No_Element";
281 if Left.Node.Key = null then
282 raise Program_Error with
283 "Left cursor of Equivalent_Keys is bad";
286 if Right.Node.Key = null then
287 raise Program_Error with
288 "Right cursor of Equivalent_Keys is bad";
291 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
292 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
294 return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
297 function Equivalent_Keys
299 Right : Key_Type) return Boolean
302 if Left.Node = null then
303 raise Constraint_Error with
304 "Left cursor of Equivalent_Keys equals No_Element";
307 if Left.Node.Key = null then
308 raise Program_Error with
309 "Left cursor of Equivalent_Keys is bad";
312 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
314 return Equivalent_Keys (Left.Node.Key.all, Right);
317 function Equivalent_Keys
319 Right : Cursor) return Boolean
322 if Right.Node = null then
323 raise Constraint_Error with
324 "Right cursor of Equivalent_Keys equals No_Element";
327 if Right.Node.Key = null then
328 raise Program_Error with
329 "Right cursor of Equivalent_Keys is bad";
332 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
334 return Equivalent_Keys (Left, Right.Node.Key.all);
341 procedure Exclude (Container : in out Map; Key : Key_Type) is
344 Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
352 procedure Finalize (Container : in out Map) is
354 HT_Ops.Finalize (Container.HT);
361 function Find (Container : Map; Key : Key_Type) return Cursor is
362 Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
369 return Cursor'(Container'Unchecked_Access, Node);
376 function Find_Equal_Key
377 (R_HT : Hash_Table_Type;
378 L_Node : Node_Access) return Boolean
380 R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
381 R_Node : Node_Access := R_HT.Buckets (R_Index);
384 while R_Node /= null loop
385 if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
386 return L_Node.Element.all = R_Node.Element.all;
389 R_Node := R_Node.Next;
399 function First (Container : Map) return Cursor is
400 Node : constant Node_Access := HT_Ops.First (Container.HT);
407 return Cursor'(Container'Unchecked_Access, Node);
414 procedure Free (X : in out Node_Access) is
415 procedure Deallocate is
416 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
422 X.Next := X; -- detect mischief (in Vet)
431 Free_Element (X.Element);
442 Free_Element (X.Element);
458 function Has_Element (Position : Cursor) return Boolean is
460 pragma Assert (Vet (Position), "bad cursor in Has_Element");
461 return Position.Node /= null;
468 function Hash_Node (Node : Node_Access) return Hash_Type is
470 return Hash (Node.Key.all);
478 (Container : in out Map;
480 New_Item : Element_Type)
489 Insert (Container, Key, New_Item, Position, Inserted);
492 if Container.HT.Lock > 0 then
493 raise Program_Error with
494 "Include attempted to tamper with cursors (map is locked)";
497 K := Position.Node.Key;
498 E := Position.Node.Element;
500 Position.Node.Key := new Key_Type'(Key);
503 Position.Node.Element := new Element_Type'(New_Item);
520 (Container : in out Map;
522 New_Item : Element_Type;
523 Position : out Cursor;
524 Inserted : out Boolean)
526 function New_Node (Next : Node_Access) return Node_Access;
528 procedure Local_Insert is
529 new Key_Ops.Generic_Conditional_Insert (New_Node);
535 function New_Node (Next : Node_Access) return Node_Access is
536 K : Key_Access := new Key_Type'(Key);
540 E := new Element_Type'(New_Item);
541 return new Node_Type'(K, E, Next);
549 HT : Hash_Table_Type renames Container.HT;
551 -- Start of processing for Insert
554 if HT_Ops.Capacity (HT) = 0 then
555 HT_Ops.Reserve_Capacity (HT, 1);
558 Local_Insert (HT, Key, Position.Node, Inserted);
561 and then HT.Length > HT_Ops.Capacity (HT)
563 HT_Ops.Reserve_Capacity (HT, HT.Length);
566 Position.Container := Container'Unchecked_Access;
570 (Container : in out Map;
572 New_Item : Element_Type)
578 Insert (Container, Key, New_Item, Position, Inserted);
581 raise Constraint_Error with
582 "attempt to insert key already in map";
590 function Is_Empty (Container : Map) return Boolean is
592 return Container.HT.Length = 0;
601 Process : not null access procedure (Position : Cursor))
603 procedure Process_Node (Node : Node_Access);
604 pragma Inline (Process_Node);
607 new HT_Ops.Generic_Iteration (Process_Node);
613 procedure Process_Node (Node : Node_Access) is
615 Process (Cursor'(Container'Unchecked_Access, Node));
618 -- Start of processing Iterate
621 Iterate (Container.HT);
628 function Key (Position : Cursor) return Key_Type is
630 if Position.Node = null then
631 raise Constraint_Error with
632 "Position cursor of function Key equals No_Element";
635 if Position.Node.Key = null then
636 raise Program_Error with
637 "Position cursor of function Key is bad";
640 pragma Assert (Vet (Position), "bad cursor in function Key");
642 return Position.Node.Key.all;
649 function Length (Container : Map) return Count_Type is
651 return Container.HT.Length;
659 (Target : in out Map;
663 HT_Ops.Move (Target => Target.HT, Source => Source.HT);
670 function Next (Node : Node_Access) return Node_Access is
675 procedure Next (Position : in out Cursor) is
677 Position := Next (Position);
680 function Next (Position : Cursor) return Cursor is
682 if Position.Node = null then
686 if Position.Node.Key = null
687 or else Position.Node.Element = null
689 raise Program_Error with "Position cursor of Next is bad";
692 pragma Assert (Vet (Position), "Position cursor of Next is bad");
695 HT : Hash_Table_Type renames Position.Container.HT;
696 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
703 return Cursor'(Position.Container, Node);
711 procedure Query_Element
713 Process : not null access procedure (Key : Key_Type;
714 Element : Element_Type))
717 if Position.Node = null then
718 raise Constraint_Error with
719 "Position cursor of Query_Element equals No_Element";
722 if Position.Node.Key = null
723 or else Position.Node.Element = null
725 raise Program_Error with
726 "Position cursor of Query_Element is bad";
729 pragma Assert (Vet (Position), "bad cursor in Query_Element");
732 M : Map renames Position.Container.all;
733 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
735 B : Natural renames HT.Busy;
736 L : Natural renames HT.Lock;
743 K : Key_Type renames Position.Node.Key.all;
744 E : Element_Type renames Position.Node.Element.all;
764 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
767 (Stream : access Root_Stream_Type'Class;
771 Read_Nodes (Stream, Container.HT);
775 (Stream : access Root_Stream_Type'Class;
779 raise Program_Error with "attempt to stream map cursor";
787 (Stream : access Root_Stream_Type'Class) return Node_Access
789 Node : Node_Access := new Node_Type;
793 Node.Key := new Key_Type'(Key_Type'Input (Stream));
801 Node.Element := new Element_Type'(Element_Type'Input (Stream));
817 (Container : in out Map;
819 New_Item : Element_Type)
821 Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
828 raise Constraint_Error with
829 "attempt to replace key not in map";
832 if Container.HT.Lock > 0 then
833 raise Program_Error with
834 "Replace attempted to tamper with cursors (map is locked)";
840 Node.Key := new Key_Type'(Key);
843 Node.Element := new Element_Type'(New_Item);
854 ---------------------
855 -- Replace_Element --
856 ---------------------
858 procedure Replace_Element
859 (Container : in out Map;
861 New_Item : Element_Type)
864 if Position.Node = null then
865 raise Constraint_Error with
866 "Position cursor of Replace_Element equals No_Element";
869 if Position.Node.Key = null
870 or else Position.Node.Element = null
872 raise Program_Error with
873 "Position cursor of Replace_Element is bad";
876 if Position.Container /= Container'Unrestricted_Access then
877 raise Program_Error with
878 "Position cursor of Replace_Element designates wrong map";
881 if Position.Container.HT.Lock > 0 then
882 raise Program_Error with
883 "Replace_Element attempted to tamper with cursors (map is locked)";
886 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
889 X : Element_Access := Position.Node.Element;
892 Position.Node.Element := new Element_Type'(New_Item);
897 ----------------------
898 -- Reserve_Capacity --
899 ----------------------
901 procedure Reserve_Capacity
902 (Container : in out Map;
903 Capacity : Count_Type)
906 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
907 end Reserve_Capacity;
913 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
922 procedure Update_Element
923 (Container : in out Map;
925 Process : not null access procedure (Key : Key_Type;
926 Element : in out Element_Type))
929 if Position.Node = null then
930 raise Constraint_Error with
931 "Position cursor of Update_Element equals No_Element";
934 if Position.Node.Key = null
935 or else Position.Node.Element = null
937 raise Program_Error with
938 "Position cursor of Update_Element is bad";
941 if Position.Container /= Container'Unrestricted_Access then
942 raise Program_Error with
943 "Position cursor of Update_Element designates wrong map";
946 pragma Assert (Vet (Position), "bad cursor in Update_Element");
949 HT : Hash_Table_Type renames Container.HT;
951 B : Natural renames HT.Busy;
952 L : Natural renames HT.Lock;
959 K : Key_Type renames Position.Node.Key.all;
960 E : Element_Type renames Position.Node.Element.all;
979 function Vet (Position : Cursor) return Boolean is
981 if Position.Node = null then
982 return Position.Container = null;
985 if Position.Container = null then
989 if Position.Node.Next = Position.Node then
993 if Position.Node.Key = null then
997 if Position.Node.Element = null then
1002 HT : Hash_Table_Type renames Position.Container.HT;
1006 if HT.Length = 0 then
1010 if HT.Buckets = null
1011 or else HT.Buckets'Length = 0
1016 X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
1018 for J in 1 .. HT.Length loop
1019 if X = Position.Node then
1027 if X = X.Next then -- to prevent endless loop
1042 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1045 (Stream : access Root_Stream_Type'Class;
1049 Write_Nodes (Stream, Container.HT);
1053 (Stream : access Root_Stream_Type'Class;
1057 raise Program_Error with "attempt to stream map cursor";
1064 procedure Write_Node
1065 (Stream : access Root_Stream_Type'Class;
1069 Key_Type'Output (Stream, Node.Key.all);
1070 Element_Type'Output (Stream, Node.Element.all);
1073 end Ada.Containers.Indefinite_Hashed_Maps;