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

Subversion Repositories openrisc

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc3/] [gcc/] [ada/] [g-dynhta.adb] - Blame information for rev 516

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                 G N A T . D Y N A M I C _ H T A B L E S                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2002-2006, 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.      --
--                                                                          --
------------------------------------------------------------------------------
 
package body GNAT.Dynamic_HTables is
 
   -------------------
   -- Static_HTable --
   -------------------
 
   package body Static_HTable is
 
      type Table_Type is array (Header_Num) of Elmt_Ptr;
 
      type Instance_Data is record
         Table            : Table_Type;
         Iterator_Index   : Header_Num;
         Iterator_Ptr     : Elmt_Ptr;
         Iterator_Started : Boolean := False;
      end record;
 
      function Get_Non_Null (T : Instance) return Elmt_Ptr;
      --  Returns Null_Ptr if Iterator_Started is False or if the Table is
      --  empty. Returns Iterator_Ptr if non null, or the next non null
      --  element in table if any.
 
      ---------
      -- Get --
      ---------
 
      function  Get (T : Instance; K : Key) return Elmt_Ptr is
         Elmt  : Elmt_Ptr;
 
      begin
         if T = null then
            return Null_Ptr;
         end if;
 
         Elmt := T.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 (T : Instance) return Elmt_Ptr is
      begin
         if T = null then
            return Null_Ptr;
         end if;
 
         T.Iterator_Started := True;
         T.Iterator_Index := T.Table'First;
         T.Iterator_Ptr := T.Table (T.Iterator_Index);
         return Get_Non_Null (T);
      end Get_First;
 
      --------------
      -- Get_Next --
      --------------
 
      function Get_Next (T : Instance) return Elmt_Ptr is
      begin
         if T = null or else not T.Iterator_Started then
            return Null_Ptr;
         end if;
 
         T.Iterator_Ptr := Next (T.Iterator_Ptr);
         return Get_Non_Null (T);
      end Get_Next;
 
      ------------------
      -- Get_Non_Null --
      ------------------
 
      function Get_Non_Null (T : Instance) return Elmt_Ptr is
      begin
         if T = null then
            return Null_Ptr;
         end if;
 
         while T.Iterator_Ptr = Null_Ptr  loop
            if T.Iterator_Index = T.Table'Last then
               T.Iterator_Started := False;
               return Null_Ptr;
            end if;
 
            T.Iterator_Index := T.Iterator_Index + 1;
            T.Iterator_Ptr   := T.Table (T.Iterator_Index);
         end loop;
 
         return T.Iterator_Ptr;
      end Get_Non_Null;
 
      ------------
      -- Remove --
      ------------
 
      procedure Remove  (T : Instance; K : Key) is
         Index     : constant Header_Num := Hash (K);
         Elmt      : Elmt_Ptr;
         Next_Elmt : Elmt_Ptr;
 
      begin
         if T = null then
            return;
         end if;
 
         Elmt := T.Table (Index);
 
         if Elmt = Null_Ptr then
            return;
 
         elsif Equal (Get_Key (Elmt), K) then
            T.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 (T : in out Instance) is
         procedure Free is
           new Ada.Unchecked_Deallocation (Instance_Data, Instance);
 
      begin
         if T = null then
            return;
         end if;
 
         for J in T.Table'Range loop
            T.Table (J) := Null_Ptr;
         end loop;
 
         Free (T);
      end Reset;
 
      ---------
      -- Set --
      ---------
 
      procedure Set (T : in out Instance; E : Elmt_Ptr) is
         Index : Header_Num;
 
      begin
         if T = null then
            T := new Instance_Data;
         end if;
 
         Index := Hash (Get_Key (E));
         Set_Next (E, T.Table (Index));
         T.Table (Index) := E;
      end Set;
 
   end Static_HTable;
 
   -------------------
   -- Simple_HTable --
   -------------------
 
   package body Simple_HTable is
 
      ---------
      -- Get --
      ---------
 
      function  Get (T : Instance; K : Key) return Element is
         Tmp : Elmt_Ptr;
 
      begin
         if T = Nil then
            return No_Element;
         end if;
 
         Tmp := Tab.Get (Tab.Instance (T), K);
 
         if Tmp = null then
            return No_Element;
         else
            return Tmp.E;
         end if;
      end Get;
 
      ---------------
      -- Get_First --
      ---------------
 
      function Get_First (T : Instance) return Element is
         Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
 
      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 (T : Instance) return Element is
         Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
      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  (T : Instance; K : Key) is
         Tmp : Elmt_Ptr;
 
      begin
         Tmp := Tab.Get (Tab.Instance (T), K);
 
         if Tmp /= null then
            Tab.Remove (Tab.Instance (T), K);
            Free (Tmp);
         end if;
      end Remove;
 
      -----------
      -- Reset --
      -----------
 
      procedure Reset (T : in out Instance) is
         E1, E2 : Elmt_Ptr;
 
      begin
         E1 := Tab.Get_First (Tab.Instance (T));
         while E1 /= null loop
            E2 := Tab.Get_Next (Tab.Instance (T));
            Free (E1);
            E1 := E2;
         end loop;
 
         Tab.Reset (Tab.Instance (T));
      end Reset;
 
      ---------
      -- Set --
      ---------
 
      procedure Set (T : in out Instance; K : Key; E : Element) is
         Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
      begin
         if Tmp = null then
            Tab.Set (Tab.Instance (T), 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;
 
end GNAT.Dynamic_HTables;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc3/] [gcc/] [ada/] [g-dynhta.adb] - Blame information for rev 516

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT RUN-TIME COMPONENTS --`
4			`-- --`
5			`-- G N A T . D Y N A M I C _ H T A B L E S --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2002-2006, 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			`package body GNAT.Dynamic_HTables is`
35
36			`-------------------`
37			`-- Static_HTable --`
38			`-------------------`
39
40			`package body Static_HTable is`
41
42			`type Table_Type is array (Header_Num) of Elmt_Ptr;`
43
44			`type Instance_Data is record`
45			`Table : Table_Type;`
46			`Iterator_Index : Header_Num;`
47			`Iterator_Ptr : Elmt_Ptr;`
48			`Iterator_Started : Boolean := False;`
49			`end record;`
50
51			`function Get_Non_Null (T : Instance) return Elmt_Ptr;`
52			`-- Returns Null_Ptr if Iterator_Started is False or if the Table is`
53			`-- empty. Returns Iterator_Ptr if non null, or the next non null`
54			`-- element in table if any.`
55
56			`---------`
57			`-- Get --`
58			`---------`
59
60			`function Get (T : Instance; K : Key) return Elmt_Ptr is`
61			`Elmt : Elmt_Ptr;`
62
63			`begin`
64			`if T = null then`
65			`return Null_Ptr;`
66			`end if;`
67
68			`Elmt := T.Table (Hash (K));`
69
70			`loop`
71			`if Elmt = Null_Ptr then`
72			`return Null_Ptr;`
73
74			`elsif Equal (Get_Key (Elmt), K) then`
75			`return Elmt;`
76
77			`else`
78			`Elmt := Next (Elmt);`
79			`end if;`
80			`end loop;`
81			`end Get;`
82
83			`---------------`
84			`-- Get_First --`
85			`---------------`
86
87			`function Get_First (T : Instance) return Elmt_Ptr is`
88			`begin`
89			`if T = null then`
90			`return Null_Ptr;`
91			`end if;`
92
93			`T.Iterator_Started := True;`
94			`T.Iterator_Index := T.Table'First;`
95			`T.Iterator_Ptr := T.Table (T.Iterator_Index);`
96			`return Get_Non_Null (T);`
97			`end Get_First;`
98
99			`--------------`
100			`-- Get_Next --`
101			`--------------`
102
103			`function Get_Next (T : Instance) return Elmt_Ptr is`
104			`begin`
105			`if T = null or else not T.Iterator_Started then`
106			`return Null_Ptr;`
107			`end if;`
108
109			`T.Iterator_Ptr := Next (T.Iterator_Ptr);`
110			`return Get_Non_Null (T);`
111			`end Get_Next;`
112
113			`------------------`
114			`-- Get_Non_Null --`
115			`------------------`
116
117			`function Get_Non_Null (T : Instance) return Elmt_Ptr is`
118			`begin`
119			`if T = null then`
120			`return Null_Ptr;`
121			`end if;`
122
123			`while T.Iterator_Ptr = Null_Ptr loop`
124			`if T.Iterator_Index = T.Table'Last then`
125			`T.Iterator_Started := False;`
126			`return Null_Ptr;`
127			`end if;`
128
129			`T.Iterator_Index := T.Iterator_Index + 1;`
130			`T.Iterator_Ptr := T.Table (T.Iterator_Index);`
131			`end loop;`
132
133			`return T.Iterator_Ptr;`
134			`end Get_Non_Null;`
135
136			`------------`
137			`-- Remove --`
138			`------------`
139
140			`procedure Remove (T : Instance; K : Key) is`
141			`Index : constant Header_Num := Hash (K);`
142			`Elmt : Elmt_Ptr;`
143			`Next_Elmt : Elmt_Ptr;`
144
145			`begin`
146			`if T = null then`
147			`return;`
148			`end if;`
149
150			`Elmt := T.Table (Index);`
151
152			`if Elmt = Null_Ptr then`
153			`return;`
154
155			`elsif Equal (Get_Key (Elmt), K) then`
156			`T.Table (Index) := Next (Elmt);`
157
158			`else`
159			`loop`
160			`Next_Elmt := Next (Elmt);`
161
162			`if Next_Elmt = Null_Ptr then`
163			`return;`
164
165			`elsif Equal (Get_Key (Next_Elmt), K) then`
166			`Set_Next (Elmt, Next (Next_Elmt));`
167			`return;`
168
169			`else`
170			`Elmt := Next_Elmt;`
171			`end if;`
172			`end loop;`
173			`end if;`
174			`end Remove;`
175
176			`-----------`
177			`-- Reset --`
178			`-----------`
179
180			`procedure Reset (T : in out Instance) is`
181			`procedure Free is`
182			`new Ada.Unchecked_Deallocation (Instance_Data, Instance);`
183
184			`begin`
185			`if T = null then`
186			`return;`
187			`end if;`
188
189			`for J in T.Table'Range loop`
190			`T.Table (J) := Null_Ptr;`
191			`end loop;`
192
193			`Free (T);`
194			`end Reset;`
195
196			`---------`
197			`-- Set --`
198			`---------`
199
200			`procedure Set (T : in out Instance; E : Elmt_Ptr) is`
201			`Index : Header_Num;`
202
203			`begin`
204			`if T = null then`
205			`T := new Instance_Data;`
206			`end if;`
207
208			`Index := Hash (Get_Key (E));`
209			`Set_Next (E, T.Table (Index));`
210			`T.Table (Index) := E;`
211			`end Set;`
212
213			`end Static_HTable;`
214
215			`-------------------`
216			`-- Simple_HTable --`
217			`-------------------`
218
219			`package body Simple_HTable is`
220
221			`---------`
222			`-- Get --`
223			`---------`
224
225			`function Get (T : Instance; K : Key) return Element is`
226			`Tmp : Elmt_Ptr;`
227
228			`begin`
229			`if T = Nil then`
230			`return No_Element;`
231			`end if;`
232
233			`Tmp := Tab.Get (Tab.Instance (T), K);`
234
235			`if Tmp = null then`
236			`return No_Element;`
237			`else`
238			`return Tmp.E;`
239			`end if;`
240			`end Get;`
241
242			`---------------`
243			`-- Get_First --`
244			`---------------`
245
246			`function Get_First (T : Instance) return Element is`
247			`Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));`
248
249			`begin`
250			`if Tmp = null then`
251			`return No_Element;`
252			`else`
253			`return Tmp.E;`
254			`end if;`
255			`end Get_First;`
256
257			`-------------`
258			`-- Get_Key --`
259			`-------------`
260
261			`function Get_Key (E : Elmt_Ptr) return Key is`
262			`begin`
263			`return E.K;`
264			`end Get_Key;`
265
266			`--------------`
267			`-- Get_Next --`
268			`--------------`
269
270			`function Get_Next (T : Instance) return Element is`
271			`Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));`
272			`begin`
273			`if Tmp = null then`
274			`return No_Element;`
275			`else`
276			`return Tmp.E;`
277			`end if;`
278			`end Get_Next;`
279
280			`----------`
281			`-- Next --`
282			`----------`
283
284			`function Next (E : Elmt_Ptr) return Elmt_Ptr is`
285			`begin`
286			`return E.Next;`
287			`end Next;`
288
289			`------------`
290			`-- Remove --`
291			`------------`
292
293			`procedure Remove (T : Instance; K : Key) is`
294			`Tmp : Elmt_Ptr;`
295
296			`begin`
297			`Tmp := Tab.Get (Tab.Instance (T), K);`
298
299			`if Tmp /= null then`
300			`Tab.Remove (Tab.Instance (T), K);`
301			`Free (Tmp);`
302			`end if;`
303			`end Remove;`
304
305			`-----------`
306			`-- Reset --`
307			`-----------`
308
309			`procedure Reset (T : in out Instance) is`
310			`E1, E2 : Elmt_Ptr;`
311
312			`begin`
313			`E1 := Tab.Get_First (Tab.Instance (T));`
314			`while E1 /= null loop`
315			`E2 := Tab.Get_Next (Tab.Instance (T));`
316			`Free (E1);`
317			`E1 := E2;`
318			`end loop;`
319
320			`Tab.Reset (Tab.Instance (T));`
321			`end Reset;`
322
323			`---------`
324			`-- Set --`
325			`---------`
326
327			`procedure Set (T : in out Instance; K : Key; E : Element) is`
328			`Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);`
329			`begin`
330			`if Tmp = null then`
331			`Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));`
332			`else`
333			`Tmp.E := E;`
334			`end if;`
335			`end Set;`
336
337			`--------------`
338			`-- Set_Next --`
339			`--------------`
340
341			`procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is`
342			`begin`
343			`E.Next := Next;`
344			`end Set_Next;`
345
346			`end Simple_HTable;`
347
348			`end GNAT.Dynamic_HTables;`