1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S --
9 -- Copyright (C) 2010-2014, 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/>. --
26 ------------------------------------------------------------------------------
28 with Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
;
29 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Bounded_Operations
);
31 with Ada
.Containers
.Hash_Tables
.Generic_Bounded_Keys
;
32 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Bounded_Keys
);
34 with Ada
.Containers
.Prime_Numbers
; use Ada
.Containers
.Prime_Numbers
;
36 with System
; use type System
.Address
;
38 package body Ada
.Containers
.Formal_Hashed_Maps
is
39 pragma SPARK_Mode
(Off
);
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 -- All local subprograms require comments ???
47 function Equivalent_Keys
49 Node
: Node_Type
) return Boolean;
50 pragma Inline
(Equivalent_Keys
);
57 with procedure Set_Element
(Node
: in out Node_Type
);
58 procedure Generic_Allocate
60 Node
: out Count_Type
);
62 function Hash_Node
(Node
: Node_Type
) return Hash_Type
;
63 pragma Inline
(Hash_Node
);
65 function Next
(Node
: Node_Type
) return Count_Type
;
68 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
);
69 pragma Inline
(Set_Next
);
71 function Vet
(Container
: Map
; Position
: Cursor
) return Boolean;
73 --------------------------
74 -- Local Instantiations --
75 --------------------------
78 new Hash_Tables
.Generic_Bounded_Operations
79 (HT_Types
=> HT_Types
,
80 Hash_Node
=> Hash_Node
,
82 Set_Next
=> Set_Next
);
85 new Hash_Tables
.Generic_Bounded_Keys
86 (HT_Types
=> HT_Types
,
91 Equivalent_Keys
=> Equivalent_Keys
);
97 function "=" (Left
, Right
: Map
) return Boolean is
99 if Length
(Left
) /= Length
(Right
) then
103 if Length
(Left
) = 0 then
112 Node
:= Left
.First
.Node
;
114 ENode
:= Find
(Container
=> Right
,
115 Key
=> Left
.Nodes
(Node
).Key
).Node
;
118 Right
.Nodes
(ENode
).Element
/= Left
.Nodes
(Node
).Element
123 Node
:= HT_Ops
.Next
(Left
, Node
);
134 procedure Assign
(Target
: in out Map
; Source
: Map
) is
135 procedure Insert_Element
(Source_Node
: Count_Type
);
136 pragma Inline
(Insert_Element
);
138 procedure Insert_Elements
is
139 new HT_Ops
.Generic_Iteration
(Insert_Element
);
145 procedure Insert_Element
(Source_Node
: Count_Type
) is
146 N
: Node_Type
renames Source
.Nodes
(Source_Node
);
148 Insert
(Target
, N
.Key
, N
.Element
);
151 -- Start of processing for Assign
154 if Target
'Address = Source
'Address then
158 if Target
.Capacity
< Length
(Source
) then
159 raise Constraint_Error
with -- correct exception ???
160 "Source length exceeds Target capacity";
165 Insert_Elements
(Source
);
172 function Capacity
(Container
: Map
) return Count_Type
is
174 return Container
.Nodes
'Length;
181 procedure Clear
(Container
: in out Map
) is
183 HT_Ops
.Clear
(Container
);
190 function Contains
(Container
: Map
; Key
: Key_Type
) return Boolean is
192 return Find
(Container
, Key
) /= No_Element
;
201 Capacity
: Count_Type
:= 0) return Map
203 C
: constant Count_Type
:=
204 Count_Type
'Max (Capacity
, Source
.Capacity
);
207 Target
: Map
(C
, Source
.Modulus
);
211 if 0 < Capacity
and then Capacity
< Source
.Capacity
then
212 raise Capacity_Error
;
215 Target
.Length
:= Source
.Length
;
216 Target
.Free
:= Source
.Free
;
219 while H
<= Source
.Modulus
loop
220 Target
.Buckets
(H
) := Source
.Buckets
(H
);
225 while N
<= Source
.Capacity
loop
226 Target
.Nodes
(N
) := Source
.Nodes
(N
);
232 Free
(Target
, Cu
.Node
);
239 ---------------------
240 -- Current_To_Last --
241 ---------------------
243 function Current_To_Last
(Container
: Map
; Current
: Cursor
) return Map
is
244 Curs
: Cursor
:= First
(Container
);
245 C
: Map
(Container
.Capacity
, Container
.Modulus
) :=
246 Copy
(Container
, Container
.Capacity
);
250 if Curs
= No_Element
then
254 elsif Current
/= No_Element
and not Has_Element
(Container
, Current
) then
255 raise Constraint_Error
;
258 while Curs
.Node
/= Current
.Node
loop
261 Curs
:= Next
(Container
, (Node
=> Node
));
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";
294 procedure Delete
(Container
: in out Map
; Position
: in out Cursor
) is
296 if not Has_Element
(Container
, Position
) then
297 raise Constraint_Error
with
298 "Position cursor of Delete has no element";
301 pragma Assert
(Vet
(Container
, Position
), "bad cursor in Delete");
303 HT_Ops
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
305 Free
(Container
, Position
.Node
);
312 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
313 Node
: constant Count_Type
:= Find
(Container
, Key
).Node
;
317 raise Constraint_Error
with
318 "no element available because key not in map";
321 return Container
.Nodes
(Node
).Element
;
324 function Element
(Container
: Map
; Position
: Cursor
) return Element_Type
is
326 if not Has_Element
(Container
, Position
) then
327 raise Constraint_Error
with "Position cursor equals No_Element";
330 pragma Assert
(Vet
(Container
, Position
),
331 "bad cursor in function Element");
333 return Container
.Nodes
(Position
.Node
).Element
;
336 ---------------------
337 -- Equivalent_Keys --
338 ---------------------
340 function Equivalent_Keys
342 Node
: Node_Type
) return Boolean
345 return Equivalent_Keys
(Key
, Node
.Key
);
348 function Equivalent_Keys
352 CRight
: Cursor
) return Boolean
355 if not Has_Element
(Left
, CLeft
) then
356 raise Constraint_Error
with
357 "Left cursor of Equivalent_Keys has no element";
360 if not Has_Element
(Right
, CRight
) then
361 raise Constraint_Error
with
362 "Right cursor of Equivalent_Keys has no element";
365 pragma Assert
(Vet
(Left
, CLeft
),
366 "Left cursor of Equivalent_Keys is bad");
367 pragma Assert
(Vet
(Right
, CRight
),
368 "Right cursor of Equivalent_Keys is bad");
371 LN
: Node_Type
renames Left
.Nodes
(CLeft
.Node
);
372 RN
: Node_Type
renames Right
.Nodes
(CRight
.Node
);
374 return Equivalent_Keys
(LN
.Key
, RN
.Key
);
378 function Equivalent_Keys
381 Right
: Key_Type
) return Boolean
384 if not Has_Element
(Left
, CLeft
) then
385 raise Constraint_Error
with
386 "Left cursor of Equivalent_Keys has no element";
389 pragma Assert
(Vet
(Left
, CLeft
),
390 "Left cursor in Equivalent_Keys is bad");
393 LN
: Node_Type
renames Left
.Nodes
(CLeft
.Node
);
395 return Equivalent_Keys
(LN
.Key
, Right
);
399 function Equivalent_Keys
402 CRight
: Cursor
) return Boolean
405 if Has_Element
(Right
, CRight
) then
406 raise Constraint_Error
with
407 "Right cursor of Equivalent_Keys has no element";
410 pragma Assert
(Vet
(Right
, CRight
),
411 "Right cursor of Equivalent_Keys is bad");
414 RN
: Node_Type
renames Right
.Nodes
(CRight
.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
);
436 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
437 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
444 return (Node
=> Node
);
451 function First
(Container
: Map
) return Cursor
is
452 Node
: constant Count_Type
:= HT_Ops
.First
(Container
);
459 return (Node
=> Node
);
462 -----------------------
463 -- First_To_Previous --
464 -----------------------
466 function First_To_Previous
468 Current
: Cursor
) return Map
is
470 C
: Map
(Container
.Capacity
, Container
.Modulus
) :=
471 Copy
(Container
, Container
.Capacity
);
477 if Curs
= No_Element
then
480 elsif not Has_Element
(Container
, Curs
) then
481 raise Constraint_Error
;
484 while Curs
.Node
/= 0 loop
487 Curs
:= Next
(Container
, (Node
=> Node
));
492 end First_To_Previous
;
498 procedure Free
(HT
: in out Map
; X
: Count_Type
) is
500 HT
.Nodes
(X
).Has_Element
:= False;
504 ----------------------
505 -- Generic_Allocate --
506 ----------------------
508 procedure Generic_Allocate
(HT
: in out Map
; Node
: out Count_Type
) is
510 procedure Allocate
is
511 new HT_Ops
.Generic_Allocate
(Set_Element
);
515 HT
.Nodes
(Node
).Has_Element
:= True;
516 end Generic_Allocate
;
522 function Has_Element
(Container
: Map
; Position
: Cursor
) return Boolean is
525 or else not Container
.Nodes
(Position
.Node
).Has_Element
537 function Hash_Node
(Node
: Node_Type
) return Hash_Type
is
539 return Hash
(Node
.Key
);
547 (Container
: in out Map
;
549 New_Item
: Element_Type
)
555 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
559 N
: Node_Type
renames Container
.Nodes
(Position
.Node
);
562 N
.Element
:= New_Item
;
572 (Container
: in out Map
;
574 New_Item
: Element_Type
;
575 Position
: out Cursor
;
576 Inserted
: out Boolean)
578 procedure Assign_Key
(Node
: in out Node_Type
);
579 pragma Inline
(Assign_Key
);
581 function New_Node
return Count_Type
;
582 pragma Inline
(New_Node
);
584 procedure Local_Insert
is
585 new Key_Ops
.Generic_Conditional_Insert
(New_Node
);
587 procedure Allocate
is
588 new Generic_Allocate
(Assign_Key
);
594 procedure Assign_Key
(Node
: in out Node_Type
) is
597 Node
.Element
:= New_Item
;
604 function New_Node
return Count_Type
is
607 Allocate
(Container
, Result
);
611 -- Start of processing for Insert
614 Local_Insert
(Container
, Key
, Position
.Node
, Inserted
);
618 (Container
: in out Map
;
620 New_Item
: Element_Type
)
623 pragma Unreferenced
(Position
);
628 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
631 raise Constraint_Error
with
632 "attempt to insert key already in map";
640 function Is_Empty
(Container
: Map
) return Boolean is
642 return Length
(Container
) = 0;
649 function Key
(Container
: Map
; Position
: Cursor
) return Key_Type
is
651 if not Has_Element
(Container
, Position
) then
652 raise Constraint_Error
with
653 "Position cursor of function Key has no element";
656 pragma Assert
(Vet
(Container
, Position
), "bad cursor in function Key");
658 return Container
.Nodes
(Position
.Node
).Key
;
665 function Length
(Container
: Map
) return Count_Type
is
667 return Container
.Length
;
675 (Target
: in out Map
;
678 NN
: HT_Types
.Nodes_Type
renames Source
.Nodes
;
682 if Target
'Address = Source
'Address then
686 if Target
.Capacity
< Length
(Source
) then
687 raise Constraint_Error
with -- ???
688 "Source length exceeds Target capacity";
693 if Source
.Length
= 0 then
697 X
:= HT_Ops
.First
(Source
);
699 Insert
(Target
, NN
(X
).Key
, NN
(X
).Element
); -- optimize???
701 Y
:= HT_Ops
.Next
(Source
, X
);
703 HT_Ops
.Delete_Node_Sans_Free
(Source
, X
);
714 function Next
(Node
: Node_Type
) return Count_Type
is
719 function Next
(Container
: Map
; Position
: Cursor
) return Cursor
is
721 if Position
.Node
= 0 then
725 if not Has_Element
(Container
, Position
) then
726 raise Constraint_Error
727 with "Position has no element";
730 pragma Assert
(Vet
(Container
, Position
), "bad cursor in function Next");
733 Node
: constant Count_Type
:= HT_Ops
.Next
(Container
, Position
.Node
);
740 return (Node
=> Node
);
744 procedure Next
(Container
: Map
; Position
: in out Cursor
) is
746 Position
:= Next
(Container
, Position
);
753 function Overlap
(Left
, Right
: Map
) return Boolean is
754 Left_Node
: Count_Type
;
755 Left_Nodes
: Nodes_Type
renames Left
.Nodes
;
758 if Length
(Right
) = 0 or Length
(Left
) = 0 then
762 if Left
'Address = Right
'Address then
766 Left_Node
:= First
(Left
).Node
;
767 while Left_Node
/= 0 loop
769 N
: Node_Type
renames Left_Nodes
(Left_Node
);
770 E
: Key_Type
renames N
.Key
;
772 if Find
(Right
, E
).Node
/= 0 then
777 Left_Node
:= HT_Ops
.Next
(Left
, Left_Node
);
788 (Container
: in out Map
;
790 New_Item
: Element_Type
)
792 Node
: constant Count_Type
:= Key_Ops
.Find
(Container
, Key
);
796 raise Constraint_Error
with
797 "attempt to replace key not in map";
801 N
: Node_Type
renames Container
.Nodes
(Node
);
804 N
.Element
:= New_Item
;
808 ---------------------
809 -- Replace_Element --
810 ---------------------
812 procedure Replace_Element
813 (Container
: in out Map
;
815 New_Item
: Element_Type
)
818 if not Has_Element
(Container
, Position
) then
819 raise Constraint_Error
with
820 "Position cursor of Replace_Element has no element";
823 pragma Assert
(Vet
(Container
, Position
),
824 "bad cursor in Replace_Element");
826 Container
.Nodes
(Position
.Node
).Element
:= New_Item
;
829 ----------------------
830 -- Reserve_Capacity --
831 ----------------------
833 procedure Reserve_Capacity
834 (Container
: in out Map
;
835 Capacity
: Count_Type
)
838 if Capacity
> Container
.Capacity
then
839 raise Capacity_Error
with "requested capacity is too large";
841 end Reserve_Capacity
;
847 procedure Set_Next
(Node
: in out Node_Type
; Next
: Count_Type
) is
856 function Strict_Equal
(Left
, Right
: Map
) return Boolean is
857 CuL
: Cursor
:= First
(Left
);
858 CuR
: Cursor
:= First
(Right
);
861 if Length
(Left
) /= Length
(Right
) then
865 while CuL
.Node
/= 0 or else CuR
.Node
/= 0 loop
866 if CuL
.Node
/= CuR
.Node
868 Left
.Nodes
(CuL
.Node
).Element
/= Right
.Nodes
(CuR
.Node
).Element
869 or else Left
.Nodes
(CuL
.Node
).Key
/= Right
.Nodes
(CuR
.Node
).Key
874 CuL
:= Next
(Left
, CuL
);
875 CuR
:= Next
(Right
, CuR
);
885 function Vet
(Container
: Map
; Position
: Cursor
) return Boolean is
887 if Position
.Node
= 0 then
895 if Container
.Length
= 0 then
899 if Container
.Capacity
= 0 then
903 if Container
.Buckets
'Length = 0 then
907 if Position
.Node
> Container
.Capacity
then
911 if Container
.Nodes
(Position
.Node
).Next
= Position
.Node
then
915 X
:= Container
.Buckets
916 (Key_Ops
.Index
(Container
, Container
.Nodes
(Position
.Node
).Key
));
918 for J
in 1 .. Container
.Length
loop
919 if X
= Position
.Node
then
927 if X
= Container
.Nodes
(X
).Next
then
929 -- Prevent unnecessary looping
934 X
:= Container
.Nodes
(X
).Next
;
941 end Ada
.Containers
.Formal_Hashed_Maps
;