OpenCores
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

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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.