URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-htable.adb] - Blame information for rev 281

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                        S Y S T E M . H T A B L E                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 1995-2009, AdaCore                      --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
pragma Compiler_Unit;
 
with Ada.Unchecked_Deallocation;
with System.String_Hash;
 
package body System.HTable is
 
   -------------------
   -- Static_HTable --
   -------------------
 
   package body Static_HTable is
 
      Table : array (Header_Num) of Elmt_Ptr;
 
      Iterator_Index   : Header_Num;
      Iterator_Ptr     : Elmt_Ptr;
      Iterator_Started : Boolean := False;
 
      function Get_Non_Null return Elmt_Ptr;
      --  Returns Null_Ptr if Iterator_Started is false or the Table is empty.
      --  Returns Iterator_Ptr if non null, or the next non null element in
      --  table if any.
 
      ---------
      -- Get --
      ---------
 
      function Get (K : Key) return Elmt_Ptr is
         Elmt : Elmt_Ptr;
 
      begin
         Elmt := Table (Hash (K));
 
         loop
            if Elmt = Null_Ptr then
               return Null_Ptr;
 
            elsif Equal (Get_Key (Elmt), K) then
               return Elmt;
 
            else
               Elmt := Next (Elmt);
            end if;
         end loop;
      end Get;
 
      ---------------
      -- Get_First --
      ---------------
 
      function Get_First return Elmt_Ptr is
      begin
         Iterator_Started := True;
         Iterator_Index := Table'First;
         Iterator_Ptr := Table (Iterator_Index);
         return Get_Non_Null;
      end Get_First;
 
      --------------
      -- Get_Next --
      --------------
 
      function Get_Next return Elmt_Ptr is
      begin
         if not Iterator_Started then
            return Null_Ptr;
         end if;
 
         Iterator_Ptr := Next (Iterator_Ptr);
         return Get_Non_Null;
      end Get_Next;
 
      ------------------
      -- Get_Non_Null --
      ------------------
 
      function Get_Non_Null return Elmt_Ptr is
      begin
         while Iterator_Ptr = Null_Ptr  loop
            if Iterator_Index = Table'Last then
               Iterator_Started := False;
               return Null_Ptr;
            end if;
 
            Iterator_Index := Iterator_Index + 1;
            Iterator_Ptr   := Table (Iterator_Index);
         end loop;
 
         return Iterator_Ptr;
      end Get_Non_Null;
 
      ------------
      -- Remove --
      ------------
 
      procedure Remove  (K : Key) is
         Index     : constant Header_Num := Hash (K);
         Elmt      : Elmt_Ptr;
         Next_Elmt : Elmt_Ptr;
 
      begin
         Elmt := Table (Index);
 
         if Elmt = Null_Ptr then
            return;
 
         elsif Equal (Get_Key (Elmt), K) then
            Table (Index) := Next (Elmt);
 
         else
            loop
               Next_Elmt :=  Next (Elmt);
 
               if Next_Elmt = Null_Ptr then
                  return;
 
               elsif Equal (Get_Key (Next_Elmt), K) then
                  Set_Next (Elmt, Next (Next_Elmt));
                  return;
 
               else
                  Elmt := Next_Elmt;
               end if;
            end loop;
         end if;
      end Remove;
 
      -----------
      -- Reset --
      -----------
 
      procedure Reset is
      begin
         for J in Table'Range loop
            Table (J) := Null_Ptr;
         end loop;
      end Reset;
 
      ---------
      -- Set --
      ---------
 
      procedure Set (E : Elmt_Ptr) is
         Index : Header_Num;
 
      begin
         Index := Hash (Get_Key (E));
         Set_Next (E, Table (Index));
         Table (Index) := E;
      end Set;
 
   end Static_HTable;
 
   -------------------
   -- Simple_HTable --
   -------------------
 
   package body Simple_HTable is
 
      type Element_Wrapper;
      type Elmt_Ptr is access all Element_Wrapper;
      type Element_Wrapper is record
         K    : Key;
         E    : Element;
         Next : Elmt_Ptr;
      end record;
 
      procedure Free is new
        Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
 
      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
      function  Next     (E : Elmt_Ptr) return Elmt_Ptr;
      function  Get_Key  (E : Elmt_Ptr) return Key;
 
      package Tab is new Static_HTable (
        Header_Num => Header_Num,
        Element    => Element_Wrapper,
        Elmt_Ptr   => Elmt_Ptr,
        Null_Ptr   => null,
        Set_Next   => Set_Next,
        Next       => Next,
        Key        => Key,
        Get_Key    => Get_Key,
        Hash       => Hash,
        Equal      => Equal);
 
      ---------
      -- Get --
      ---------
 
      function  Get (K : Key) return Element is
         Tmp : constant Elmt_Ptr := Tab.Get (K);
      begin
         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get;
 
      ---------------
      -- Get_First --
      ---------------
 
      function Get_First return Element is
         Tmp : constant Elmt_Ptr := Tab.Get_First;
      begin
         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get_First;
 
      -------------
      -- Get_Key --
      -------------
 
      function Get_Key (E : Elmt_Ptr) return Key is
      begin
         return E.K;
      end Get_Key;
 
      --------------
      -- Get_Next --
      --------------
 
      function Get_Next return Element is
         Tmp : constant Elmt_Ptr := Tab.Get_Next;
      begin
         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get_Next;
 
      ----------
      -- Next --
      ----------
 
      function Next (E : Elmt_Ptr) return Elmt_Ptr is
      begin
         return E.Next;
      end Next;
 
      ------------
      -- Remove --
      ------------
 
      procedure Remove  (K : Key) is
         Tmp : Elmt_Ptr;
 
      begin
         Tmp := Tab.Get (K);
 
         if Tmp /= null then
            Tab.Remove (K);
            Free (Tmp);
         end if;
      end Remove;
 
      -----------
      -- Reset --
      -----------
 
      procedure Reset is
         E1, E2 : Elmt_Ptr;
 
      begin
         E1 := Tab.Get_First;
         while E1 /= null loop
            E2 := Tab.Get_Next;
            Free (E1);
            E1 := E2;
         end loop;
 
         Tab.Reset;
      end Reset;
 
      ---------
      -- Set --
      ---------
 
      procedure Set (K : Key; E : Element) is
         Tmp : constant Elmt_Ptr := Tab.Get (K);
      begin
         if Tmp = null then
            Tab.Set (new Element_Wrapper'(K, E, null));
         else
            Tmp.E := E;
         end if;
      end Set;
 
      --------------
      -- Set_Next --
      --------------
 
      procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
      begin
         E.Next := Next;
      end Set_Next;
   end Simple_HTable;
 
   ----------
   -- Hash --
   ----------
 
   function Hash (Key : String) return Header_Num is
      type Uns is mod 2 ** 32;
 
      function Hash_Fun is
         new System.String_Hash.Hash (Character, String, Uns);
 
   begin
      return Header_Num'First +
        Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);
   end Hash;
 
end System.HTable;

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-htable.adb] - Blame information for rev 281

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT RUN-TIME COMPONENTS --`
4			`-- --`
5			`-- S Y S T E M . H T A B L E --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1995-2009, AdaCore --`
10			`-- --`
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 2, 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. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING. If not, write --`
19			`-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --`
20			`-- Boston, MA 02110-1301, USA. --`
21			`-- --`
22			`-- As a special exception, if other files instantiate generics from this --`
23			`-- unit, or you link this unit with other files to produce an executable, --`
24			`-- this unit does not by itself cause the resulting executable to be --`
25			`-- covered by the GNU General Public License. This exception does not --`
26			`-- however invalidate any other reasons why the executable file might be --`
27			`-- covered by the GNU Public License. --`
28			`-- --`
29			`-- GNAT was originally developed by the GNAT team at New York University. --`
30			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
31			`-- --`
32			`------------------------------------------------------------------------------`
33
34			`pragma Compiler_Unit;`
35
36			`with Ada.Unchecked_Deallocation;`
37			`with System.String_Hash;`
38
39			`package body System.HTable is`
40
41			`-------------------`
42			`-- Static_HTable --`
43			`-------------------`
44
45			`package body Static_HTable is`
46
47			`Table : array (Header_Num) of Elmt_Ptr;`
48
49			`Iterator_Index : Header_Num;`
50			`Iterator_Ptr : Elmt_Ptr;`
51			`Iterator_Started : Boolean := False;`
52
53			`function Get_Non_Null return Elmt_Ptr;`
54			`-- Returns Null_Ptr if Iterator_Started is false or the Table is empty.`
55			`-- Returns Iterator_Ptr if non null, or the next non null element in`
56			`-- table if any.`
57
58			`---------`
59			`-- Get --`
60			`---------`
61
62			`function Get (K : Key) return Elmt_Ptr is`
63			`Elmt : Elmt_Ptr;`
64
65			`begin`
66			`Elmt := Table (Hash (K));`
67
68			`loop`
69			`if Elmt = Null_Ptr then`
70			`return Null_Ptr;`
71
72			`elsif Equal (Get_Key (Elmt), K) then`
73			`return Elmt;`
74
75			`else`
76			`Elmt := Next (Elmt);`
77			`end if;`
78			`end loop;`
79			`end Get;`
80
81			`---------------`
82			`-- Get_First --`
83			`---------------`
84
85			`function Get_First return Elmt_Ptr is`
86			`begin`
87			`Iterator_Started := True;`
88			`Iterator_Index := Table'First;`
89			`Iterator_Ptr := Table (Iterator_Index);`
90			`return Get_Non_Null;`
91			`end Get_First;`
92
93			`--------------`
94			`-- Get_Next --`
95			`--------------`
96
97			`function Get_Next return Elmt_Ptr is`
98			`begin`
99			`if not Iterator_Started then`
100			`return Null_Ptr;`
101			`end if;`
102
103			`Iterator_Ptr := Next (Iterator_Ptr);`
104			`return Get_Non_Null;`
105			`end Get_Next;`
106
107			`------------------`
108			`-- Get_Non_Null --`
109			`------------------`
110
111			`function Get_Non_Null return Elmt_Ptr is`
112			`begin`
113			`while Iterator_Ptr = Null_Ptr loop`
114			`if Iterator_Index = Table'Last then`
115			`Iterator_Started := False;`
116			`return Null_Ptr;`
117			`end if;`
118
119			`Iterator_Index := Iterator_Index + 1;`
120			`Iterator_Ptr := Table (Iterator_Index);`
121			`end loop;`
122
123			`return Iterator_Ptr;`
124			`end Get_Non_Null;`
125
126			`------------`
127			`-- Remove --`
128			`------------`
129
130			`procedure Remove (K : Key) is`
131			`Index : constant Header_Num := Hash (K);`
132			`Elmt : Elmt_Ptr;`
133			`Next_Elmt : Elmt_Ptr;`
134
135			`begin`
136			`Elmt := Table (Index);`
137
138			`if Elmt = Null_Ptr then`
139			`return;`
140
141			`elsif Equal (Get_Key (Elmt), K) then`
142			`Table (Index) := Next (Elmt);`
143
144			`else`
145			`loop`
146			`Next_Elmt := Next (Elmt);`
147
148			`if Next_Elmt = Null_Ptr then`
149			`return;`
150
151			`elsif Equal (Get_Key (Next_Elmt), K) then`
152			`Set_Next (Elmt, Next (Next_Elmt));`
153			`return;`
154
155			`else`
156			`Elmt := Next_Elmt;`
157			`end if;`
158			`end loop;`
159			`end if;`
160			`end Remove;`
161
162			`-----------`
163			`-- Reset --`
164			`-----------`
165
166			`procedure Reset is`
167			`begin`
168			`for J in Table'Range loop`
169			`Table (J) := Null_Ptr;`
170			`end loop;`
171			`end Reset;`
172
173			`---------`
174			`-- Set --`
175			`---------`
176
177			`procedure Set (E : Elmt_Ptr) is`
178			`Index : Header_Num;`
179
180			`begin`
181			`Index := Hash (Get_Key (E));`
182			`Set_Next (E, Table (Index));`
183			`Table (Index) := E;`
184			`end Set;`
185
186			`end Static_HTable;`
187
188			`-------------------`
189			`-- Simple_HTable --`
190			`-------------------`
191
192			`package body Simple_HTable is`
193
194			`type Element_Wrapper;`
195			`type Elmt_Ptr is access all Element_Wrapper;`
196			`type Element_Wrapper is record`
197			`K : Key;`
198			`E : Element;`
199			`Next : Elmt_Ptr;`
200			`end record;`
201
202			`procedure Free is new`
203			`Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);`
204
205			`procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);`
206			`function Next (E : Elmt_Ptr) return Elmt_Ptr;`
207			`function Get_Key (E : Elmt_Ptr) return Key;`
208
209			`package Tab is new Static_HTable (`
210			`Header_Num => Header_Num,`
211			`Element => Element_Wrapper,`
212			`Elmt_Ptr => Elmt_Ptr,`
213			`Null_Ptr => null,`
214			`Set_Next => Set_Next,`
215			`Next => Next,`
216			`Key => Key,`
217			`Get_Key => Get_Key,`
218			`Hash => Hash,`
219			`Equal => Equal);`
220
221			`---------`
222			`-- Get --`
223			`---------`
224
225			`function Get (K : Key) return Element is`
226			`Tmp : constant Elmt_Ptr := Tab.Get (K);`
227			`begin`
228			`if Tmp = null then`
229			`return No_Element;`
230			`else`
231			`return Tmp.E;`
232			`end if;`
233			`end Get;`
234
235			`---------------`
236			`-- Get_First --`
237			`---------------`
238
239			`function Get_First return Element is`
240			`Tmp : constant Elmt_Ptr := Tab.Get_First;`
241			`begin`
242			`if Tmp = null then`
243			`return No_Element;`
244			`else`
245			`return Tmp.E;`
246			`end if;`
247			`end Get_First;`
248
249			`-------------`
250			`-- Get_Key --`
251			`-------------`
252
253			`function Get_Key (E : Elmt_Ptr) return Key is`
254			`begin`
255			`return E.K;`
256			`end Get_Key;`
257
258			`--------------`
259			`-- Get_Next --`
260			`--------------`
261
262			`function Get_Next return Element is`
263			`Tmp : constant Elmt_Ptr := Tab.Get_Next;`
264			`begin`
265			`if Tmp = null then`
266			`return No_Element;`
267			`else`
268			`return Tmp.E;`
269			`end if;`
270			`end Get_Next;`
271
272			`----------`
273			`-- Next --`
274			`----------`
275
276			`function Next (E : Elmt_Ptr) return Elmt_Ptr is`
277			`begin`
278			`return E.Next;`
279			`end Next;`
280
281			`------------`
282			`-- Remove --`
283			`------------`
284
285			`procedure Remove (K : Key) is`
286			`Tmp : Elmt_Ptr;`
287
288			`begin`
289			`Tmp := Tab.Get (K);`
290
291			`if Tmp /= null then`
292			`Tab.Remove (K);`
293			`Free (Tmp);`
294			`end if;`
295			`end Remove;`
296
297			`-----------`
298			`-- Reset --`
299			`-----------`
300
301			`procedure Reset is`
302			`E1, E2 : Elmt_Ptr;`
303
304			`begin`
305			`E1 := Tab.Get_First;`
306			`while E1 /= null loop`
307			`E2 := Tab.Get_Next;`
308			`Free (E1);`
309			`E1 := E2;`
310			`end loop;`
311
312			`Tab.Reset;`
313			`end Reset;`
314
315			`---------`
316			`-- Set --`
317			`---------`
318
319			`procedure Set (K : Key; E : Element) is`
320			`Tmp : constant Elmt_Ptr := Tab.Get (K);`
321			`begin`
322			`if Tmp = null then`
323			`Tab.Set (new Element_Wrapper'(K, E, null));`
324			`else`
325			`Tmp.E := E;`
326			`end if;`
327			`end Set;`
328
329			`--------------`
330			`-- Set_Next --`
331			`--------------`
332
333			`procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is`
334			`begin`
335			`E.Next := Next;`
336			`end Set_Next;`
337			`end Simple_HTable;`
338
339			`----------`
340			`-- Hash --`
341			`----------`
342
343			`function Hash (Key : String) return Header_Num is`
344			`type Uns is mod 2 ** 32;`
345
346			`function Hash_Fun is`
347			`new System.String_Hash.Hash (Character, String, Uns);`
348
349			`begin`
350			`return Header_Num'First +`
351			`Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);`
352			`end Hash;`
353
354			`end System.HTable;`