1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . D Y N A M I C _ T A B L E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2016, 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. --
-- --
------------------------------------------------------------------------------
-- Resizable one dimensional array support
-- This package provides an implementation of dynamically resizable one
-- dimensional arrays. The idea is to mimic the normal Ada semantics for
-- arrays as closely as possible with the one additional capability of
-- dynamically modifying the value of the Last attribute.
-- This package provides a facility similar to that of GNAT.Table, except
-- that this package declares a type that can be used to define dynamic
-- instances of the table, while an instantiation of GNAT.Table creates a
-- single instance of the table type.
-- Note that these three interfaces should remain synchronized to keep as much
-- coherency as possible among these three related units:
--
-- GNAT.Dynamic_Tables
-- GNAT.Table
-- Table (the compiler unit)
pragma Compiler_Unit_Warning;
with Ada.Unchecked_Conversion;
generic
type Table_Component_Type is private;
type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type;
Table_Initial : Positive := 8;
Table_Increment : Natural := 100;
package GNAT.Dynamic_Tables is
-- Table_Component_Type and Table_Index_Type specify the type of the array,
-- Table_Low_Bound is the lower bound. The effect is roughly to declare:
-- Table : array (Table_Low_Bound .. <>) of Table_Component_Type;
-- The lower bound of Table_Index_Type is ignored.
pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First);
function First return Table_Index_Type;
pragma Inline (First);
-- Export First as synonym for Table_Low_Bound (parallel with use of Last)
subtype Valid_Table_Index_Type is Table_Index_Type'Base
range Table_Low_Bound .. Table_Index_Type'Base'Last;
subtype Table_Count_Type is Table_Index_Type'Base
range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last;
-- Table_Component_Type must not be a type with controlled parts.
-- The Table_Initial value controls the allocation of the table when
-- it is first allocated.
-- The Table_Increment value controls the amount of increase, if the
-- table has to be increased in size. The value given is a percentage
-- value (e.g. 100 = increase table size by 100%, i.e. double it).
-- The Last and Set_Last subprograms provide control over the current
-- logical allocation. They are quite efficient, so they can be used
-- freely (expensive reallocation occurs only at major granularity
-- chunks controlled by the allocation parameters).
-- Note: we do not make the table components aliased, since this would
-- restrict the use of table for discriminated types. If it is necessary
-- to take the access of a table element, use Unrestricted_Access.
type Table_Type is
array (Valid_Table_Index_Type range <>) of Table_Component_Type;
subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Valid_Table_Index_Type'Last);
-- We work with pointers to a bogus array type that is constrained with
-- the maximum possible range bound. This means that the pointer is a thin
-- pointer, which is more efficient. Since subscript checks in any case
-- must be on the logical, rather than physical bounds, safety is not
-- compromised by this approach.
-- To get subscript checking, rename a slice of the Table, like this:
-- Table : Table_Type renames T.Table (First .. Last (T));
-- and the refer to components of Table.
type Table_Ptr is access all Big_Table_Type;
for Table_Ptr'Storage_Size use 0;
-- The table is actually represented as a pointer to allow reallocation
type Table_Private is private;
-- Table private data that is not exported in Instance
-- Private use only:
subtype Empty_Table_Array_Type is
Table_Type (Table_Low_Bound .. Table_Low_Bound - 1);
type Empty_Table_Array_Ptr is access all Empty_Table_Array_Type;
Empty_Table_Array : aliased Empty_Table_Array_Type;
function Empty_Table_Array_Ptr_To_Table_Ptr is
new Ada.Unchecked_Conversion (Empty_Table_Array_Ptr, Table_Ptr);
-- End private use only. The above are used to initialize Table to point to
-- an empty array.
type Instance is record
Table : aliased Table_Ptr :=
Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-- The table itself. The lower bound is the value of First. Logically
-- the upper bound is the current value of Last (although the actual
-- size of the allocated table may be larger than this). The program may
-- only access and modify Table entries in the range First .. Last.
--
-- It's a good idea to access this via a renaming of a slice, in order
-- to ensure bounds checking, as in:
--
-- Tab : Table_Type renames X.Table (First .. X.Last);
Locked : Boolean := False;
-- Table expansion is permitted only if this switch is set to False. A
-- client may set Locked to True, in which case any attempt to expand
-- the table will cause an assertion failure. Note that while a table
-- is locked, its address in memory remains fixed and unchanging.
P : Table_Private;
end record;
procedure Init (T : in out Instance);
-- Reinitializes the table to empty. There is no need to call this before
-- using a table; tables default to empty.
function Last (T : Instance) return Table_Count_Type;
pragma Inline (Last);
-- Returns the current value of the last used entry in the table, which can
-- then be used as a subscript for Table.
procedure Release (T : in out Instance);
-- Storage is allocated in chunks according to the values given in the
-- Table_Initial and Table_Increment parameters. A call to Release releases
-- all storage that is allocated, but is not logically part of the current
-- array value. Current array values are not affected by this call.
procedure Free (T : in out Instance);
-- Same as Init
procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type);
pragma Inline (Set_Last);
-- This procedure sets Last to the indicated value. If necessary the table
-- is reallocated to accommodate the new value (i.e. on return the
-- allocated table has an upper bound of at least Last). If Set_Last
-- reduces the size of the table, then logically entries are removed from
-- the table. If Set_Last increases the size of the table, then new entries
-- are logically added to the table.
procedure Increment_Last (T : in out Instance);
pragma Inline (Increment_Last);
-- Adds 1 to Last (same as Set_Last (Last + 1))
procedure Decrement_Last (T : in out Instance);
pragma Inline (Decrement_Last);
-- Subtracts 1 from Last (same as Set_Last (Last - 1))
procedure Append (T : in out Instance; New_Val : Table_Component_Type);
pragma Inline (Append);
-- Appends New_Val onto the end of the table
-- Equivalent to:
-- Increment_Last (T);
-- T.Table (T.Last) := New_Val;
procedure Append_All (T : in out Instance; New_Vals : Table_Type);
-- Appends all components of New_Vals
procedure Set_Item
(T : in out Instance;
Index : Valid_Table_Index_Type;
Item : Table_Component_Type);
pragma Inline (Set_Item);
-- Put Item in the table at position Index. If Index points to an existing
-- item (i.e. it is in the range First .. Last (T)), the item is replaced.
-- Otherwise (i.e. Index > Last (T), the table is expanded, and Last is set
-- to Index.
procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate);
-- Adds Num to Last
generic
with procedure Action
(Index : Valid_Table_Index_Type;
Item : Table_Component_Type;
Quit : in out Boolean) is <>;
procedure For_Each (Table : Instance);
-- Calls procedure Action for each component of the table, or until one of
-- these calls set Quit to True.
generic
with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
procedure Sort_Table (Table : in out Instance);
-- This procedure sorts the components of the table into ascending
-- order making calls to Lt to do required comparisons, and using
-- assignments to move components around. The Lt function returns True
-- if Comp1 is less than Comp2 (in the sense of the desired sort), and
-- False if Comp1 is greater than Comp2. For equal objects it does not
-- matter if True or False is returned (it is slightly more efficient
-- to return False). The sort is not stable (the order of equal items
-- in the table is not preserved).
private
type Table_Private is record
Last_Allocated : Table_Count_Type := Table_Low_Bound - 1;
-- Subscript of the maximum entry in the currently allocated table.
-- Initial value ensures that we initially allocate the table.
Last : Table_Count_Type := Table_Low_Bound - 1;
-- Current value of Last function
-- Invariant: Last <= Last_Allocated
end record;
end GNAT.Dynamic_Tables;
|
