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/] [table.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                T A B L E                                 --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
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 Debug;   use Debug;
33
with Opt;     use Opt;
34
with Output;  use Output;
35
with System;  use System;
36
with Tree_IO; use Tree_IO;
37
 
38
with System.Memory; use System.Memory;
39
 
40
with Unchecked_Conversion;
41
 
42
pragma Elaborate_All (Output);
43
 
44
package body Table is
45
   package body Table is
46
 
47
      Min : constant Int := Int (Table_Low_Bound);
48
      --  Subscript of the minimum entry in the currently allocated table
49
 
50
      Length : Int := 0;
51
      --  Number of entries in currently allocated table. The value of zero
52
      --  ensures that we initially allocate the table.
53
 
54
      -----------------------
55
      -- Local Subprograms --
56
      -----------------------
57
 
58
      procedure Reallocate;
59
      --  Reallocate the existing table according to the current value stored
60
      --  in Max. Works correctly to do an initial allocation if the table
61
      --  is currently null.
62
 
63
      function Tree_Get_Table_Address return Address;
64
      --  Return Null_Address if the table length is zero,
65
      --  Table (First)'Address if not.
66
 
67
      pragma Warnings (Off);
68
      --  Turn off warnings. The following unchecked conversions are only used
69
      --  internally in this package, and cannot never result in any instances
70
      --  of improperly aliased pointers for the client of the package.
71
 
72
      function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
73
      function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
74
 
75
      pragma Warnings (On);
76
 
77
      ------------
78
      -- Append --
79
      ------------
80
 
81
      procedure Append (New_Val : Table_Component_Type) is
82
      begin
83
         Set_Item (Table_Index_Type (Last_Val + 1), New_Val);
84
      end Append;
85
 
86
      ----------------
87
      -- Append_All --
88
      ----------------
89
 
90
      procedure Append_All (New_Vals : Table_Type) is
91
      begin
92
         for J in New_Vals'Range loop
93
            Append (New_Vals (J));
94
         end loop;
95
      end Append_All;
96
 
97
      --------------------
98
      -- Decrement_Last --
99
      --------------------
100
 
101
      procedure Decrement_Last is
102
      begin
103
         Last_Val := Last_Val - 1;
104
      end Decrement_Last;
105
 
106
      ----------
107
      -- Free --
108
      ----------
109
 
110
      procedure Free is
111
      begin
112
         Free (To_Address (Table));
113
         Table := null;
114
         Length := 0;
115
      end Free;
116
 
117
      --------------------
118
      -- Increment_Last --
119
      --------------------
120
 
121
      procedure Increment_Last is
122
      begin
123
         Last_Val := Last_Val + 1;
124
 
125
         if Last_Val > Max then
126
            Reallocate;
127
         end if;
128
      end Increment_Last;
129
 
130
      ----------
131
      -- Init --
132
      ----------
133
 
134
      procedure Init is
135
         Old_Length : constant Int := Length;
136
 
137
      begin
138
         Locked   := False;
139
         Last_Val := Min - 1;
140
         Max      := Min + (Table_Initial * Table_Factor) - 1;
141
         Length   := Max - Min + 1;
142
 
143
         --  If table is same size as before (happens when table is never
144
         --  expanded which is a common case), then simply reuse it. Note
145
         --  that this also means that an explicit Init call right after
146
         --  the implicit one in the package body is harmless.
147
 
148
         if Old_Length = Length then
149
            return;
150
 
151
         --  Otherwise we can use Reallocate to get a table of the right size.
152
         --  Note that Reallocate works fine to allocate a table of the right
153
         --  initial size when it is first allocated.
154
 
155
         else
156
            Reallocate;
157
         end if;
158
      end Init;
159
 
160
      ----------
161
      -- Last --
162
      ----------
163
 
164
      function Last return Table_Index_Type is
165
      begin
166
         return Table_Index_Type (Last_Val);
167
      end Last;
168
 
169
      ----------------
170
      -- Reallocate --
171
      ----------------
172
 
173
      procedure Reallocate is
174
         New_Size   : Memory.size_t;
175
 
176
      begin
177
         if Max < Last_Val then
178
            pragma Assert (not Locked);
179
 
180
            --  Make sure that we have at least the initial allocation. This
181
            --  is needed in cases where a zero length table is written out.
182
 
183
            Length := Int'Max (Length, Table_Initial);
184
 
185
            --  Now increment table length until it is sufficiently large. Use
186
            --  the increment value or 10, which ever is larger (the reason
187
            --  for the use of 10 here is to ensure that the table does really
188
            --  increase in size (which would not be the case for a table of
189
            --  length 10 increased by 3% for instance).
190
 
191
            while Max < Last_Val loop
192
               Length := Int'Max (Length * (100 + Table_Increment) / 100,
193
                                  Length + 10);
194
               Max := Min + Length - 1;
195
            end loop;
196
 
197
            if Debug_Flag_D then
198
               Write_Str ("--> Allocating new ");
199
               Write_Str (Table_Name);
200
               Write_Str (" table, size = ");
201
               Write_Int (Max - Min + 1);
202
               Write_Eol;
203
            end if;
204
         end if;
205
 
206
         New_Size :=
207
           Memory.size_t ((Max - Min + 1) *
208
                          (Table_Type'Component_Size / Storage_Unit));
209
 
210
         if Table = null then
211
            Table := To_Pointer (Alloc (New_Size));
212
 
213
         elsif New_Size > 0 then
214
            Table :=
215
              To_Pointer (Realloc (Ptr  => To_Address (Table),
216
                                   Size => New_Size));
217
         end if;
218
 
219
         if Length /= 0 and then Table = null then
220
            Set_Standard_Error;
221
            Write_Str ("available memory exhausted");
222
            Write_Eol;
223
            Set_Standard_Output;
224
            raise Unrecoverable_Error;
225
         end if;
226
 
227
      end Reallocate;
228
 
229
      -------------
230
      -- Release --
231
      -------------
232
 
233
      procedure Release is
234
      begin
235
         Length := Last_Val - Int (Table_Low_Bound) + 1;
236
         Max    := Last_Val;
237
         Reallocate;
238
      end Release;
239
 
240
      -------------
241
      -- Restore --
242
      -------------
243
 
244
      procedure Restore (T : Saved_Table) is
245
      begin
246
         Free (To_Address (Table));
247
         Last_Val := T.Last_Val;
248
         Max      := T.Max;
249
         Table    := T.Table;
250
         Length   := Max - Min + 1;
251
      end Restore;
252
 
253
      ----------
254
      -- Save --
255
      ----------
256
 
257
      function Save return Saved_Table is
258
         Res : Saved_Table;
259
 
260
      begin
261
         Res.Last_Val := Last_Val;
262
         Res.Max      := Max;
263
         Res.Table    := Table;
264
 
265
         Table  := null;
266
         Length := 0;
267
         Init;
268
         return Res;
269
      end Save;
270
 
271
      --------------
272
      -- Set_Item --
273
      --------------
274
 
275
      procedure Set_Item
276
         (Index : Table_Index_Type;
277
          Item  : Table_Component_Type)
278
      is
279
         --  If Item is a value within the current allocation, and we are going
280
         --  to reallocate, then we must preserve an intermediate copy here
281
         --  before calling Increment_Last. Otherwise, if Table_Component_Type
282
         --  is passed by reference, we are going to end up copying from
283
         --  storage that might have been deallocated from Increment_Last
284
         --  calling Reallocate.
285
 
286
         subtype Allocated_Table_T is
287
           Table_Type (Table'First .. Table_Index_Type (Max + 1));
288
         --  A constrained table subtype one element larger than the currently
289
         --  allocated table.
290
 
291
         Allocated_Table_Address : constant System.Address :=
292
                                     Table.all'Address;
293
         --  Used for address clause below (we can't use non-static expression
294
         --  Table.all'Address directly in the clause because some older
295
         --  versions of the compiler do not allow it).
296
 
297
         Allocated_Table : Allocated_Table_T;
298
         pragma Import (Ada, Allocated_Table);
299
         pragma Suppress (Range_Check, On => Allocated_Table);
300
         for Allocated_Table'Address use Allocated_Table_Address;
301
         --  Allocated_Table represents the currently allocated array, plus one
302
         --  element (the supplementary element is used to have a convenient
303
         --  way of computing the address just past the end of the current
304
         --  allocation). Range checks are suppressed because this unit
305
         --  uses direct calls to System.Memory for allocation, and this can
306
         --  yield misaligned storage (and we cannot rely on the bootstrap
307
         --  compiler supporting specifically disabling alignment checks, so we
308
         --  need to suppress all range checks). It is safe to suppress this
309
         --  check here because we know that a (possibly misaligned) object
310
         --  of that type does actually exist at that address.
311
         --  ??? We should really improve the allocation circuitry here to
312
         --  guarantee proper alignment.
313
 
314
         Need_Realloc : constant Boolean := Int (Index) > Max;
315
         --  True if this operation requires storage reallocation (which may
316
         --  involve moving table contents around).
317
 
318
      begin
319
         --  If we're going to reallocate, check whether Item references an
320
         --  element of the currently allocated table.
321
 
322
         if Need_Realloc
323
           and then Allocated_Table'Address <= Item'Address
324
           and then Item'Address <
325
                      Allocated_Table (Table_Index_Type (Max + 1))'Address
326
         then
327
            --  If so, save a copy on the stack because Increment_Last will
328
            --  reallocate storage and might deallocate the current table.
329
 
330
            declare
331
               Item_Copy : constant Table_Component_Type := Item;
332
            begin
333
               Set_Last (Index);
334
               Table (Index) := Item_Copy;
335
            end;
336
 
337
         else
338
            --  Here we know that either we won't reallocate (case of Index <
339
            --  Max) or that Item is not in the currently allocated table.
340
 
341
            if Int (Index) > Last_Val then
342
               Set_Last (Index);
343
            end if;
344
 
345
            Table (Index) := Item;
346
         end if;
347
      end Set_Item;
348
 
349
      --------------
350
      -- Set_Last --
351
      --------------
352
 
353
      procedure Set_Last (New_Val : Table_Index_Type) is
354
      begin
355
         if Int (New_Val) < Last_Val then
356
            Last_Val := Int (New_Val);
357
 
358
         else
359
            Last_Val := Int (New_Val);
360
 
361
            if Last_Val > Max then
362
               Reallocate;
363
            end if;
364
         end if;
365
      end Set_Last;
366
 
367
      ----------------------------
368
      -- Tree_Get_Table_Address --
369
      ----------------------------
370
 
371
      function Tree_Get_Table_Address return Address is
372
      begin
373
         if Length = 0 then
374
            return Null_Address;
375
         else
376
            return Table (First)'Address;
377
         end if;
378
      end Tree_Get_Table_Address;
379
 
380
      ---------------
381
      -- Tree_Read --
382
      ---------------
383
 
384
      --  Note: we allocate only the space required to accommodate the data
385
      --  actually written, which means that a Tree_Write/Tree_Read sequence
386
      --  does an implicit Release.
387
 
388
      procedure Tree_Read is
389
      begin
390
         Tree_Read_Int (Max);
391
         Last_Val := Max;
392
         Length := Max - Min + 1;
393
         Reallocate;
394
 
395
         Tree_Read_Data
396
           (Tree_Get_Table_Address,
397
             (Last_Val - Int (First) + 1) *
398
               Table_Type'Component_Size / Storage_Unit);
399
      end Tree_Read;
400
 
401
      ----------------
402
      -- Tree_Write --
403
      ----------------
404
 
405
      --  Note: we write out only the currently valid data, not the entire
406
      --  contents of the allocated array. See note above on Tree_Read.
407
 
408
      procedure Tree_Write is
409
      begin
410
         Tree_Write_Int (Int (Last));
411
         Tree_Write_Data
412
           (Tree_Get_Table_Address,
413
            (Last_Val - Int (First) + 1) *
414
              Table_Type'Component_Size / Storage_Unit);
415
      end Tree_Write;
416
 
417
   begin
418
      Init;
419
   end Table;
420
end Table;

powered by: WebSVN 2.1.0

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