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-2013, 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
;
38 with System
; use type System
.Address
;
40 package body Ada
.Containers
.Bounded_Hashed_Maps
is
42 -----------------------
43 -- Local Subprograms --
44 -----------------------
46 function Equivalent_Key_Node
48 Node
: Node_Type
) return Boolean;
49 pragma Inline
(Equivalent_Key_Node
);
51 function Hash_Node
(Node
: Node_Type
) return Hash_Type
;
52 pragma Inline
(Hash_Node
);
54 function Next
(Node
: Node_Type
) return Count_Type
;
57 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
);
58 pragma Inline
(Set_Next
);
60 function Vet
(Position
: Cursor
) return Boolean;
62 --------------------------
63 -- Local Instantiations --
64 --------------------------
66 package HT_Ops
is new Hash_Tables
.Generic_Bounded_Operations
67 (HT_Types
=> HT_Types
,
68 Hash_Node
=> Hash_Node
,
70 Set_Next
=> Set_Next
);
72 package Key_Ops
is new Hash_Tables
.Generic_Bounded_Keys
73 (HT_Types
=> HT_Types
,
78 Equivalent_Keys
=> Equivalent_Key_Node
);
84 function "=" (Left
, Right
: Map
) return Boolean is
85 function Find_Equal_Key
86 (R_HT
: Hash_Table_Type
'Class;
87 L_Node
: Node_Type
) return Boolean;
89 function Is_Equal
is new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
95 function Find_Equal_Key
96 (R_HT
: Hash_Table_Type
'Class;
97 L_Node
: Node_Type
) return Boolean
99 R_Index
: constant Hash_Type
:= Key_Ops
.Index
(R_HT
, L_Node
.Key
);
100 R_Node
: Count_Type
:= R_HT
.Buckets
(R_Index
);
103 while R_Node
/= 0 loop
104 if Equivalent_Keys
(L_Node
.Key
, R_HT
.Nodes
(R_Node
).Key
) then
105 return L_Node
.Element
= R_HT
.Nodes
(R_Node
).Element
;
108 R_Node
:= R_HT
.Nodes
(R_Node
).Next
;
114 -- Start of processing for "="
117 return Is_Equal
(Left
, Right
);
124 procedure Assign
(Target
: in out Map
; Source
: Map
) is
125 procedure Insert_Element
(Source_Node
: Count_Type
);
127 procedure Insert_Elements
is
128 new HT_Ops
.Generic_Iteration
(Insert_Element
);
134 procedure Insert_Element
(Source_Node
: Count_Type
) is
135 N
: Node_Type
renames Source
.Nodes
(Source_Node
);
140 Insert
(Target
, N
.Key
, N
.Element
, C
, B
);
144 -- Start of processing for Assign
147 if Target
'Address = Source
'Address then
151 if Target
.Capacity
< Source
.Length
then
153 with "Target capacity is less than Source length";
156 HT_Ops
.Clear
(Target
);
157 Insert_Elements
(Source
);
164 function Capacity
(Container
: Map
) return Count_Type
is
166 return Container
.Capacity
;
173 procedure Clear
(Container
: in out Map
) is
175 HT_Ops
.Clear
(Container
);
178 ------------------------
179 -- Constant_Reference --
180 ------------------------
182 function Constant_Reference
183 (Container
: aliased Map
;
184 Position
: Cursor
) return Constant_Reference_Type
187 if Position
.Container
= null then
188 raise Constraint_Error
with
189 "Position cursor has no element";
192 if Position
.Container
/= Container
'Unrestricted_Access then
193 raise Program_Error
with
194 "Position cursor designates wrong map";
197 pragma Assert
(Vet
(Position
),
198 "Position cursor in Constant_Reference is bad");
201 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
203 return (Element
=> N
.Element
'Access);
205 end Constant_Reference
;
207 function Constant_Reference
208 (Container
: aliased Map
;
209 Key
: Key_Type
) return Constant_Reference_Type
211 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
215 raise Constraint_Error
with "key not in map";
219 N
: Node_Type
renames Container
.Nodes
(Node
);
221 return (Element
=> N
.Element
'Access);
223 end Constant_Reference
;
229 function Contains
(Container
: Map
; Key
: Key_Type
) return Boolean is
231 return Find
(Container
, Key
) /= No_Element
;
240 Capacity
: Count_Type
:= 0;
241 Modulus
: Hash_Type
:= 0) return Map
250 elsif Capacity
>= Source
.Length
then
254 raise Capacity_Error
with "Capacity value too small";
258 M
:= Default_Modulus
(C
);
263 return Target
: Map
(Capacity
=> C
, Modulus
=> M
) do
264 Assign
(Target
=> Target
, Source
=> Source
);
268 ---------------------
269 -- Default_Modulus --
270 ---------------------
272 function Default_Modulus
(Capacity
: Count_Type
) return Hash_Type
is
274 return To_Prime
(Capacity
);
281 procedure Delete
(Container
: in out Map
; Key
: Key_Type
) is
285 Key_Ops
.Delete_Key_Sans_Free
(Container
, Key
, X
);
288 raise Constraint_Error
with "attempt to delete key not in map";
291 HT_Ops
.Free
(Container
, X
);
294 procedure Delete
(Container
: in out Map
; Position
: in out Cursor
) is
296 if Position
.Node
= 0 then
297 raise Constraint_Error
with
298 "Position cursor of Delete equals No_Element";
301 if Position
.Container
/= Container
'Unrestricted_Access then
302 raise Program_Error
with
303 "Position cursor of Delete designates wrong map";
306 if Container
.Busy
> 0 then
307 raise Program_Error
with
308 "Delete attempted to tamper with cursors (map is busy)";
311 pragma Assert
(Vet
(Position
), "bad cursor in Delete");
313 HT_Ops
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
314 HT_Ops
.Free
(Container
, Position
.Node
);
316 Position
:= No_Element
;
323 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
324 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
328 raise Constraint_Error
with
329 "no element available because key not in map";
332 return Container
.Nodes
(Node
).Element
;
335 function Element
(Position
: Cursor
) return Element_Type
is
337 if Position
.Node
= 0 then
338 raise Constraint_Error
with
339 "Position cursor of function Element equals No_Element";
342 pragma Assert
(Vet
(Position
), "bad cursor in function Element");
344 return Position
.Container
.Nodes
(Position
.Node
).Element
;
347 -------------------------
348 -- Equivalent_Key_Node --
349 -------------------------
351 function Equivalent_Key_Node
353 Node
: Node_Type
) return Boolean is
355 return Equivalent_Keys
(Key
, Node
.Key
);
356 end Equivalent_Key_Node
;
358 ---------------------
359 -- Equivalent_Keys --
360 ---------------------
362 function Equivalent_Keys
(Left
, Right
: Cursor
)
365 if Left
.Node
= 0 then
366 raise Constraint_Error
with
367 "Left cursor of Equivalent_Keys equals No_Element";
370 if Right
.Node
= 0 then
371 raise Constraint_Error
with
372 "Right cursor of Equivalent_Keys equals No_Element";
375 pragma Assert
(Vet
(Left
), "Left cursor of Equivalent_Keys is bad");
376 pragma Assert
(Vet
(Right
), "Right cursor of Equivalent_Keys is bad");
379 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
380 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
383 return Equivalent_Keys
(LN
.Key
, RN
.Key
);
387 function Equivalent_Keys
(Left
: Cursor
; Right
: Key_Type
) return Boolean is
389 if Left
.Node
= 0 then
390 raise Constraint_Error
with
391 "Left cursor of Equivalent_Keys equals No_Element";
394 pragma Assert
(Vet
(Left
), "Left cursor in Equivalent_Keys is bad");
397 LN
: Node_Type
renames Left
.Container
.Nodes
(Left
.Node
);
400 return Equivalent_Keys
(LN
.Key
, Right
);
404 function Equivalent_Keys
(Left
: Key_Type
; Right
: Cursor
) return Boolean is
406 if Right
.Node
= 0 then
407 raise Constraint_Error
with
408 "Right cursor of Equivalent_Keys equals No_Element";
411 pragma Assert
(Vet
(Right
), "Right cursor of Equivalent_Keys is bad");
414 RN
: Node_Type
renames Right
.Container
.Nodes
(Right
.Node
);
417 return Equivalent_Keys
(Left
, RN
.Key
);
425 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
428 Key_Ops
.Delete_Key_Sans_Free
(Container
, Key
, X
);
429 HT_Ops
.Free
(Container
, X
);
436 procedure Finalize
(Object
: in out Iterator
) is
438 if Object
.Container
/= null then
440 B
: Natural renames Object
.Container
.all.Busy
;
451 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
452 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
457 return Cursor
'(Container'Unrestricted_Access, Node);
465 function First (Container : Map) return Cursor is
466 Node : constant Count_Type := HT_Ops.First (Container);
471 return Cursor'(Container
'Unrestricted_Access, Node
);
475 function First
(Object
: Iterator
) return Cursor
is
477 return Object
.Container
.First
;
484 function Has_Element
(Position
: Cursor
) return Boolean is
486 pragma Assert
(Vet
(Position
), "bad cursor in Has_Element");
487 return Position
.Node
/= 0;
494 function Hash_Node
(Node
: Node_Type
) return Hash_Type
is
496 return Hash
(Node
.Key
);
504 (Container
: in out Map
;
506 New_Item
: Element_Type
)
512 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
515 if Container
.Lock
> 0 then
516 raise Program_Error
with
517 "Include attempted to tamper with elements (map is locked)";
521 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
524 N
.Element
:= New_Item
;
534 (Container
: in out Map
;
536 Position
: out Cursor
;
537 Inserted
: out Boolean)
539 procedure Assign_Key
(Node
: in out Node_Type
);
540 pragma Inline
(Assign_Key
);
542 function New_Node
return Count_Type
;
543 pragma Inline
(New_Node
);
545 procedure Local_Insert
is
546 new Key_Ops
.Generic_Conditional_Insert
(New_Node
);
548 procedure Allocate
is
549 new HT_Ops
.Generic_Allocate
(Assign_Key
);
555 procedure Assign_Key
(Node
: in out Node_Type
) is
559 -- Note that we do not also assign the element component of the node
560 -- here, because this version of Insert does not accept an element
563 -- Node.Element := New_Item;
564 -- What is this deleted code about???
571 function New_Node
return Count_Type
is
574 Allocate
(Container
, Result
);
578 -- Start of processing for Insert
581 -- The buckets array length is specified by the user as a discriminant
582 -- of the container type, so it is possible for the buckets array to
583 -- have a length of zero. We must check for this case specifically, in
584 -- order to prevent divide-by-zero errors later, when we compute the
585 -- buckets array index value for a key, given its hash value.
587 if Container
.Buckets
'Length = 0 then
588 raise Capacity_Error
with "No capacity for insertion";
591 Local_Insert
(Container
, Key
, Position
.Node
, Inserted
);
592 Position
.Container
:= Container
'Unchecked_Access;
596 (Container
: in out Map
;
598 New_Item
: Element_Type
;
599 Position
: out Cursor
;
600 Inserted
: out Boolean)
602 procedure Assign_Key
(Node
: in out Node_Type
);
603 pragma Inline
(Assign_Key
);
605 function New_Node
return Count_Type
;
606 pragma Inline
(New_Node
);
608 procedure Local_Insert
is
609 new Key_Ops
.Generic_Conditional_Insert
(New_Node
);
611 procedure Allocate
is
612 new HT_Ops
.Generic_Allocate
(Assign_Key
);
618 procedure Assign_Key
(Node
: in out Node_Type
) is
621 Node
.Element
:= New_Item
;
628 function New_Node
return Count_Type
is
631 Allocate
(Container
, Result
);
635 -- Start of processing for Insert
638 -- The buckets array length is specified by the user as a discriminant
639 -- of the container type, so it is possible for the buckets array to
640 -- have a length of zero. We must check for this case specifically, in
641 -- order to prevent divide-by-zero errors later, when we compute the
642 -- buckets array index value for a key, given its hash value.
644 if Container
.Buckets
'Length = 0 then
645 raise Capacity_Error
with "No capacity for insertion";
648 Local_Insert
(Container
, Key
, Position
.Node
, Inserted
);
649 Position
.Container
:= Container
'Unchecked_Access;
653 (Container
: in out Map
;
655 New_Item
: Element_Type
)
658 pragma Unreferenced
(Position
);
663 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
666 raise Constraint_Error
with
667 "attempt to insert key already in map";
675 function Is_Empty
(Container
: Map
) return Boolean is
677 return Container
.Length
= 0;
686 Process
: not null access procedure (Position
: Cursor
))
688 procedure Process_Node
(Node
: Count_Type
);
689 pragma Inline
(Process_Node
);
691 procedure Local_Iterate
is new HT_Ops
.Generic_Iteration
(Process_Node
);
697 procedure Process_Node
(Node
: Count_Type
) is
699 Process
(Cursor
'(Container'Unrestricted_Access, Node));
702 B : Natural renames Container'Unrestricted_Access.all.Busy;
704 -- Start of processing for Iterate
710 Local_Iterate (Container);
721 (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
723 B : Natural renames Container'Unrestricted_Access.all.Busy;
726 return It : constant Iterator :=
727 (Limited_Controlled with
728 Container => Container'Unrestricted_Access)
738 function Key (Position : Cursor) return Key_Type is
740 if Position.Node = 0 then
741 raise Constraint_Error with
742 "Position cursor of function Key equals No_Element";
745 pragma Assert (Vet (Position), "bad cursor in function Key");
747 return Position.Container.Nodes (Position.Node).Key;
754 function Length (Container : Map) return Count_Type is
756 return Container.Length;
764 (Target : in out Map;
768 if Target'Address = Source'Address then
772 if Source.Busy > 0 then
773 raise Program_Error with
774 "attempt to tamper with cursors (container is busy)";
777 Target.Assign (Source);
785 function Next (Node : Node_Type) return Count_Type is
790 function Next (Position : Cursor) return Cursor is
792 if Position.Node = 0 then
796 pragma Assert (Vet (Position), "bad cursor in function Next");
799 M : Map renames Position.Container.all;
800 Node : constant Count_Type := HT_Ops.Next (M, Position.Node);
805 return Cursor'(Position
.Container
, Node
);
810 procedure Next
(Position
: in out Cursor
) is
812 Position
:= Next
(Position
);
817 Position
: Cursor
) return Cursor
820 if Position
.Container
= null then
824 if Position
.Container
/= Object
.Container
then
825 raise Program_Error
with
826 "Position cursor of Next designates wrong map";
829 return Next
(Position
);
836 procedure Query_Element
838 Process
: not null access
839 procedure (Key
: Key_Type
; Element
: Element_Type
))
842 if Position
.Node
= 0 then
843 raise Constraint_Error
with
844 "Position cursor of Query_Element equals No_Element";
847 pragma Assert
(Vet
(Position
), "bad cursor in Query_Element");
850 M
: Map
renames Position
.Container
.all;
851 N
: Node_Type
renames M
.Nodes
(Position
.Node
);
852 B
: Natural renames M
.Busy
;
853 L
: Natural renames M
.Lock
;
862 Process
(N
.Key
, N
.Element
);
880 (Stream
: not null access Root_Stream_Type
'Class;
884 (Stream
: not null access Root_Stream_Type
'Class) return Count_Type
;
885 -- pragma Inline (Read_Node); ???
887 procedure Read_Nodes
is new HT_Ops
.Generic_Read
(Read_Node
);
894 (Stream
: not null access Root_Stream_Type
'Class) return Count_Type
896 procedure Read_Element
(Node
: in out Node_Type
);
897 -- pragma Inline (Read_Element); ???
899 procedure Allocate
is
900 new HT_Ops
.Generic_Allocate
(Read_Element
);
902 procedure Read_Element
(Node
: in out Node_Type
) is
904 Key_Type
'Read (Stream
, Node
.Key
);
905 Element_Type
'Read (Stream
, Node
.Element
);
910 -- Start of processing for Read_Node
913 Allocate
(Container
, Node
);
917 -- Start of processing for Read
920 Read_Nodes
(Stream
, Container
);
924 (Stream
: not null access Root_Stream_Type
'Class;
928 raise Program_Error
with "attempt to stream map cursor";
932 (Stream
: not null access Root_Stream_Type
'Class;
933 Item
: out Reference_Type
)
936 raise Program_Error
with "attempt to stream reference";
940 (Stream
: not null access Root_Stream_Type
'Class;
941 Item
: out Constant_Reference_Type
)
944 raise Program_Error
with "attempt to stream reference";
952 (Container
: aliased in out Map
;
953 Position
: Cursor
) return Reference_Type
956 if Position
.Container
= null then
957 raise Constraint_Error
with
958 "Position cursor has no element";
961 if Position
.Container
/= Container
'Unrestricted_Access then
962 raise Program_Error
with
963 "Position cursor designates wrong map";
966 pragma Assert
(Vet
(Position
),
967 "Position cursor in function Reference is bad");
970 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
972 return (Element
=> N
.Element
'Access);
977 (Container
: aliased in out Map
;
978 Key
: Key_Type
) return Reference_Type
980 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
984 raise Constraint_Error
with "key not in map";
988 N
: Node_Type
renames Container
.Nodes
(Node
);
990 return (Element
=> N
.Element
'Access);
999 (Container
: in out Map
;
1001 New_Item
: Element_Type
)
1003 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
1007 raise Constraint_Error
with
1008 "attempt to replace key not in map";
1011 if Container
.Lock
> 0 then
1012 raise Program_Error
with
1013 "Replace attempted to tamper with elements (map is locked)";
1017 N
: Node_Type
renames Container
.Nodes
(Node
);
1021 N
.Element
:= New_Item
;
1025 ---------------------
1026 -- Replace_Element --
1027 ---------------------
1029 procedure Replace_Element
1030 (Container
: in out Map
;
1032 New_Item
: Element_Type
)
1035 if Position
.Node
= 0 then
1036 raise Constraint_Error
with
1037 "Position cursor of Replace_Element equals No_Element";
1040 if Position
.Container
/= Container
'Unrestricted_Access then
1041 raise Program_Error
with
1042 "Position cursor of Replace_Element designates wrong map";
1045 if Position
.Container
.Lock
> 0 then
1046 raise Program_Error
with
1047 "Replace_Element attempted to tamper with elements (map is locked)";
1050 pragma Assert
(Vet
(Position
), "bad cursor in Replace_Element");
1052 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
1053 end Replace_Element
;
1055 ----------------------
1056 -- Reserve_Capacity --
1057 ----------------------
1059 procedure Reserve_Capacity
1060 (Container
: in out Map
;
1061 Capacity
: Count_Type
)
1064 if Capacity
> Container
.Capacity
then
1065 raise Capacity_Error
with "requested capacity is too large";
1067 end Reserve_Capacity
;
1073 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
) is
1078 --------------------
1079 -- Update_Element --
1080 --------------------
1082 procedure Update_Element
1083 (Container
: in out Map
;
1085 Process
: not null access procedure (Key
: Key_Type
;
1086 Element
: in out Element_Type
))
1089 if Position
.Node
= 0 then
1090 raise Constraint_Error
with
1091 "Position cursor of Update_Element equals No_Element";
1094 if Position
.Container
/= Container
'Unrestricted_Access then
1095 raise Program_Error
with
1096 "Position cursor of Update_Element designates wrong map";
1099 pragma Assert
(Vet
(Position
), "bad cursor in Update_Element");
1102 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
1103 B
: Natural renames Container
.Busy
;
1104 L
: Natural renames Container
.Lock
;
1111 Process
(N
.Key
, N
.Element
);
1128 function Vet
(Position
: Cursor
) return Boolean is
1130 if Position
.Node
= 0 then
1131 return Position
.Container
= null;
1134 if Position
.Container
= null then
1139 M
: Map
renames Position
.Container
.all;
1143 if M
.Length
= 0 then
1147 if M
.Capacity
= 0 then
1151 if M
.Buckets
'Length = 0 then
1155 if Position
.Node
> M
.Capacity
then
1159 if M
.Nodes
(Position
.Node
).Next
= Position
.Node
then
1163 X
:= M
.Buckets
(Key_Ops
.Index
(M
, M
.Nodes
(Position
.Node
).Key
));
1165 for J
in 1 .. M
.Length
loop
1166 if X
= Position
.Node
then
1174 if X
= M
.Nodes
(X
).Next
then -- to prevent unnecessary looping
1178 X
:= M
.Nodes
(X
).Next
;
1190 (Stream
: not null access Root_Stream_Type
'Class;
1193 procedure Write_Node
1194 (Stream
: not null access Root_Stream_Type
'Class;
1196 pragma Inline
(Write_Node
);
1198 procedure Write_Nodes
is new HT_Ops
.Generic_Write
(Write_Node
);
1204 procedure Write_Node
1205 (Stream
: not null access Root_Stream_Type
'Class;
1209 Key_Type
'Write (Stream
, Node
.Key
);
1210 Element_Type
'Write (Stream
, Node
.Element
);
1213 -- Start of processing for Write
1216 Write_Nodes
(Stream
, Container
);
1220 (Stream
: not null access Root_Stream_Type
'Class;
1224 raise Program_Error
with "attempt to stream map cursor";
1228 (Stream
: not null access Root_Stream_Type
'Class;
1229 Item
: Reference_Type
)
1232 raise Program_Error
with "attempt to stream reference";
1236 (Stream
: not null access Root_Stream_Type
'Class;
1237 Item
: Constant_Reference_Type
)
1240 raise Program_Error
with "attempt to stream reference";
1243 end Ada
.Containers
.Bounded_Hashed_Maps
;