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

Subversion Repositories openrisc

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

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--                            G N A T . T A B L E                           --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--                     Copyright (C) 1998-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
with System;        use System;
33
with System.Memory; use System.Memory;
34
 
35
with Ada.Unchecked_Conversion;
36
 
37
package body GNAT.Table is
38
 
39
   Min : constant Integer := Integer (Table_Low_Bound);
40
   --  Subscript of the minimum entry in the currently allocated table
41
 
42
   Max : Integer;
43
   --  Subscript of the maximum entry in the currently allocated table
44
 
45
   Length : Integer := 0;
46
   --  Number of entries in currently allocated table. The value of zero
47
   --  ensures that we initially allocate the table.
48
 
49
   Last_Val : Integer;
50
   --  Current value of Last
51
 
52
   -----------------------
53
   -- Local Subprograms --
54
   -----------------------
55
 
56
   procedure Reallocate;
57
   --  Reallocate the existing table according to the current value stored
58
   --  in Max. Works correctly to do an initial allocation if the table
59
   --  is currently null.
60
 
61
   pragma Warnings (Off);
62
   --  Turn off warnings. The following unchecked conversions are only used
63
   --  internally in this package, and cannot never result in any instances
64
   --  of improperly aliased pointers for the client of the package.
65
 
66
   function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
67
   function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
68
 
69
   pragma Warnings (On);
70
 
71
   --------------
72
   -- Allocate --
73
   --------------
74
 
75
   function Allocate (Num : Integer := 1) return Table_Index_Type is
76
      Old_Last : constant Integer := Last_Val;
77
 
78
   begin
79
      Last_Val := Last_Val + Num;
80
 
81
      if Last_Val > Max then
82
         Reallocate;
83
      end if;
84
 
85
      return Table_Index_Type (Old_Last + 1);
86
   end Allocate;
87
 
88
   ------------
89
   -- Append --
90
   ------------
91
 
92
   procedure Append (New_Val : Table_Component_Type) is
93
   begin
94
      Set_Item (Table_Index_Type (Last_Val + 1), New_Val);
95
   end Append;
96
 
97
   ----------------
98
   -- Append_All --
99
   ----------------
100
 
101
   procedure Append_All (New_Vals : Table_Type) is
102
   begin
103
      for J in New_Vals'Range loop
104
         Append (New_Vals (J));
105
      end loop;
106
   end Append_All;
107
 
108
   --------------------
109
   -- Decrement_Last --
110
   --------------------
111
 
112
   procedure Decrement_Last is
113
   begin
114
      Last_Val := Last_Val - 1;
115
   end Decrement_Last;
116
 
117
   ----------
118
   -- Free --
119
   ----------
120
 
121
   procedure Free is
122
   begin
123
      Free (To_Address (Table));
124
      Table := null;
125
      Length := 0;
126
   end Free;
127
 
128
   --------------------
129
   -- Increment_Last --
130
   --------------------
131
 
132
   procedure Increment_Last is
133
   begin
134
      Last_Val := Last_Val + 1;
135
 
136
      if Last_Val > Max then
137
         Reallocate;
138
      end if;
139
   end Increment_Last;
140
 
141
   ----------
142
   -- Init --
143
   ----------
144
 
145
   procedure Init is
146
      Old_Length : constant Integer := Length;
147
 
148
   begin
149
      Last_Val := Min - 1;
150
      Max      := Min + Table_Initial - 1;
151
      Length   := Max - Min + 1;
152
 
153
      --  If table is same size as before (happens when table is never
154
      --  expanded which is a common case), then simply reuse it. Note
155
      --  that this also means that an explicit Init call right after
156
      --  the implicit one in the package body is harmless.
157
 
158
      if Old_Length = Length then
159
         return;
160
 
161
      --  Otherwise we can use Reallocate to get a table of the right size.
162
      --  Note that Reallocate works fine to allocate a table of the right
163
      --  initial size when it is first allocated.
164
 
165
      else
166
         Reallocate;
167
      end if;
168
   end Init;
169
 
170
   ----------
171
   -- Last --
172
   ----------
173
 
174
   function Last return Table_Index_Type is
175
   begin
176
      return Table_Index_Type (Last_Val);
177
   end Last;
178
 
179
   ----------------
180
   -- Reallocate --
181
   ----------------
182
 
183
   procedure Reallocate is
184
      New_Size : size_t;
185
 
186
   begin
187
      if Max < Last_Val then
188
         pragma Assert (not Locked);
189
 
190
         while Max < Last_Val loop
191
 
192
            --  Increase length using the table increment factor, but make
193
            --  sure that we add at least ten elements (this avoids a loop
194
            --  for silly small increment values)
195
 
196
            Length := Integer'Max
197
                        (Length * (100 + Table_Increment) / 100,
198
                         Length + 10);
199
            Max := Min + Length - 1;
200
         end loop;
201
      end if;
202
 
203
      New_Size :=
204
        size_t ((Max - Min + 1) *
205
                (Table_Type'Component_Size / Storage_Unit));
206
 
207
      if Table = null then
208
         Table := To_Pointer (Alloc (New_Size));
209
 
210
      elsif New_Size > 0 then
211
         Table :=
212
           To_Pointer (Realloc (Ptr  => To_Address (Table),
213
                                Size => New_Size));
214
      end if;
215
 
216
      if Length /= 0 and then Table = null then
217
         raise Storage_Error;
218
      end if;
219
 
220
   end Reallocate;
221
 
222
   -------------
223
   -- Release --
224
   -------------
225
 
226
   procedure Release is
227
   begin
228
      Length := Last_Val - Integer (Table_Low_Bound) + 1;
229
      Max    := Last_Val;
230
      Reallocate;
231
   end Release;
232
 
233
   --------------
234
   -- Set_Item --
235
   --------------
236
 
237
   procedure Set_Item
238
      (Index : Table_Index_Type;
239
       Item  : Table_Component_Type)
240
   is
241
      --  If Item is a value within the current allocation, and we are going to
242
      --  reallocate, then we must preserve an intermediate copy here before
243
      --  calling Increment_Last. Otherwise, if Table_Component_Type is passed
244
      --  by reference, we are going to end up copying from storage that might
245
      --  have been deallocated from Increment_Last calling Reallocate.
246
 
247
      subtype Allocated_Table_T is
248
        Table_Type (Table'First .. Table_Index_Type (Max + 1));
249
      --  A constrained table subtype one element larger than the currently
250
      --  allocated table.
251
 
252
      Allocated_Table_Address : constant System.Address :=
253
                                  Table.all'Address;
254
      --  Used for address clause below (we can't use non-static expression
255
      --  Table.all'Address directly in the clause because some older versions
256
      --  of the compiler do not allow it).
257
 
258
      Allocated_Table : Allocated_Table_T;
259
      pragma Import (Ada, Allocated_Table);
260
      pragma Suppress (Range_Check, On => Allocated_Table);
261
      for Allocated_Table'Address use Allocated_Table_Address;
262
      --  Allocated_Table represents the currently allocated array, plus
263
      --  one element (the supplementary element is used to have a
264
      --  convenient way of computing the address just past the end of the
265
      --  current allocation). Range checks are suppressed because this unit
266
      --  uses direct calls to System.Memory for allocation, and this can
267
      --  yield misaligned storage (and we cannot rely on the bootstrap
268
      --  compiler supporting specifically disabling alignment checks, so we
269
      --  need to suppress all range checks). It is safe to suppress this check
270
      --  here because we know that a (possibly misaligned) object of that type
271
      --  does actually exist at that address.
272
      --  ??? We should really improve the allocation circuitry here to
273
      --  guarantee proper alignment.
274
 
275
      Need_Realloc : constant Boolean := Integer (Index) > Max;
276
      --  True if this operation requires storage reallocation (which may
277
      --  involve moving table contents around).
278
 
279
   begin
280
      --  If we're going to reallocate, check whether Item references an
281
      --  element of the currently allocated table.
282
 
283
      if Need_Realloc
284
        and then Allocated_Table'Address <= Item'Address
285
        and then Item'Address <
286
                   Allocated_Table (Table_Index_Type (Max + 1))'Address
287
      then
288
         --  If so, save a copy on the stack because Increment_Last will
289
         --  reallocate storage and might deallocate the current table.
290
 
291
         declare
292
            Item_Copy : constant Table_Component_Type := Item;
293
         begin
294
            Set_Last (Index);
295
            Table (Index) := Item_Copy;
296
         end;
297
 
298
      else
299
         --  Here we know that either we won't reallocate (case of Index < Max)
300
         --  or that Item is not in the currently allocated table.
301
 
302
         if Integer (Index) > Last_Val then
303
            Set_Last (Index);
304
         end if;
305
 
306
         Table (Index) := Item;
307
      end if;
308
   end Set_Item;
309
 
310
   --------------
311
   -- Set_Last --
312
   --------------
313
 
314
   procedure Set_Last (New_Val : Table_Index_Type) is
315
   begin
316
      if Integer (New_Val) < Last_Val then
317
         Last_Val := Integer (New_Val);
318
      else
319
         Last_Val := Integer (New_Val);
320
 
321
         if Last_Val > Max then
322
            Reallocate;
323
         end if;
324
      end if;
325
   end Set_Last;
326
 
327
begin
328
   Init;
329
end GNAT.Table;

powered by: WebSVN 2.1.0

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