1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . H A S H E D _ M A P S --
9 -- Copyright (C) 2004-2015, 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
.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 System
; use type System
.Address
;
40 package body Ada
.Containers
.Hashed_Maps
is
42 pragma Annotate
(CodePeer
, Skip_Analysis
);
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
49 (Source
: Node_Access
) return Node_Access
;
50 pragma Inline
(Copy_Node
);
52 function Equivalent_Key_Node
54 Node
: Node_Access
) return Boolean;
55 pragma Inline
(Equivalent_Key_Node
);
57 procedure Free
(X
: in out Node_Access
);
59 function Find_Equal_Key
60 (R_HT
: Hash_Table_Type
;
61 L_Node
: Node_Access
) return Boolean;
63 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
64 pragma Inline
(Hash_Node
);
66 function Next
(Node
: Node_Access
) return Node_Access
;
70 (Stream
: not null access Root_Stream_Type
'Class) return Node_Access
;
71 pragma Inline
(Read_Node
);
73 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
74 pragma Inline
(Set_Next
);
76 function Vet
(Position
: Cursor
) return Boolean;
79 (Stream
: not null access Root_Stream_Type
'Class;
81 pragma Inline
(Write_Node
);
83 --------------------------
84 -- Local Instantiations --
85 --------------------------
87 package HT_Ops
is new Hash_Tables
.Generic_Operations
88 (HT_Types
=> HT_Types
,
89 Hash_Node
=> Hash_Node
,
92 Copy_Node
=> Copy_Node
,
95 package Key_Ops
is new Hash_Tables
.Generic_Keys
96 (HT_Types
=> HT_Types
,
101 Equivalent_Keys
=> Equivalent_Key_Node
);
103 function Is_Equal
is new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
105 procedure Read_Nodes
is new HT_Ops
.Generic_Read
(Read_Node
);
106 procedure Write_Nodes
is new HT_Ops
.Generic_Write
(Write_Node
);
112 function "=" (Left
, Right
: Map
) return Boolean is
114 return Is_Equal
(Left
.HT
, Right
.HT
);
121 procedure Adjust
(Container
: in out Map
) is
123 HT_Ops
.Adjust
(Container
.HT
);
126 procedure Adjust
(Control
: in out Reference_Control_Type
) is
128 if Control
.Container
/= null then
130 HT
: Hash_Table_Type
renames Control
.Container
.all.HT
;
131 B
: Natural renames HT
.Busy
;
132 L
: Natural renames HT
.Lock
;
144 procedure Assign
(Target
: in out Map
; Source
: Map
) is
145 procedure Insert_Item
(Node
: Node_Access
);
146 pragma Inline
(Insert_Item
);
148 procedure Insert_Items
is new HT_Ops
.Generic_Iteration
(Insert_Item
);
154 procedure Insert_Item
(Node
: Node_Access
) is
156 Target
.Insert
(Key
=> Node
.Key
, New_Item
=> Node
.Element
);
159 -- Start of processing for Assign
162 if Target
'Address = Source
'Address then
168 if Target
.Capacity
< Source
.Length
then
169 Target
.Reserve_Capacity
(Source
.Length
);
172 Insert_Items
(Source
.HT
);
179 function Capacity
(Container
: Map
) return Count_Type
is
181 return HT_Ops
.Capacity
(Container
.HT
);
188 procedure Clear
(Container
: in out Map
) is
190 HT_Ops
.Clear
(Container
.HT
);
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";
214 "Position cursor in Constant_Reference is bad");
217 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.all.HT
;
218 B
: Natural renames HT
.Busy
;
219 L
: Natural renames HT
.Lock
;
221 return R
: constant Constant_Reference_Type
:=
222 (Element
=> Position
.Node
.Element
'Access,
223 Control
=> (Controlled
with Position
.Container
))
229 end Constant_Reference
;
231 function Constant_Reference
232 (Container
: aliased Map
;
233 Key
: Key_Type
) return Constant_Reference_Type
235 HT
: Hash_Table_Type
renames Container
'Unrestricted_Access.HT
;
236 Node
: constant Node_Access
:= Key_Ops
.Find
(HT
, Key
);
240 raise Constraint_Error
with "key not in map";
244 B
: Natural renames HT
.Busy
;
245 L
: Natural renames HT
.Lock
;
247 return R
: constant Constant_Reference_Type
:=
248 (Element
=> Node
.Element
'Access,
249 Control
=> (Controlled
with Container
'Unrestricted_Access))
255 end Constant_Reference
;
261 function Contains
(Container
: Map
; Key
: Key_Type
) return Boolean is
263 return Find
(Container
, Key
) /= No_Element
;
272 Capacity
: Count_Type
:= 0) return Map
280 elsif Capacity
>= Source
.Length
then
285 with "Requested capacity is less than Source length";
288 return Target
: Map
do
289 Target
.Reserve_Capacity
(C
);
290 Target
.Assign
(Source
);
299 (Source
: Node_Access
) return Node_Access
301 Target
: constant Node_Access
:=
302 new Node_Type
'(Key => Source.Key,
303 Element => Source.Element,
313 procedure Delete (Container : in out Map; Key : Key_Type) is
317 Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
320 raise Constraint_Error with "attempt to delete key not in map";
326 procedure Delete (Container : in out Map; Position : in out Cursor) is
328 if Position.Node = null then
329 raise Constraint_Error with
330 "Position cursor of Delete equals No_Element";
333 if Position.Container /= Container'Unrestricted_Access then
334 raise Program_Error with
335 "Position cursor of Delete designates wrong map";
338 if Container.HT.Busy > 0 then
339 raise Program_Error with
340 "Delete attempted to tamper with cursors (map is busy)";
343 pragma Assert (Vet (Position), "bad cursor in Delete");
345 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
347 Free (Position.Node);
348 Position.Container := null;
355 function Element (Container : Map; Key : Key_Type) return Element_Type is
356 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
357 Node : constant Node_Access := Key_Ops.Find (HT, Key);
361 raise Constraint_Error with
362 "no element available because key not in map";
368 function Element (Position : Cursor) return Element_Type is
370 if Position.Node = null then
371 raise Constraint_Error with
372 "Position cursor of function Element equals No_Element";
375 pragma Assert (Vet (Position), "bad cursor in function Element");
377 return Position.Node.Element;
380 -------------------------
381 -- Equivalent_Key_Node --
382 -------------------------
384 function Equivalent_Key_Node
386 Node : Node_Access) return Boolean is
388 return Equivalent_Keys (Key, Node.Key);
389 end Equivalent_Key_Node;
391 ---------------------
392 -- Equivalent_Keys --
393 ---------------------
395 function Equivalent_Keys (Left, Right : Cursor)
398 if Left.Node = null then
399 raise Constraint_Error with
400 "Left cursor of Equivalent_Keys equals No_Element";
403 if Right.Node = null then
404 raise Constraint_Error with
405 "Right cursor of Equivalent_Keys equals No_Element";
408 pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
409 pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
411 return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
414 function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
416 if Left.Node = null then
417 raise Constraint_Error with
418 "Left cursor of Equivalent_Keys equals No_Element";
421 pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
423 return Equivalent_Keys (Left.Node.Key, Right);
426 function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
428 if Right.Node = null then
429 raise Constraint_Error with
430 "Right cursor of Equivalent_Keys equals No_Element";
433 pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
435 return Equivalent_Keys (Left, Right.Node.Key);
442 procedure Exclude (Container : in out Map; Key : Key_Type) is
445 Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
453 procedure Finalize (Container : in out Map) is
455 HT_Ops.Finalize (Container.HT);
458 procedure Finalize (Object : in out Iterator) is
460 if Object.Container /= null then
462 B : Natural renames Object.Container.all.HT.Busy;
469 procedure Finalize (Control : in out Reference_Control_Type) is
471 if Control.Container /= null then
473 HT : Hash_Table_Type renames Control.Container.all.HT;
474 B : Natural renames HT.Busy;
475 L : Natural renames HT.Lock;
481 Control.Container := null;
489 function Find (Container : Map; Key : Key_Type) return Cursor is
490 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT;
491 Node : constant Node_Access := Key_Ops.Find (HT, Key);
498 return Cursor'(Container
'Unrestricted_Access, Node
);
505 function Find_Equal_Key
506 (R_HT
: Hash_Table_Type
;
507 L_Node
: Node_Access
) return Boolean
509 R_Index
: constant Hash_Type
:= Key_Ops
.Index
(R_HT
, L_Node
.Key
);
510 R_Node
: Node_Access
:= R_HT
.Buckets
(R_Index
);
513 while R_Node
/= null loop
514 if Equivalent_Keys
(L_Node
.Key
, R_Node
.Key
) then
515 return L_Node
.Element
= R_Node
.Element
;
518 R_Node
:= R_Node
.Next
;
528 function First
(Container
: Map
) return Cursor
is
529 Node
: constant Node_Access
:= HT_Ops
.First
(Container
.HT
);
536 return Cursor
'(Container'Unrestricted_Access, Node);
539 function First (Object : Iterator) return Cursor is
541 return Object.Container.First;
548 procedure Free (X : in out Node_Access) is
549 procedure Deallocate is
550 new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
553 X.Next := X; -- detect mischief (in Vet)
558 ------------------------
559 -- Get_Element_Access --
560 ------------------------
562 function Get_Element_Access
563 (Position : Cursor) return not null Element_Access is
565 return Position.Node.Element'Access;
566 end Get_Element_Access;
572 function Has_Element (Position : Cursor) return Boolean is
574 pragma Assert (Vet (Position), "bad cursor in Has_Element");
575 return Position.Node /= null;
582 function Hash_Node (Node : Node_Access) return Hash_Type is
584 return Hash (Node.Key);
592 (Container : in out Map;
594 New_Item : Element_Type)
600 Insert (Container, Key, New_Item, Position, Inserted);
603 if Container.HT.Lock > 0 then
604 raise Program_Error with
605 "Include attempted to tamper with elements (map is locked)";
608 Position.Node.Key := Key;
609 Position.Node.Element := New_Item;
618 (Container : in out Map;
620 Position : out Cursor;
621 Inserted : out Boolean)
623 function New_Node (Next : Node_Access) return Node_Access;
624 pragma Inline (New_Node);
626 procedure Local_Insert is
627 new Key_Ops.Generic_Conditional_Insert (New_Node);
633 function New_Node (Next : Node_Access) return Node_Access is
635 return new Node_Type'(Key
=> Key
,
640 HT
: Hash_Table_Type
renames Container
.HT
;
642 -- Start of processing for Insert
645 if HT_Ops
.Capacity
(HT
) = 0 then
646 HT_Ops
.Reserve_Capacity
(HT
, 1);
649 Local_Insert
(HT
, Key
, Position
.Node
, Inserted
);
652 and then HT
.Length
> HT_Ops
.Capacity
(HT
)
654 HT_Ops
.Reserve_Capacity
(HT
, HT
.Length
);
657 Position
.Container
:= Container
'Unrestricted_Access;
661 (Container
: in out Map
;
663 New_Item
: Element_Type
;
664 Position
: out Cursor
;
665 Inserted
: out Boolean)
667 function New_Node
(Next
: Node_Access
) return Node_Access
;
668 pragma Inline
(New_Node
);
670 procedure Local_Insert
is
671 new Key_Ops
.Generic_Conditional_Insert
(New_Node
);
677 function New_Node
(Next
: Node_Access
) return Node_Access
is
679 return new Node_Type
'(Key, New_Item, Next);
682 HT : Hash_Table_Type renames Container.HT;
684 -- Start of processing for Insert
687 if HT_Ops.Capacity (HT) = 0 then
688 HT_Ops.Reserve_Capacity (HT, 1);
691 Local_Insert (HT, Key, Position.Node, Inserted);
694 and then HT.Length > HT_Ops.Capacity (HT)
696 HT_Ops.Reserve_Capacity (HT, HT.Length);
699 Position.Container := Container'Unrestricted_Access;
703 (Container : in out Map;
705 New_Item : Element_Type)
708 pragma Unreferenced (Position);
713 Insert (Container, Key, New_Item, Position, Inserted);
716 raise Constraint_Error with
717 "attempt to insert key already in map";
725 function Is_Empty (Container : Map) return Boolean is
727 return Container.HT.Length = 0;
736 Process : not null access procedure (Position : Cursor))
738 procedure Process_Node (Node : Node_Access);
739 pragma Inline (Process_Node);
741 procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
747 procedure Process_Node (Node : Node_Access) is
749 Process (Cursor'(Container
'Unrestricted_Access, Node
));
752 B
: Natural renames Container
'Unrestricted_Access.all.HT
.Busy
;
754 -- Start of processing for Iterate
760 Local_Iterate
(Container
.HT
);
771 (Container
: Map
) return Map_Iterator_Interfaces
.Forward_Iterator
'Class
773 B
: Natural renames Container
'Unrestricted_Access.all.HT
.Busy
;
775 return It
: constant Iterator
:=
776 (Limited_Controlled
with Container
=> Container
'Unrestricted_Access)
786 function Key
(Position
: Cursor
) return Key_Type
is
788 if Position
.Node
= null then
789 raise Constraint_Error
with
790 "Position cursor of function Key equals No_Element";
793 pragma Assert
(Vet
(Position
), "bad cursor in function Key");
795 return Position
.Node
.Key
;
802 function Length
(Container
: Map
) return Count_Type
is
804 return Container
.HT
.Length
;
812 (Target
: in out Map
;
816 HT_Ops
.Move
(Target
=> Target
.HT
, Source
=> Source
.HT
);
823 function Next
(Node
: Node_Access
) return Node_Access
is
828 function Next
(Position
: Cursor
) return Cursor
is
830 if Position
.Node
= null then
834 pragma Assert
(Vet
(Position
), "bad cursor in function Next");
837 HT
: Hash_Table_Type
renames Position
.Container
.HT
;
838 Node
: constant Node_Access
:= HT_Ops
.Next
(HT
, Position
.Node
);
845 return Cursor
'(Position.Container, Node);
849 procedure Next (Position : in out Cursor) is
851 Position := Next (Position);
856 Position : Cursor) return Cursor
859 if Position.Container = null then
863 if Position.Container /= Object.Container then
864 raise Program_Error with
865 "Position cursor of Next designates wrong map";
868 return Next (Position);
871 ----------------------
872 -- Pseudo_Reference --
873 ----------------------
875 function Pseudo_Reference
876 (Container : aliased Map'Class) return Reference_Control_Type
878 C : constant Map_Access := Container'Unrestricted_Access;
879 B : Natural renames C.HT.Busy;
880 L : Natural renames C.HT.Lock;
882 return R : constant Reference_Control_Type :=
888 end Pseudo_Reference;
894 procedure Query_Element
896 Process : not null access
897 procedure (Key : Key_Type; Element : Element_Type))
900 if Position.Node = null then
901 raise Constraint_Error with
902 "Position cursor of Query_Element equals No_Element";
905 pragma Assert (Vet (Position), "bad cursor in Query_Element");
908 M : Map renames Position.Container.all;
909 HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
911 B : Natural renames HT.Busy;
912 L : Natural renames HT.Lock;
919 K : Key_Type renames Position.Node.Key;
920 E : Element_Type renames Position.Node.Element;
940 (Stream : not null access Root_Stream_Type'Class;
944 Read_Nodes (Stream, Container.HT);
948 (Stream : not null access Root_Stream_Type'Class;
952 raise Program_Error with "attempt to stream map cursor";
956 (Stream : not null access Root_Stream_Type'Class;
957 Item : out Reference_Type)
960 raise Program_Error with "attempt to stream reference";
964 (Stream : not null access Root_Stream_Type'Class;
965 Item : out Constant_Reference_Type)
968 raise Program_Error with "attempt to stream reference";
976 (Container : aliased in out Map;
977 Position : Cursor) return Reference_Type
980 if Position.Container = null then
981 raise Constraint_Error with
982 "Position cursor has no element";
985 if Position.Container /= Container'Unrestricted_Access then
986 raise Program_Error with
987 "Position cursor designates wrong map";
992 "Position cursor in function Reference is bad");
995 HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
996 B : Natural renames HT.Busy;
997 L : Natural renames HT.Lock;
999 return R : constant Reference_Type :=
1000 (Element => Position.Node.Element'Access,
1001 Control => (Controlled with Position.Container))
1010 (Container : aliased in out Map;
1011 Key : Key_Type) return Reference_Type
1013 HT : Hash_Table_Type renames Container.HT;
1014 Node : constant Node_Access := Key_Ops.Find (HT, Key);
1018 raise Constraint_Error with "key not in map";
1022 B : Natural renames HT.Busy;
1023 L : Natural renames HT.Lock;
1025 return R : constant Reference_Type :=
1026 (Element => Node.Element'Access,
1027 Control => (Controlled with Container'Unrestricted_Access))
1040 (Stream : not null access Root_Stream_Type'Class) return Node_Access
1042 Node : Node_Access := new Node_Type;
1045 Key_Type'Read (Stream, Node.Key);
1046 Element_Type'Read (Stream, Node.Element);
1060 (Container : in out Map;
1062 New_Item : Element_Type)
1064 Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1068 raise Constraint_Error with
1069 "attempt to replace key not in map";
1072 if Container.HT.Lock > 0 then
1073 raise Program_Error with
1074 "Replace attempted to tamper with elements (map is locked)";
1078 Node.Element := New_Item;
1081 ---------------------
1082 -- Replace_Element --
1083 ---------------------
1085 procedure Replace_Element
1086 (Container : in out Map;
1088 New_Item : Element_Type)
1091 if Position.Node = null then
1092 raise Constraint_Error with
1093 "Position cursor of Replace_Element equals No_Element";
1096 if Position.Container /= Container'Unrestricted_Access then
1097 raise Program_Error with
1098 "Position cursor of Replace_Element designates wrong map";
1101 if Position.Container.HT.Lock > 0 then
1102 raise Program_Error with
1103 "Replace_Element attempted to tamper with elements (map is locked)";
1106 pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1108 Position.Node.Element := New_Item;
1109 end Replace_Element;
1111 ----------------------
1112 -- Reserve_Capacity --
1113 ----------------------
1115 procedure Reserve_Capacity
1116 (Container : in out Map;
1117 Capacity : Count_Type)
1120 HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1121 end Reserve_Capacity;
1127 procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1132 --------------------
1133 -- Update_Element --
1134 --------------------
1136 procedure Update_Element
1137 (Container : in out Map;
1139 Process : not null access procedure (Key : Key_Type;
1140 Element : in out Element_Type))
1143 if Position.Node = null then
1144 raise Constraint_Error with
1145 "Position cursor of Update_Element equals No_Element";
1148 if Position.Container /= Container'Unrestricted_Access then
1149 raise Program_Error with
1150 "Position cursor of Update_Element designates wrong map";
1153 pragma Assert (Vet (Position), "bad cursor in Update_Element");
1156 HT : Hash_Table_Type renames Container.HT;
1157 B : Natural renames HT.Busy;
1158 L : Natural renames HT.Lock;
1165 K : Key_Type renames Position.Node.Key;
1166 E : Element_Type renames Position.Node.Element;
1185 function Vet (Position : Cursor) return Boolean is
1187 if Position.Node = null then
1188 return Position.Container = null;
1191 if Position.Container = null then
1195 if Position.Node.Next = Position.Node then
1200 HT : Hash_Table_Type renames Position.Container.HT;
1204 if HT.Length = 0 then
1208 if HT.Buckets = null
1209 or else HT.Buckets'Length = 0
1214 X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key));
1216 for J in 1 .. HT.Length loop
1217 if X = Position.Node then
1225 if X = X.Next then -- to prevent unnecessary looping
1241 (Stream : not null access Root_Stream_Type'Class;
1245 Write_Nodes (Stream, Container.HT);
1249 (Stream : not null access Root_Stream_Type'Class;
1253 raise Program_Error with "attempt to stream map cursor";
1257 (Stream : not null access Root_Stream_Type'Class;
1258 Item : Reference_Type)
1261 raise Program_Error with "attempt to stream reference";
1265 (Stream : not null access Root_Stream_Type'Class;
1266 Item : Constant_Reference_Type)
1269 raise Program_Error with "attempt to stream reference";
1276 procedure Write_Node
1277 (Stream : not null access Root_Stream_Type'Class;
1281 Key_Type'Write (Stream, Node.Key);
1282 Element_Type'Write (Stream, Node.Element);
1285 end Ada.Containers.Hashed_Maps;