1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . H T A B L E --
9 -- Copyright (C) 1995-2011, AdaCore --
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 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
34 with Ada.Unchecked_Deallocation;
35 with System.String_Hash;
37 package body System.HTable is
43 package body Static_HTable is
45 Table : array (Header_Num) of Elmt_Ptr;
47 Iterator_Index : Header_Num;
48 Iterator_Ptr : Elmt_Ptr;
49 Iterator_Started : Boolean := False;
51 function Get_Non_Null return Elmt_Ptr;
52 -- Returns Null_Ptr if Iterator_Started is false or the Table is empty.
53 -- Returns Iterator_Ptr if non null, or the next non null element in
60 function Get (K : Key) return Elmt_Ptr is
64 Elmt := Table (Hash (K));
67 if Elmt = Null_Ptr then
70 elsif Equal (Get_Key (Elmt), K) then
83 function Get_First return Elmt_Ptr is
85 Iterator_Started := True;
86 Iterator_Index := Table'First;
87 Iterator_Ptr := Table (Iterator_Index);
95 function Get_Next return Elmt_Ptr is
97 if not Iterator_Started then
101 Iterator_Ptr := Next (Iterator_Ptr);
109 function Get_Non_Null return Elmt_Ptr is
111 while Iterator_Ptr = Null_Ptr loop
112 if Iterator_Index = Table'Last then
113 Iterator_Started := False;
117 Iterator_Index := Iterator_Index + 1;
118 Iterator_Ptr := Table (Iterator_Index);
128 function Present (K : Key) return Boolean is
130 return Get (K) /= Null_Ptr;
137 procedure Remove (K : Key) is
138 Index : constant Header_Num := Hash (K);
140 Next_Elmt : Elmt_Ptr;
143 Elmt := Table (Index);
145 if Elmt = Null_Ptr then
148 elsif Equal (Get_Key (Elmt), K) then
149 Table (Index) := Next (Elmt);
153 Next_Elmt := Next (Elmt);
155 if Next_Elmt = Null_Ptr then
158 elsif Equal (Get_Key (Next_Elmt), K) then
159 Set_Next (Elmt, Next (Next_Elmt));
175 for J in Table'Range loop
176 Table (J) := Null_Ptr;
184 procedure Set (E : Elmt_Ptr) is
188 Index := Hash (Get_Key (E));
189 Set_Next (E, Table (Index));
193 ------------------------
194 -- Set_If_Not_Present --
195 ------------------------
197 function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
198 K : constant Key := Get_Key (E);
199 Index : constant Header_Num := Hash (K);
200 Elmt : Elmt_Ptr := Table (Index);
204 if Elmt = Null_Ptr then
205 Set_Next (E, Table (Index));
210 elsif Equal (Get_Key (Elmt), K) then
217 end Set_If_Not_Present;
225 package body Simple_HTable is
227 type Element_Wrapper;
228 type Elmt_Ptr is access all Element_Wrapper;
229 type Element_Wrapper is record
235 procedure Free is new
236 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
238 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
239 function Next (E : Elmt_Ptr) return Elmt_Ptr;
240 function Get_Key (E : Elmt_Ptr) return Key;
242 package Tab is new Static_HTable (
243 Header_Num => Header_Num,
244 Element => Element_Wrapper,
245 Elmt_Ptr => Elmt_Ptr,
247 Set_Next => Set_Next,
258 function Get (K : Key) return Element is
259 Tmp : constant Elmt_Ptr := Tab.Get (K);
272 function Get_First return Element is
273 Tmp : constant Elmt_Ptr := Tab.Get_First;
282 procedure Get_First (K : in out Key; E : out Element) is
283 Tmp : constant Elmt_Ptr := Tab.Get_First;
297 function Get_Key (E : Elmt_Ptr) return Key is
306 function Get_Next return Element is
307 Tmp : constant Elmt_Ptr := Tab.Get_Next;
316 procedure Get_Next (K : in out Key; E : out Element) is
317 Tmp : constant Elmt_Ptr := Tab.Get_Next;
331 function Next (E : Elmt_Ptr) return Elmt_Ptr is
340 procedure Remove (K : Key) is
361 while E1 /= null loop
374 procedure Set (K : Key; E : Element) is
375 Tmp : constant Elmt_Ptr := Tab.Get (K);
378 Tab.Set (new Element_Wrapper'(K, E, null));
388 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
398 function Hash (Key : String) return Header_Num is
399 type Uns is mod 2 ** 32;
402 new System.String_Hash.Hash (Character, String, Uns);
405 return Header_Num'First +
406 Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);