]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT RUNTIME COMPONENTS -- | |
4 | -- -- | |
5 | -- G N A T . T A B L E -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
bcea76b6 | 9 | -- Copyright (C) 1998-2002 Ada Core Technologies, Inc. -- |
38cbfe40 RK |
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, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, 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 | -- -- | |
fbf5a39b AC |
29 | -- GNAT was originally developed by the GNAT team at New York University. -- |
30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
38cbfe40 RK |
31 | -- -- |
32 | ------------------------------------------------------------------------------ | |
33 | ||
07fc65c4 GB |
34 | with System; use System; |
35 | with System.Memory; use System.Memory; | |
bcea76b6 GB |
36 | |
37 | with Unchecked_Conversion; | |
38cbfe40 RK |
38 | |
39 | package body GNAT.Table is | |
40 | ||
41 | Min : constant Integer := Integer (Table_Low_Bound); | |
42 | -- Subscript of the minimum entry in the currently allocated table | |
43 | ||
44 | Max : Integer; | |
45 | -- Subscript of the maximum entry in the currently allocated table | |
46 | ||
47 | Length : Integer := 0; | |
48 | -- Number of entries in currently allocated table. The value of zero | |
49 | -- ensures that we initially allocate the table. | |
50 | ||
51 | Last_Val : Integer; | |
52 | -- Current value of Last. | |
53 | ||
38cbfe40 RK |
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 | ||
bcea76b6 GB |
63 | function To_Address is new Unchecked_Conversion (Table_Ptr, Address); |
64 | function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr); | |
07fc65c4 | 65 | |
38cbfe40 RK |
66 | -------------- |
67 | -- Allocate -- | |
68 | -------------- | |
69 | ||
70 | function Allocate (Num : Integer := 1) return Table_Index_Type is | |
71 | Old_Last : constant Integer := Last_Val; | |
72 | ||
73 | begin | |
74 | Last_Val := Last_Val + Num; | |
75 | ||
76 | if Last_Val > Max then | |
77 | Reallocate; | |
78 | end if; | |
79 | ||
80 | return Table_Index_Type (Old_Last + 1); | |
81 | end Allocate; | |
82 | ||
83 | ------------ | |
84 | -- Append -- | |
85 | ------------ | |
86 | ||
87 | procedure Append (New_Val : Table_Component_Type) is | |
88 | begin | |
89 | Increment_Last; | |
90 | Table (Table_Index_Type (Last_Val)) := New_Val; | |
91 | end Append; | |
92 | ||
93 | -------------------- | |
94 | -- Decrement_Last -- | |
95 | -------------------- | |
96 | ||
97 | procedure Decrement_Last is | |
98 | begin | |
99 | Last_Val := Last_Val - 1; | |
100 | end Decrement_Last; | |
101 | ||
102 | ---------- | |
103 | -- Free -- | |
104 | ---------- | |
105 | ||
106 | procedure Free is | |
38cbfe40 | 107 | begin |
07fc65c4 | 108 | Free (To_Address (Table)); |
38cbfe40 RK |
109 | Table := null; |
110 | Length := 0; | |
111 | end Free; | |
112 | ||
113 | -------------------- | |
114 | -- Increment_Last -- | |
115 | -------------------- | |
116 | ||
117 | procedure Increment_Last is | |
118 | begin | |
119 | Last_Val := Last_Val + 1; | |
120 | ||
121 | if Last_Val > Max then | |
122 | Reallocate; | |
123 | end if; | |
124 | end Increment_Last; | |
125 | ||
126 | ---------- | |
127 | -- Init -- | |
128 | ---------- | |
129 | ||
130 | procedure Init is | |
bcea76b6 | 131 | Old_Length : constant Integer := Length; |
38cbfe40 RK |
132 | |
133 | begin | |
134 | Last_Val := Min - 1; | |
135 | Max := Min + Table_Initial - 1; | |
136 | Length := Max - Min + 1; | |
137 | ||
138 | -- If table is same size as before (happens when table is never | |
139 | -- expanded which is a common case), then simply reuse it. Note | |
140 | -- that this also means that an explicit Init call right after | |
141 | -- the implicit one in the package body is harmless. | |
142 | ||
143 | if Old_Length = Length then | |
144 | return; | |
145 | ||
146 | -- Otherwise we can use Reallocate to get a table of the right size. | |
147 | -- Note that Reallocate works fine to allocate a table of the right | |
148 | -- initial size when it is first allocated. | |
149 | ||
150 | else | |
151 | Reallocate; | |
152 | end if; | |
153 | end Init; | |
154 | ||
155 | ---------- | |
156 | -- Last -- | |
157 | ---------- | |
158 | ||
159 | function Last return Table_Index_Type is | |
160 | begin | |
161 | return Table_Index_Type (Last_Val); | |
162 | end Last; | |
163 | ||
164 | ---------------- | |
165 | -- Reallocate -- | |
166 | ---------------- | |
167 | ||
168 | procedure Reallocate is | |
38cbfe40 RK |
169 | New_Size : size_t; |
170 | ||
171 | begin | |
172 | if Max < Last_Val then | |
173 | pragma Assert (not Locked); | |
174 | ||
175 | while Max < Last_Val loop | |
176 | ||
177 | -- Increase length using the table increment factor, but make | |
178 | -- sure that we add at least ten elements (this avoids a loop | |
179 | -- for silly small increment values) | |
180 | ||
181 | Length := Integer'Max | |
182 | (Length * (100 + Table_Increment) / 100, | |
183 | Length + 10); | |
184 | Max := Min + Length - 1; | |
185 | end loop; | |
186 | end if; | |
187 | ||
188 | New_Size := | |
189 | size_t ((Max - Min + 1) * | |
190 | (Table_Type'Component_Size / Storage_Unit)); | |
191 | ||
192 | if Table = null then | |
07fc65c4 | 193 | Table := To_Pointer (Alloc (New_Size)); |
38cbfe40 RK |
194 | |
195 | elsif New_Size > 0 then | |
196 | Table := | |
07fc65c4 GB |
197 | To_Pointer (Realloc (Ptr => To_Address (Table), |
198 | Size => New_Size)); | |
38cbfe40 RK |
199 | end if; |
200 | ||
201 | if Length /= 0 and then Table = null then | |
202 | raise Storage_Error; | |
203 | end if; | |
204 | ||
205 | end Reallocate; | |
206 | ||
207 | ------------- | |
208 | -- Release -- | |
209 | ------------- | |
210 | ||
211 | procedure Release is | |
212 | begin | |
213 | Length := Last_Val - Integer (Table_Low_Bound) + 1; | |
214 | Max := Last_Val; | |
215 | Reallocate; | |
216 | end Release; | |
217 | ||
218 | -------------- | |
219 | -- Set_Item -- | |
220 | -------------- | |
221 | ||
222 | procedure Set_Item | |
223 | (Index : Table_Index_Type; | |
224 | Item : Table_Component_Type) | |
225 | is | |
226 | begin | |
227 | if Integer (Index) > Max then | |
228 | Set_Last (Index); | |
229 | end if; | |
230 | ||
231 | Table (Index) := Item; | |
232 | end Set_Item; | |
233 | ||
234 | -------------- | |
235 | -- Set_Last -- | |
236 | -------------- | |
237 | ||
238 | procedure Set_Last (New_Val : Table_Index_Type) is | |
239 | begin | |
240 | if Integer (New_Val) < Last_Val then | |
241 | Last_Val := Integer (New_Val); | |
242 | else | |
243 | Last_Val := Integer (New_Val); | |
244 | ||
245 | if Last_Val > Max then | |
246 | Reallocate; | |
247 | end if; | |
248 | end if; | |
249 | end Set_Last; | |
250 | ||
251 | begin | |
252 | Init; | |
253 | end GNAT.Table; |