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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-htable.adb] - Blame information for rev 706

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-2011, 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 3,  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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- 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;
 
      -------------
      -- Present --
      -------------
 
      function Present (K : Key) return Boolean is
      begin
         return Get (K) /= Null_Ptr;
      end Present;
 
      ------------
      -- 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;
 
      ------------------------
      -- Set_If_Not_Present --
      ------------------------
 
      function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
         K : Key renames Get_Key (E);
         --  Note that it is important to use a renaming here rather than
         --  define a constant initialized by the call, because the latter
         --  construct runs into bootstrap problems with earlier versions
         --  of the GNAT compiler.
 
         Index : constant Header_Num := Hash (K);
         Elmt  : Elmt_Ptr;
 
      begin
         Elmt := Table (Index);
         loop
            if Elmt = Null_Ptr then
               Set_Next (E, Table (Index));
               Table (Index) := E;
               return True;
 
            elsif Equal (Get_Key (Elmt), K) then
               return False;
 
            else
               Elmt := Next (Elmt);
            end if;
         end loop;
      end Set_If_Not_Present;
 
   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;
 
      procedure Get_First (K : in out Key; E : out Element) is
         Tmp : constant Elmt_Ptr := Tab.Get_First;
      begin
         if Tmp = null then
            E := No_Element;
         else
            K := Tmp.K;
            E := 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;
 
      procedure Get_Next (K : in out Key; E : out Element) is
         Tmp : constant Elmt_Ptr := Tab.Get_Next;
      begin
         if Tmp = null then
            E := No_Element;
         else
            K := Tmp.K;
            E := 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

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-htable.adb] - Blame information for rev 706

Line No.	Rev	Author	Line
1	706	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-2011, 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 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. --`
17			`-- --`
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. --`
21			`-- --`
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/>. --`
26			`-- --`
27			`-- GNAT was originally developed by the GNAT team at New York University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`pragma Compiler_Unit;`
33
34			`with Ada.Unchecked_Deallocation;`
35			`with System.String_Hash;`
36
37			`package body System.HTable is`
38
39			`-------------------`
40			`-- Static_HTable --`
41			`-------------------`
42
43			`package body Static_HTable is`
44
45			`Table : array (Header_Num) of Elmt_Ptr;`
46
47			`Iterator_Index : Header_Num;`
48			`Iterator_Ptr : Elmt_Ptr;`
49			`Iterator_Started : Boolean := False;`
50
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`
54			`-- table if any.`
55
56			`---------`
57			`-- Get --`
58			`---------`
59
60			`function Get (K : Key) return Elmt_Ptr is`
61			`Elmt : Elmt_Ptr;`
62
63			`begin`
64			`Elmt := Table (Hash (K));`
65
66			`loop`
67			`if Elmt = Null_Ptr then`
68			`return Null_Ptr;`
69
70			`elsif Equal (Get_Key (Elmt), K) then`
71			`return Elmt;`
72
73			`else`
74			`Elmt := Next (Elmt);`
75			`end if;`
76			`end loop;`
77			`end Get;`
78
79			`---------------`
80			`-- Get_First --`
81			`---------------`
82
83			`function Get_First return Elmt_Ptr is`
84			`begin`
85			`Iterator_Started := True;`
86			`Iterator_Index := Table'First;`
87			`Iterator_Ptr := Table (Iterator_Index);`
88			`return Get_Non_Null;`
89			`end Get_First;`
90
91			`--------------`
92			`-- Get_Next --`
93			`--------------`
94
95			`function Get_Next return Elmt_Ptr is`
96			`begin`
97			`if not Iterator_Started then`
98			`return Null_Ptr;`
99			`end if;`
100
101			`Iterator_Ptr := Next (Iterator_Ptr);`
102			`return Get_Non_Null;`
103			`end Get_Next;`
104
105			`------------------`
106			`-- Get_Non_Null --`
107			`------------------`
108
109			`function Get_Non_Null return Elmt_Ptr is`
110			`begin`
111			`while Iterator_Ptr = Null_Ptr loop`
112			`if Iterator_Index = Table'Last then`
113			`Iterator_Started := False;`
114			`return Null_Ptr;`
115			`end if;`
116
117			`Iterator_Index := Iterator_Index + 1;`
118			`Iterator_Ptr := Table (Iterator_Index);`
119			`end loop;`
120
121			`return Iterator_Ptr;`
122			`end Get_Non_Null;`
123
124			`-------------`
125			`-- Present --`
126			`-------------`
127
128			`function Present (K : Key) return Boolean is`
129			`begin`
130			`return Get (K) /= Null_Ptr;`
131			`end Present;`
132
133			`------------`
134			`-- Remove --`
135			`------------`
136
137			`procedure Remove (K : Key) is`
138			`Index : constant Header_Num := Hash (K);`
139			`Elmt : Elmt_Ptr;`
140			`Next_Elmt : Elmt_Ptr;`
141
142			`begin`
143			`Elmt := Table (Index);`
144
145			`if Elmt = Null_Ptr then`
146			`return;`
147
148			`elsif Equal (Get_Key (Elmt), K) then`
149			`Table (Index) := Next (Elmt);`
150
151			`else`
152			`loop`
153			`Next_Elmt := Next (Elmt);`
154
155			`if Next_Elmt = Null_Ptr then`
156			`return;`
157
158			`elsif Equal (Get_Key (Next_Elmt), K) then`
159			`Set_Next (Elmt, Next (Next_Elmt));`
160			`return;`
161
162			`else`
163			`Elmt := Next_Elmt;`
164			`end if;`
165			`end loop;`
166			`end if;`
167			`end Remove;`
168
169			`-----------`
170			`-- Reset --`
171			`-----------`
172
173			`procedure Reset is`
174			`begin`
175			`for J in Table'Range loop`
176			`Table (J) := Null_Ptr;`
177			`end loop;`
178			`end Reset;`
179
180			`---------`
181			`-- Set --`
182			`---------`
183
184			`procedure Set (E : Elmt_Ptr) is`
185			`Index : Header_Num;`
186
187			`begin`
188			`Index := Hash (Get_Key (E));`
189			`Set_Next (E, Table (Index));`
190			`Table (Index) := E;`
191			`end Set;`
192
193			`------------------------`
194			`-- Set_If_Not_Present --`
195			`------------------------`
196
197			`function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is`
198			`K : Key renames Get_Key (E);`
199			`-- Note that it is important to use a renaming here rather than`
200			`-- define a constant initialized by the call, because the latter`
201			`-- construct runs into bootstrap problems with earlier versions`
202			`-- of the GNAT compiler.`
203
204			`Index : constant Header_Num := Hash (K);`
205			`Elmt : Elmt_Ptr;`
206
207			`begin`
208			`Elmt := Table (Index);`
209			`loop`
210			`if Elmt = Null_Ptr then`
211			`Set_Next (E, Table (Index));`
212			`Table (Index) := E;`
213			`return True;`
214
215			`elsif Equal (Get_Key (Elmt), K) then`
216			`return False;`
217
218			`else`
219			`Elmt := Next (Elmt);`
220			`end if;`
221			`end loop;`
222			`end Set_If_Not_Present;`
223
224			`end Static_HTable;`
225
226			`-------------------`
227			`-- Simple_HTable --`
228			`-------------------`
229
230			`package body Simple_HTable is`
231
232			`type Element_Wrapper;`
233			`type Elmt_Ptr is access all Element_Wrapper;`
234			`type Element_Wrapper is record`
235			`K : Key;`
236			`E : Element;`
237			`Next : Elmt_Ptr;`
238			`end record;`
239
240			`procedure Free is new`
241			`Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);`
242
243			`procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);`
244			`function Next (E : Elmt_Ptr) return Elmt_Ptr;`
245			`function Get_Key (E : Elmt_Ptr) return Key;`
246
247			`package Tab is new Static_HTable (`
248			`Header_Num => Header_Num,`
249			`Element => Element_Wrapper,`
250			`Elmt_Ptr => Elmt_Ptr,`
251			`Null_Ptr => null,`
252			`Set_Next => Set_Next,`
253			`Next => Next,`
254			`Key => Key,`
255			`Get_Key => Get_Key,`
256			`Hash => Hash,`
257			`Equal => Equal);`
258
259			`---------`
260			`-- Get --`
261			`---------`
262
263			`function Get (K : Key) return Element is`
264			`Tmp : constant Elmt_Ptr := Tab.Get (K);`
265			`begin`
266			`if Tmp = null then`
267			`return No_Element;`
268			`else`
269			`return Tmp.E;`
270			`end if;`
271			`end Get;`
272
273			`---------------`
274			`-- Get_First --`
275			`---------------`
276
277			`function Get_First return Element is`
278			`Tmp : constant Elmt_Ptr := Tab.Get_First;`
279			`begin`
280			`if Tmp = null then`
281			`return No_Element;`
282			`else`
283			`return Tmp.E;`
284			`end if;`
285			`end Get_First;`
286
287			`procedure Get_First (K : in out Key; E : out Element) is`
288			`Tmp : constant Elmt_Ptr := Tab.Get_First;`
289			`begin`
290			`if Tmp = null then`
291			`E := No_Element;`
292			`else`
293			`K := Tmp.K;`
294			`E := Tmp.E;`
295			`end if;`
296			`end Get_First;`
297
298			`-------------`
299			`-- Get_Key --`
300			`-------------`
301
302			`function Get_Key (E : Elmt_Ptr) return Key is`
303			`begin`
304			`return E.K;`
305			`end Get_Key;`
306
307			`--------------`
308			`-- Get_Next --`
309			`--------------`
310
311			`function Get_Next return Element is`
312			`Tmp : constant Elmt_Ptr := Tab.Get_Next;`
313			`begin`
314			`if Tmp = null then`
315			`return No_Element;`
316			`else`
317			`return Tmp.E;`
318			`end if;`
319			`end Get_Next;`
320
321			`procedure Get_Next (K : in out Key; E : out Element) is`
322			`Tmp : constant Elmt_Ptr := Tab.Get_Next;`
323			`begin`
324			`if Tmp = null then`
325			`E := No_Element;`
326			`else`
327			`K := Tmp.K;`
328			`E := Tmp.E;`
329			`end if;`
330			`end Get_Next;`
331
332			`----------`
333			`-- Next --`
334			`----------`
335
336			`function Next (E : Elmt_Ptr) return Elmt_Ptr is`
337			`begin`
338			`return E.Next;`
339			`end Next;`
340
341			`------------`
342			`-- Remove --`
343			`------------`
344
345			`procedure Remove (K : Key) is`
346			`Tmp : Elmt_Ptr;`
347
348			`begin`
349			`Tmp := Tab.Get (K);`
350
351			`if Tmp /= null then`
352			`Tab.Remove (K);`
353			`Free (Tmp);`
354			`end if;`
355			`end Remove;`
356
357			`-----------`
358			`-- Reset --`
359			`-----------`
360
361			`procedure Reset is`
362			`E1, E2 : Elmt_Ptr;`
363
364			`begin`
365			`E1 := Tab.Get_First;`
366			`while E1 /= null loop`
367			`E2 := Tab.Get_Next;`
368			`Free (E1);`
369			`E1 := E2;`
370			`end loop;`
371
372			`Tab.Reset;`
373			`end Reset;`
374
375			`---------`
376			`-- Set --`
377			`---------`
378
379			`procedure Set (K : Key; E : Element) is`
380			`Tmp : constant Elmt_Ptr := Tab.Get (K);`
381			`begin`
382			`if Tmp = null then`
383			`Tab.Set (new Element_Wrapper'(K, E, null));`
384			`else`
385			`Tmp.E := E;`
386			`end if;`
387			`end Set;`
388
389			`--------------`
390			`-- Set_Next --`
391			`--------------`
392
393			`procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is`
394			`begin`
395			`E.Next := Next;`
396			`end Set_Next;`
397			`end Simple_HTable;`
398
399			`----------`
400			`-- Hash --`
401			`----------`
402
403			`function Hash (Key : String) return Header_Num is`
404			`type Uns is mod 2 ** 32;`
405
406			`function Hash_Fun is`
407			`new System.String_Hash.Hash (Character, String, Uns);`
408
409			`begin`
410			`return Header_Num'First +`
411			`Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);`
412			`end Hash;`
413
414			`end System.HTable;`