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;