OpenCores
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

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;

powered by: WebSVN 2.1.0

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