1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S --
9 -- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
31 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
33 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
34 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
36 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
37 with Ada.Finalization; use Ada.Finalization;
39 with System; use type System.Address;
41 package body Ada.Containers.Bounded_Hashed_Maps is
43 type Iterator is new Limited_Controlled and
44 Map_Iterator_Interfaces.Forward_Iterator with
46 Container : Map_Access;
49 overriding procedure Finalize (Object : in out Iterator);
51 overriding function First (Object : Iterator) return Cursor;
53 overriding function Next
55 Position : Cursor) return Cursor;
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 function Equivalent_Key_Node
63 Node : Node_Type) return Boolean;
64 pragma Inline (Equivalent_Key_Node);
66 function Hash_Node (Node : Node_Type) return Hash_Type;
67 pragma Inline (Hash_Node);
69 function Next (Node : Node_Type) return Count_Type;
72 procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
73 pragma Inline (Set_Next);
75 function Vet (Position : Cursor) return Boolean;
77 --------------------------
78 -- Local Instantiations --
79 --------------------------
81 package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
82 (HT_Types => HT_Types,
83 Hash_Node => Hash_Node,
85 Set_Next => Set_Next);
87 package Key_Ops is new Hash_Tables.Generic_Bounded_Keys
88 (HT_Types => HT_Types,
93 Equivalent_Keys => Equivalent_Key_Node);
99 function "=" (Left, Right : Map) return Boolean is
100 function Find_Equal_Key
101 (R_HT : Hash_Table_Type'Class;
102 L_Node : Node_Type) return Boolean;
104 function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
110 function Find_Equal_Key
111 (R_HT : Hash_Table_Type'Class;
112 L_Node : Node_Type) return Boolean
114 R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
115 R_Node : Count_Type := R_HT.Buckets (R_Index);
118 while R_Node /= 0 loop
119 if Equivalent_Keys (L_Node.Key, R_HT.Nodes (R_Node).Key) then
120 return L_Node.Element = R_HT.Nodes (R_Node).Element;
123 R_Node := R_HT.Nodes (R_Node).Next;
129 -- Start of processing for "="
132 return Is_Equal (Left, Right);
139 procedure Assign (Target : in out Map; Source : Map) is
140 procedure Insert_Element (Source_Node : Count_Type);
142 procedure Insert_Elements is
143 new HT_Ops.Generic_Iteration (Insert_Element);
149 procedure Insert_Element (Source_Node : Count_Type) is
150 N : Node_Type renames Source.Nodes (Source_Node);
155 Insert (Target, N.Key, N.Element, C, B);
159 -- Start of processing for Assign
162 if Target'Address = Source'Address then
166 if Target.Capacity < Source.Length then
168 with "Target capacity is less than Source length";
171 HT_Ops.Clear (Target);
172 Insert_Elements (Source);
179 function Capacity (Container : Map) return Count_Type is
181 return Container.Capacity;
188 procedure Clear (Container : in out Map) is
190 HT_Ops.Clear (Container);
193 ------------------------
194 -- Constant_Reference --
195 ------------------------
197 function Constant_Reference
198 (Container : aliased Map;
199 Position : Cursor) return Constant_Reference_Type
202 if Position.Container = null then
203 raise Constraint_Error with
204 "Position cursor has no element";
207 if Position.Container /= Container'Unrestricted_Access then
208 raise Program_Error with
209 "Position cursor designates wrong map";
212 pragma Assert (Vet (Position),
213 "Position cursor in Constant_Reference is bad");
216 N : Node_Type renames Container.Nodes (Position.Node);
218 return (Element => N.Element'Access);
220 end Constant_Reference;
222 function Constant_Reference
224 Key : Key_Type) return Constant_Reference_Type
226 Node : constant Count_Type := Key_Ops.Find (Container, Key);
230 raise Constraint_Error with "key not in map";
234 N : Node_Type renames Container.Nodes (Node);
236 return (Element => N.Element'Access);
238 end Constant_Reference;
244 function Contains (Container : Map; Key : Key_Type) return Boolean is
246 return Find (Container, Key) /= No_Element;
255 Capacity : Count_Type := 0;
256 Modulus : Hash_Type := 0) return Map
265 elsif Capacity >= Source.Length then
269 raise Capacity_Error with "Capacity value too small";
273 M := Default_Modulus (C);
278 return Target : Map (Capacity => C, Modulus => M) do
279 Assign (Target => Target, Source => Source);
283 ---------------------
284 -- Default_Modulus --
285 ---------------------
287 function Default_Modulus (Capacity : Count_Type) return Hash_Type is
289 return To_Prime (Capacity);
296 procedure Delete (Container : in out Map; Key : Key_Type) is
300 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
303 raise Constraint_Error with "attempt to delete key not in map";
306 HT_Ops.Free (Container, X);
309 procedure Delete (Container : in out Map; Position : in out Cursor) is
311 if Position.Node = 0 then
312 raise Constraint_Error with
313 "Position cursor of Delete equals No_Element";
316 if Position.Container /= Container'Unrestricted_Access then
317 raise Program_Error with
318 "Position cursor of Delete designates wrong map";
321 if Container.Busy > 0 then
322 raise Program_Error with
323 "Delete attempted to tamper with cursors (map is busy)";
326 pragma Assert (Vet (Position), "bad cursor in Delete");
328 HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
329 HT_Ops.Free (Container, Position.Node);
331 Position := No_Element;
338 function Element (Container : Map; Key : Key_Type) return Element_Type is
339 Node : constant Count_Type := Key_Ops.Find (Container, Key);
343 raise Constraint_Error with
344 "no element available because key not in map";
347 return Container.Nodes (Node).Element;
350 function Element (Position : Cursor) return Element_Type is
352 if Position.Node = 0 then
353 raise Constraint_Error with
354 "Position cursor of function Element equals No_Element";
357 pragma Assert (Vet (Position), "bad cursor in function Element");
359 return Position.Container.Nodes (Position.Node).Element;
362 -------------------------
363 -- Equivalent_Key_Node --
364 -------------------------
366 function Equivalent_Key_Node
368 Node : Node_Type) return Boolean is
370 return Equivalent_Keys (Key, Node.Key);
371 end Equivalent_Key_Node;
373 ---------------------
374 -- Equivalent_Keys --
375 ---------------------
377 function Equivalent_Keys (Left, Right : Cursor)
380 if Left.Node = 0 then
381 raise Constraint_Error with
382 "Left cursor of Equivalent_Keys equals No_Element";
385 if Right.Node = 0 then
386 raise Constraint_Error with
387 "Right cursor of Equivalent_Keys equals No_Element";
390 pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
391 pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
394 LN : Node_Type renames Left.Container.Nodes (Left.Node);
395 RN : Node_Type renames Right.Container.Nodes (Right.Node);
398 return Equivalent_Keys (LN.Key, RN.Key);
402 function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
404 if Left.Node = 0 then
405 raise Constraint_Error with
406 "Left cursor of Equivalent_Keys equals No_Element";
409 pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
412 LN : Node_Type renames Left.Container.Nodes (Left.Node);
415 return Equivalent_Keys (LN.Key, Right);
419 function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
421 if Right.Node = 0 then
422 raise Constraint_Error with
423 "Right cursor of Equivalent_Keys equals No_Element";
426 pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
429 RN : Node_Type renames Right.Container.Nodes (Right.Node);
432 return Equivalent_Keys (Left, RN.Key);
440 procedure Exclude (Container : in out Map; Key : Key_Type) is
443 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
444 HT_Ops.Free (Container, X);
451 procedure Finalize (Object : in out Iterator) is
453 if Object.Container /= null then
455 B : Natural renames Object.Container.all.Busy;
466 function Find (Container : Map; Key : Key_Type) return Cursor is
467 Node : constant Count_Type := Key_Ops.Find (Container, Key);
472 return Cursor'(Container'Unrestricted_Access, Node);
480 function First (Container : Map) return Cursor is
481 Node : constant Count_Type := HT_Ops.First (Container);
486 return Cursor'(Container'Unrestricted_Access, Node);
490 function First (Object : Iterator) return Cursor is
492 return Object.Container.First;
499 function Has_Element (Position : Cursor) return Boolean is
501 pragma Assert (Vet (Position), "bad cursor in Has_Element");
502 return Position.Node /= 0;
509 function Hash_Node (Node : Node_Type) return Hash_Type is
511 return Hash (Node.Key);
519 (Container : in out Map;
521 New_Item : Element_Type)
527 Insert (Container, Key, New_Item, Position, Inserted);
530 if Container.Lock > 0 then
531 raise Program_Error with
532 "Include attempted to tamper with elements (map is locked)";
536 N : Node_Type renames Container.Nodes (Position.Node);
539 N.Element := New_Item;
549 (Container : in out Map;
551 Position : out Cursor;
552 Inserted : out Boolean)
554 procedure Assign_Key (Node : in out Node_Type);
555 pragma Inline (Assign_Key);
557 function New_Node return Count_Type;
558 pragma Inline (New_Node);
560 procedure Local_Insert is
561 new Key_Ops.Generic_Conditional_Insert (New_Node);
563 procedure Allocate is
564 new HT_Ops.Generic_Allocate (Assign_Key);
570 procedure Assign_Key (Node : in out Node_Type) is
574 -- Note that we do not also assign the element component of the node
575 -- here, because this version of Insert does not accept an element
578 -- Node.Element := New_Item;
579 -- What is this deleted code about???
586 function New_Node return Count_Type is
589 Allocate (Container, Result);
593 -- Start of processing for Insert
596 -- The buckets array length is specified by the user as a discriminant
597 -- of the container type, so it is possible for the buckets array to
598 -- have a length of zero. We must check for this case specifically, in
599 -- order to prevent divide-by-zero errors later, when we compute the
600 -- buckets array index value for a key, given its hash value.
602 if Container.Buckets'Length = 0 then
603 raise Capacity_Error with "No capacity for insertion";
606 Local_Insert (Container, Key, Position.Node, Inserted);
607 Position.Container := Container'Unchecked_Access;
611 (Container : in out Map;
613 New_Item : Element_Type;
614 Position : out Cursor;
615 Inserted : out Boolean)
617 procedure Assign_Key (Node : in out Node_Type);
618 pragma Inline (Assign_Key);
620 function New_Node return Count_Type;
621 pragma Inline (New_Node);
623 procedure Local_Insert is
624 new Key_Ops.Generic_Conditional_Insert (New_Node);
626 procedure Allocate is
627 new HT_Ops.Generic_Allocate (Assign_Key);
633 procedure Assign_Key (Node : in out Node_Type) is
636 Node.Element := New_Item;
643 function New_Node return Count_Type is
646 Allocate (Container, Result);
650 -- Start of processing for Insert
653 -- The buckets array length is specified by the user as a discriminant
654 -- of the container type, so it is possible for the buckets array to
655 -- have a length of zero. We must check for this case specifically, in
656 -- order to prevent divide-by-zero errors later, when we compute the
657 -- buckets array index value for a key, given its hash value.
659 if Container.Buckets'Length = 0 then
660 raise Capacity_Error with "No capacity for insertion";
663 Local_Insert (Container, Key, Position.Node, Inserted);
664 Position.Container := Container'Unchecked_Access;
668 (Container : in out Map;
670 New_Item : Element_Type)
673 pragma Unreferenced (Position);
678 Insert (Container, Key, New_Item, Position, Inserted);
681 raise Constraint_Error with
682 "attempt to insert key already in map";
690 function Is_Empty (Container : Map) return Boolean is
692 return Container.Length = 0;
701 Process : not null access procedure (Position : Cursor))
703 procedure Process_Node (Node : Count_Type);
704 pragma Inline (Process_Node);
706 procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
712 procedure Process_Node (Node : Count_Type) is
714 Process (Cursor'(Container'Unrestricted_Access, Node));
717 B : Natural renames Container'Unrestricted_Access.all.Busy;
719 -- Start of processing for Iterate
725 Local_Iterate (Container);
736 (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
738 B : Natural renames Container'Unrestricted_Access.all.Busy;
741 return It : constant Iterator :=
742 (Limited_Controlled with
743 Container => Container'Unrestricted_Access)
753 function Key (Position : Cursor) return Key_Type is
755 if Position.Node = 0 then
756 raise Constraint_Error with
757 "Position cursor of function Key equals No_Element";
760 pragma Assert (Vet (Position), "bad cursor in function Key");
762 return Position.Container.Nodes (Position.Node).Key;
769 function Length (Container : Map) return Count_Type is
771 return Container.Length;
779 (Target : in out Map;
783 if Target'Address = Source'Address then
787 if Source.Busy > 0 then
788 raise Program_Error with
789 "attempt to tamper with cursors (container is busy)";
792 Target.Assign (Source);
800 function Next (Node : Node_Type) return Count_Type is
805 function Next (Position : Cursor) return Cursor is
807 if Position.Node = 0 then
811 pragma Assert (Vet (Position), "bad cursor in function Next");
814 M : Map renames Position.Container.all;
815 Node : constant Count_Type := HT_Ops.Next (M, Position.Node);
820 return Cursor'(Position.Container, Node);
825 procedure Next (Position : in out Cursor) is
827 Position := Next (Position);
832 Position : Cursor) return Cursor
835 if Position.Container = null then
839 if Position.Container /= Object.Container then
840 raise Program_Error with
841 "Position cursor of Next designates wrong map";
844 return Next (Position);
851 procedure Query_Element
853 Process : not null access
854 procedure (Key : Key_Type; Element : Element_Type))
857 if Position.Node = 0 then
858 raise Constraint_Error with
859 "Position cursor of Query_Element equals No_Element";
862 pragma Assert (Vet (Position), "bad cursor in Query_Element");
865 M : Map renames Position.Container.all;
866 N : Node_Type renames M.Nodes (Position.Node);
867 B : Natural renames M.Busy;
868 L : Natural renames M.Lock;
877 Process (N.Key, N.Element);
895 (Stream : not null access Root_Stream_Type'Class;
899 (Stream : not null access Root_Stream_Type'Class) return Count_Type;
900 -- pragma Inline (Read_Node); ???
902 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
909 (Stream : not null access Root_Stream_Type'Class) return Count_Type
911 procedure Read_Element (Node : in out Node_Type);
912 -- pragma Inline (Read_Element); ???
914 procedure Allocate is
915 new HT_Ops.Generic_Allocate (Read_Element);
917 procedure Read_Element (Node : in out Node_Type) is
919 Key_Type'Read (Stream, Node.Key);
920 Element_Type'Read (Stream, Node.Element);
925 -- Start of processing for Read_Node
928 Allocate (Container, Node);
932 -- Start of processing for Read
935 Read_Nodes (Stream, Container);
939 (Stream : not null access Root_Stream_Type'Class;
943 raise Program_Error with "attempt to stream map cursor";
947 (Stream : not null access Root_Stream_Type'Class;
948 Item : out Reference_Type)
951 raise Program_Error with "attempt to stream reference";
955 (Stream : not null access Root_Stream_Type'Class;
956 Item : out Constant_Reference_Type)
959 raise Program_Error with "attempt to stream reference";
967 (Container : aliased in out Map;
968 Position : Cursor) return Reference_Type
971 if Position.Container = null then
972 raise Constraint_Error with
973 "Position cursor has no element";
976 if Position.Container /= Container'Unrestricted_Access then
977 raise Program_Error with
978 "Position cursor designates wrong map";
981 pragma Assert (Vet (Position),
982 "Position cursor in function Reference is bad");
985 N : Node_Type renames Container.Nodes (Position.Node);
987 return (Element => N.Element'Access);
992 (Container : aliased in out Map;
993 Key : Key_Type) return Reference_Type
995 Node : constant Count_Type := Key_Ops.Find (Container, Key);
999 raise Constraint_Error with "key not in map";
1003 N : Node_Type renames Container.Nodes (Node);
1005 return (Element => N.Element'Access);
1014 (Container : in out Map;
1016 New_Item : Element_Type)
1018 Node : constant Count_Type := Key_Ops.Find (Container, Key);
1022 raise Constraint_Error with
1023 "attempt to replace key not in map";
1026 if Container.Lock > 0 then
1027 raise Program_Error with
1028 "Replace attempted to tamper with elements (map is locked)";
1032 N : Node_Type renames Container.Nodes (Node);
1036 N.Element := New_Item;
1040 ---------------------
1041 -- Replace_Element --
1042 ---------------------
1044 procedure Replace_Element
1045 (Container : in out Map;
1047 New_Item : Element_Type)
1050 if Position.Node = 0 then
1051 raise Constraint_Error with
1052 "Position cursor of Replace_Element equals No_Element";
1055 if Position.Container /= Container'Unrestricted_Access then
1056 raise Program_Error with
1057 "Position cursor of Replace_Element designates wrong map";
1060 if Position.Container.Lock > 0 then
1061 raise Program_Error with
1062 "Replace_Element attempted to tamper with elements (map is locked)";
1065 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1067 Container.Nodes (Position.Node).Element := New_Item;
1068 end Replace_Element;
1070 ----------------------
1071 -- Reserve_Capacity --
1072 ----------------------
1074 procedure Reserve_Capacity
1075 (Container : in out Map;
1076 Capacity : Count_Type)
1079 if Capacity > Container.Capacity then
1080 raise Capacity_Error with "requested capacity is too large";
1082 end Reserve_Capacity;
1088 procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1093 --------------------
1094 -- Update_Element --
1095 --------------------
1097 procedure Update_Element
1098 (Container : in out Map;
1100 Process : not null access procedure (Key : Key_Type;
1101 Element : in out Element_Type))
1104 if Position.Node = 0 then
1105 raise Constraint_Error with
1106 "Position cursor of Update_Element equals No_Element";
1109 if Position.Container /= Container'Unrestricted_Access then
1110 raise Program_Error with
1111 "Position cursor of Update_Element designates wrong map";
1114 pragma Assert (Vet (Position), "bad cursor in Update_Element");
1117 N : Node_Type renames Container.Nodes (Position.Node);
1118 B : Natural renames Container.Busy;
1119 L : Natural renames Container.Lock;
1126 Process (N.Key, N.Element);
1143 function Vet (Position : Cursor) return Boolean is
1145 if Position.Node = 0 then
1146 return Position.Container = null;
1149 if Position.Container = null then
1154 M : Map renames Position.Container.all;
1158 if M.Length = 0 then
1162 if M.Capacity = 0 then
1166 if M.Buckets'Length = 0 then
1170 if Position.Node > M.Capacity then
1174 if M.Nodes (Position.Node).Next = Position.Node then
1178 X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key));
1180 for J in 1 .. M.Length loop
1181 if X = Position.Node then
1189 if X = M.Nodes (X).Next then -- to prevent unnecessary looping
1193 X := M.Nodes (X).Next;
1205 (Stream : not null access Root_Stream_Type'Class;
1208 procedure Write_Node
1209 (Stream : not null access Root_Stream_Type'Class;
1211 pragma Inline (Write_Node);
1213 procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1219 procedure Write_Node
1220 (Stream : not null access Root_Stream_Type'Class;
1224 Key_Type'Write (Stream, Node.Key);
1225 Element_Type'Write (Stream, Node.Element);
1228 -- Start of processing for Write
1231 Write_Nodes (Stream, Container);
1235 (Stream : not null access Root_Stream_Type'Class;
1239 raise Program_Error with "attempt to stream map cursor";
1243 (Stream : not null access Root_Stream_Type'Class;
1244 Item : Reference_Type)
1247 raise Program_Error with "attempt to stream reference";
1251 (Stream : not null access Root_Stream_Type'Class;
1252 Item : Constant_Reference_Type)
1255 raise Program_Error with "attempt to stream reference";
1258 end Ada.Containers.Bounded_Hashed_Maps;