1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
11 -- This specification is derived from the Ada Reference Manual for use with --
12 -- GNAT. The copyright notice above, and the license provisions that follow --
13 -- apply solely to the contents of the part following the private keyword. --
15 -- GNAT is free software; you can redistribute it and/or modify it under --
16 -- terms of the GNU General Public License as published by the Free Soft- --
17 -- ware Foundation; either version 2, or (at your option) any later ver- --
18 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
19 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
20 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
21 -- for more details. You should have received a copy of the GNU General --
22 -- Public License distributed with GNAT; see file COPYING. If not, write --
23 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
24 -- MA 02111-1307, USA. --
26 -- As a special exception, if other files instantiate generics from this --
27 -- unit, or you link this unit with other files to produce an executable, --
28 -- this unit does not by itself cause the resulting executable to be --
29 -- covered by the GNU General Public License. This exception does not --
30 -- however invalidate any other reasons why the executable file might be --
31 -- covered by the GNU Public License. --
33 -- This unit has originally being developed by Matthew J Heaney. --
34 ------------------------------------------------------------------------------
36 with Ada
.Containers
.Hash_Tables
.Generic_Operations
;
37 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Operations
);
39 with Ada
.Containers
.Hash_Tables
.Generic_Keys
;
40 pragma Elaborate_All
(Ada
.Containers
.Hash_Tables
.Generic_Keys
);
42 with Ada
.Unchecked_Deallocation
;
44 package body Ada
.Containers
.Indefinite_Hashed_Maps
is
46 type Key_Access
is access Key_Type
;
47 type Element_Access
is access Element_Type
;
49 type Node_Type
is limited record
51 Element
: Element_Access
;
56 new Ada
.Unchecked_Deallocation
(Key_Type
, Key_Access
);
58 procedure Free_Element
is
59 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
65 function Copy_Node
(Node
: Node_Access
) return Node_Access
;
66 pragma Inline
(Copy_Node
);
68 function Equivalent_Keys
70 Node
: Node_Access
) return Boolean;
71 pragma Inline
(Equivalent_Keys
);
73 function Find_Equal_Key
75 L_Node
: Node_Access
) return Boolean;
77 procedure Free
(X
: in out Node_Access
);
80 function Hash_Node
(Node
: Node_Access
) return Hash_Type
;
81 pragma Inline
(Hash_Node
);
83 function Next
(Node
: Node_Access
) return Node_Access
;
87 (Stream
: access Root_Stream_Type
'Class) return Node_Access
;
89 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
);
90 pragma Inline
(Set_Next
);
93 (Stream
: access Root_Stream_Type
'Class;
96 --------------------------
97 -- Local Instantiations --
98 --------------------------
101 new Ada
.Containers
.Hash_Tables
.Generic_Operations
102 (HT_Types
=> HT_Types
,
103 Hash_Table_Type
=> Map
,
105 Hash_Node
=> Hash_Node
,
107 Set_Next
=> Set_Next
,
108 Copy_Node
=> Copy_Node
,
112 new Hash_Tables
.Generic_Keys
113 (HT_Types
=> HT_Types
,
117 Set_Next
=> Set_Next
,
118 Key_Type
=> Key_Type
,
120 Equivalent_Keys
=> Equivalent_Keys
);
126 function Is_Equal
is new HT_Ops
.Generic_Equal
(Find_Equal_Key
);
128 function "=" (Left
, Right
: Map
) return Boolean renames Is_Equal
;
134 procedure Adjust
(Container
: in out Map
) renames HT_Ops
.Adjust
;
140 function Capacity
(Container
: Map
)
141 return Count_Type
renames HT_Ops
.Capacity
;
147 procedure Clear
(Container
: in out Map
) renames HT_Ops
.Clear
;
153 function Contains
(Container
: Map
; Key
: Key_Type
) return Boolean is
155 return Find
(Container
, Key
) /= No_Element
;
162 function Copy_Node
(Node
: Node_Access
) return Node_Access
is
163 K
: Key_Access
:= new Key_Type
'(Node.Key.all);
167 E := new Element_Type'(Node
.Element
.all);
168 return new Node_Type
'(K, E, null);
181 procedure Delete (Container : in out Map; Key : Key_Type) is
185 Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
188 raise Constraint_Error;
194 procedure Delete (Container : in out Map; Position : in out Cursor) is
196 if Position = No_Element then
200 if Position.Container /= Map_Access'(Container
'Unchecked_Access) then
204 HT_Ops
.Delete_Node_Sans_Free
(Container
, Position
.Node
);
205 Free
(Position
.Node
);
207 Position
.Container
:= null;
214 function Element
(Container
: Map
; Key
: Key_Type
) return Element_Type
is
215 C
: constant Cursor
:= Find
(Container
, Key
);
217 return C
.Node
.Element
.all;
220 function Element
(Position
: Cursor
) return Element_Type
is
222 return Position
.Node
.Element
.all;
225 ---------------------
226 -- Equivalent_Keys --
227 ---------------------
229 function Equivalent_Keys
231 Node
: Node_Access
) return Boolean
234 return Equivalent_Keys
(Key
, Node
.Key
.all);
237 function Equivalent_Keys
(Left
, Right
: Cursor
) return Boolean is
239 return Equivalent_Keys
(Left
.Node
.Key
.all, Right
.Node
.Key
.all);
242 function Equivalent_Keys
244 Right
: Key_Type
) return Boolean
247 return Equivalent_Keys
(Left
.Node
.Key
.all, Right
);
250 function Equivalent_Keys
252 Right
: Cursor
) return Boolean
255 return Equivalent_Keys
(Left
, Right
.Node
.Key
.all);
262 procedure Exclude
(Container
: in out Map
; Key
: Key_Type
) is
265 Key_Ops
.Delete_Key_Sans_Free
(Container
, Key
, X
);
273 procedure Finalize
(Container
: in out Map
) renames HT_Ops
.Finalize
;
279 function Find
(Container
: Map
; Key
: Key_Type
) return Cursor
is
280 Node
: constant Node_Access
:= Key_Ops
.Find
(Container
, Key
);
287 return Cursor
'(Container'Unchecked_Access, Node);
294 function Find_Equal_Key
296 L_Node : Node_Access) return Boolean
298 R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key.all);
299 R_Node : Node_Access := R_Map.Buckets (R_Index);
302 while R_Node /= null loop
303 if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
304 return L_Node.Element.all = R_Node.Element.all;
307 R_Node := R_Node.Next;
317 function First (Container : Map) return Cursor is
318 Node : constant Node_Access := HT_Ops.First (Container);
324 return Cursor'(Container
'Unchecked_Access, Node
);
331 procedure Free
(X
: in out Node_Access
) is
332 procedure Deallocate
is
333 new Ada
.Unchecked_Deallocation
(Node_Type
, Node_Access
);
337 Free_Element
(X
.Element
);
346 function Has_Element
(Position
: Cursor
) return Boolean is
348 return Position
/= No_Element
;
355 function Hash_Node
(Node
: Node_Access
) return Hash_Type
is
357 return Hash
(Node
.Key
.all);
365 (Container
: in out Map
;
367 New_Item
: Element_Type
)
376 Insert
(Container
, Key
, New_Item
, Position
, Inserted
);
379 K
:= Position
.Node
.Key
;
380 E
:= Position
.Node
.Element
;
382 Position
.Node
.Key
:= new Key_Type
'(Key);
383 Position.Node.Element := new Element_Type'(New_Item
);
395 (Container
: in out Map
;
397 New_Item
: Element_Type
;
398 Position
: out Cursor
;
399 Inserted
: out Boolean)
401 function New_Node
(Next
: Node_Access
) return Node_Access
;
404 new Key_Ops
.Generic_Conditional_Insert
(New_Node
);
410 function New_Node
(Next
: Node_Access
) return Node_Access
is
411 K
: Key_Access
:= new Key_Type
'(Key);
414 E := new Element_Type'(New_Item
);
415 return new Node_Type
'(K, E, Next);
423 -- Start of processing for Insert
426 HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
427 Insert (Container, Key, Position.Node, Inserted);
428 Position.Container := Container'Unchecked_Access;
432 (Container : in out Map;
434 New_Item : Element_Type)
440 Insert (Container, Key, New_Item, Position, Inserted);
443 raise Constraint_Error;
451 function Is_Empty (Container : Map) return Boolean is
453 return Container.Length = 0;
462 Process : not null access procedure (Position : Cursor))
464 procedure Process_Node (Node : Node_Access);
465 pragma Inline (Process_Node);
468 new HT_Ops.Generic_Iteration (Process_Node);
474 procedure Process_Node (Node : Node_Access) is
476 Process (Cursor'(Container
'Unchecked_Access, Node
));
479 -- Start of processing Iterate
489 function Key
(Position
: Cursor
) return Key_Type
is
491 return Position
.Node
.Key
.all;
498 function Length
(Container
: Map
) return Count_Type
is
500 return Container
.Length
;
508 (Target
: in out Map
;
509 Source
: in out Map
) renames HT_Ops
.Move
;
515 function Next
(Node
: Node_Access
) return Node_Access
is
520 procedure Next
(Position
: in out Cursor
) is
522 Position
:= Next
(Position
);
525 function Next
(Position
: Cursor
) return Cursor
is
527 if Position
= No_Element
then
532 M
: Map
renames Position
.Container
.all;
533 Node
: constant Node_Access
:= HT_Ops
.Next
(M
, Position
.Node
);
540 return Cursor
'(Position.Container, Node);
548 procedure Query_Element
550 Process : not null access procedure (Element : Element_Type))
553 Process (Position.Node.Key.all, Position.Node.Element.all);
560 procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
563 (Stream : access Root_Stream_Type'Class;
564 Container : out Map) renames Read_Nodes;
571 (Stream : access Root_Stream_Type'Class) return Node_Access
573 Node : Node_Access := new Node_Type;
577 Node.Key := new Key_Type'(Key_Type
'Input (Stream
));
585 Node
.Element
:= new Element_Type
'(Element_Type'Input (Stream));
601 (Container : in out Map;
603 New_Item : Element_Type)
605 Node : constant Node_Access := Key_Ops.Find (Container, Key);
612 raise Constraint_Error;
618 Node.Key := new Key_Type'(Key
);
619 Node
.Element
:= new Element_Type
'(New_Item);
625 ---------------------
626 -- Replace_Element --
627 ---------------------
629 procedure Replace_Element (Position : Cursor; By : Element_Type) is
630 X : Element_Access := Position.Node.Element;
632 Position.Node.Element := new Element_Type'(By
);
636 ----------------------
637 -- Reserve_Capacity --
638 ----------------------
640 procedure Reserve_Capacity
641 (Container
: in out Map
;
642 Capacity
: Count_Type
) renames HT_Ops
.Ensure_Capacity
;
648 procedure Set_Next
(Node
: Node_Access
; Next
: Node_Access
) is
657 procedure Update_Element
659 Process
: not null access procedure (Element
: in out Element_Type
))
662 Process
(Position
.Node
.Key
.all, Position
.Node
.Element
.all);
669 procedure Write_Nodes
is new HT_Ops
.Generic_Write
(Write_Node
);
672 (Stream
: access Root_Stream_Type
'Class;
673 Container
: Map
) renames Write_Nodes
;
680 (Stream
: access Root_Stream_Type
'Class;
684 Key_Type
'Output (Stream
, Node
.Key
.all);
685 Element_Type
'Output (Stream
, Node
.Element
.all);
688 end Ada
.Containers
.Indefinite_Hashed_Maps
;