1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . H T A B L E --
9 -- Copyright (C) 1995-2012, 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));
66 if Elmt = Null_Ptr then
69 elsif Equal (Get_Key (Elmt), K) then
82 function Get_First return Elmt_Ptr is
84 Iterator_Started := True;
85 Iterator_Index := Table'First;
86 Iterator_Ptr := Table (Iterator_Index);
94 function Get_Next return Elmt_Ptr is
96 if not Iterator_Started then
99 Iterator_Ptr := Next (Iterator_Ptr);
108 function Get_Non_Null return Elmt_Ptr is
110 while Iterator_Ptr = Null_Ptr loop
111 if Iterator_Index = Table'Last then
112 Iterator_Started := False;
116 Iterator_Index := Iterator_Index + 1;
117 Iterator_Ptr := Table (Iterator_Index);
127 function Present (K : Key) return Boolean is
129 return Get (K) /= Null_Ptr;
136 procedure Remove (K : Key) is
137 Index : constant Header_Num := Hash (K);
139 Next_Elmt : Elmt_Ptr;
142 Elmt := Table (Index);
144 if Elmt = Null_Ptr then
147 elsif Equal (Get_Key (Elmt), K) then
148 Table (Index) := Next (Elmt);
152 Next_Elmt := Next (Elmt);
154 if Next_Elmt = Null_Ptr then
157 elsif Equal (Get_Key (Next_Elmt), K) then
158 Set_Next (Elmt, Next (Next_Elmt));
174 for J in Table'Range loop
175 Table (J) := Null_Ptr;
183 procedure Set (E : Elmt_Ptr) is
186 Index := Hash (Get_Key (E));
187 Set_Next (E, Table (Index));
191 ------------------------
192 -- Set_If_Not_Present --
193 ------------------------
195 function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
196 K : Key renames Get_Key (E);
197 -- Note that it is important to use a renaming here rather than
198 -- define a constant initialized by the call, because the latter
199 -- construct runs into bootstrap problems with earlier versions
200 -- of the GNAT compiler.
202 Index : constant Header_Num := Hash (K);
206 Elmt := Table (Index);
208 if Elmt = Null_Ptr then
209 Set_Next (E, Table (Index));
213 elsif Equal (Get_Key (Elmt), K) then
220 end Set_If_Not_Present;
228 package body Simple_HTable is
230 type Element_Wrapper;
231 type Elmt_Ptr is access all Element_Wrapper;
232 type Element_Wrapper is record
238 procedure Free is new
239 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
241 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
242 function Next (E : Elmt_Ptr) return Elmt_Ptr;
243 function Get_Key (E : Elmt_Ptr) return Key;
245 package Tab is new Static_HTable (
246 Header_Num => Header_Num,
247 Element => Element_Wrapper,
248 Elmt_Ptr => Elmt_Ptr,
250 Set_Next => Set_Next,
261 function Get (K : Key) return Element is
262 Tmp : constant Elmt_Ptr := Tab.Get (K);
275 function Get_First return Element is
276 Tmp : constant Elmt_Ptr := Tab.Get_First;
285 procedure Get_First (K : in out Key; E : out Element) is
286 Tmp : constant Elmt_Ptr := Tab.Get_First;
300 function Get_Key (E : Elmt_Ptr) return Key is
309 function Get_Next return Element is
310 Tmp : constant Elmt_Ptr := Tab.Get_Next;
319 procedure Get_Next (K : in out Key; E : out Element) is
320 Tmp : constant Elmt_Ptr := Tab.Get_Next;
334 function Next (E : Elmt_Ptr) return Elmt_Ptr is
343 procedure Remove (K : Key) is
364 while E1 /= null loop
377 procedure Set (K : Key; E : Element) is
378 Tmp : constant Elmt_Ptr := Tab.Get (K);
381 Tab.Set (new Element_Wrapper'(K, E, null));
391 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
401 function Hash (Key : String) return Header_Num is
402 type Uns is mod 2 ** 32;
405 new System.String_Hash.Hash (Character, String, Uns);
408 return Header_Num'First +
409 Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);