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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-dynhta.adb] - Blame information for rev 801

Go to most recent revision | 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-2010, 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.      --
--                                                                          --
------------------------------------------------------------------------------
 
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/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-dynhta.adb] - Blame information for rev 801

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