1 |
706 |
jeremybenn |
------------------------------------------------------------------------------
|
2 |
|
|
-- --
|
3 |
|
|
-- GNAT LIBRARY COMPONENTS --
|
4 |
|
|
-- --
|
5 |
|
|
-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
|
6 |
|
|
-- --
|
7 |
|
|
-- B o d y --
|
8 |
|
|
-- --
|
9 |
|
|
-- Copyright (C) 2004-2012, 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 |
|
|
-- This unit was originally developed by Matthew J Heaney. --
|
28 |
|
|
------------------------------------------------------------------------------
|
29 |
|
|
|
30 |
|
|
with Ada.Containers.Generic_Array_Sort;
|
31 |
|
|
with Ada.Finalization; use Ada.Finalization;
|
32 |
|
|
|
33 |
|
|
with System; use type System.Address;
|
34 |
|
|
|
35 |
|
|
package body Ada.Containers.Bounded_Vectors is
|
36 |
|
|
|
37 |
|
|
type Iterator is new Limited_Controlled and
|
38 |
|
|
Vector_Iterator_Interfaces.Reversible_Iterator with
|
39 |
|
|
record
|
40 |
|
|
Container : Vector_Access;
|
41 |
|
|
Index : Index_Type'Base;
|
42 |
|
|
end record;
|
43 |
|
|
|
44 |
|
|
overriding procedure Finalize (Object : in out Iterator);
|
45 |
|
|
|
46 |
|
|
overriding function First (Object : Iterator) return Cursor;
|
47 |
|
|
overriding function Last (Object : Iterator) return Cursor;
|
48 |
|
|
|
49 |
|
|
overriding function Next
|
50 |
|
|
(Object : Iterator;
|
51 |
|
|
Position : Cursor) return Cursor;
|
52 |
|
|
|
53 |
|
|
overriding function Previous
|
54 |
|
|
(Object : Iterator;
|
55 |
|
|
Position : Cursor) return Cursor;
|
56 |
|
|
|
57 |
|
|
-----------------------
|
58 |
|
|
-- Local Subprograms --
|
59 |
|
|
-----------------------
|
60 |
|
|
|
61 |
|
|
function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
|
62 |
|
|
|
63 |
|
|
---------
|
64 |
|
|
-- "&" --
|
65 |
|
|
---------
|
66 |
|
|
|
67 |
|
|
function "&" (Left, Right : Vector) return Vector is
|
68 |
|
|
LN : constant Count_Type := Length (Left);
|
69 |
|
|
RN : constant Count_Type := Length (Right);
|
70 |
|
|
N : Count_Type'Base; -- length of result
|
71 |
|
|
J : Count_Type'Base; -- for computing intermediate index values
|
72 |
|
|
Last : Index_Type'Base; -- Last index of result
|
73 |
|
|
|
74 |
|
|
begin
|
75 |
|
|
-- We decide that the capacity of the result is the sum of the lengths
|
76 |
|
|
-- of the vector parameters. We could decide to make it larger, but we
|
77 |
|
|
-- have no basis for knowing how much larger, so we just allocate the
|
78 |
|
|
-- minimum amount of storage.
|
79 |
|
|
|
80 |
|
|
-- Here we handle the easy cases first, when one of the vector
|
81 |
|
|
-- parameters is empty. (We say "easy" because there's nothing to
|
82 |
|
|
-- compute, that can potentially overflow.)
|
83 |
|
|
|
84 |
|
|
if LN = 0 then
|
85 |
|
|
if RN = 0 then
|
86 |
|
|
return Empty_Vector;
|
87 |
|
|
end if;
|
88 |
|
|
|
89 |
|
|
return Vector'(Capacity => RN,
|
90 |
|
|
Elements => Right.Elements (1 .. RN),
|
91 |
|
|
Last => Right.Last,
|
92 |
|
|
others => <>);
|
93 |
|
|
end if;
|
94 |
|
|
|
95 |
|
|
if RN = 0 then
|
96 |
|
|
return Vector'(Capacity => LN,
|
97 |
|
|
Elements => Left.Elements (1 .. LN),
|
98 |
|
|
Last => Left.Last,
|
99 |
|
|
others => <>);
|
100 |
|
|
end if;
|
101 |
|
|
|
102 |
|
|
-- Neither of the vector parameters is empty, so must compute the length
|
103 |
|
|
-- of the result vector and its last index. (This is the harder case,
|
104 |
|
|
-- because our computations must avoid overflow.)
|
105 |
|
|
|
106 |
|
|
-- There are two constraints we need to satisfy. The first constraint is
|
107 |
|
|
-- that a container cannot have more than Count_Type'Last elements, so
|
108 |
|
|
-- we must check the sum of the combined lengths. Note that we cannot
|
109 |
|
|
-- simply add the lengths, because of the possibility of overflow.
|
110 |
|
|
|
111 |
|
|
if LN > Count_Type'Last - RN then
|
112 |
|
|
raise Constraint_Error with "new length is out of range";
|
113 |
|
|
end if;
|
114 |
|
|
|
115 |
|
|
-- It is now safe compute the length of the new vector, without fear of
|
116 |
|
|
-- overflow.
|
117 |
|
|
|
118 |
|
|
N := LN + RN;
|
119 |
|
|
|
120 |
|
|
-- The second constraint is that the new Last index value cannot
|
121 |
|
|
-- exceed Index_Type'Last. We use the wider of Index_Type'Base and
|
122 |
|
|
-- Count_Type'Base as the type for intermediate values.
|
123 |
|
|
|
124 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
125 |
|
|
-- We perform a two-part test. First we determine whether the
|
126 |
|
|
-- computed Last value lies in the base range of the type, and then
|
127 |
|
|
-- determine whether it lies in the range of the index (sub)type.
|
128 |
|
|
|
129 |
|
|
-- Last must satisfy this relation:
|
130 |
|
|
-- First + Length - 1 <= Last
|
131 |
|
|
-- We regroup terms:
|
132 |
|
|
-- First - 1 <= Last - Length
|
133 |
|
|
-- Which can rewrite as:
|
134 |
|
|
-- No_Index <= Last - Length
|
135 |
|
|
|
136 |
|
|
if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
|
137 |
|
|
raise Constraint_Error with "new length is out of range";
|
138 |
|
|
end if;
|
139 |
|
|
|
140 |
|
|
-- We now know that the computed value of Last is within the base
|
141 |
|
|
-- range of the type, so it is safe to compute its value:
|
142 |
|
|
|
143 |
|
|
Last := No_Index + Index_Type'Base (N);
|
144 |
|
|
|
145 |
|
|
-- Finally we test whether the value is within the range of the
|
146 |
|
|
-- generic actual index subtype:
|
147 |
|
|
|
148 |
|
|
if Last > Index_Type'Last then
|
149 |
|
|
raise Constraint_Error with "new length is out of range";
|
150 |
|
|
end if;
|
151 |
|
|
|
152 |
|
|
elsif Index_Type'First <= 0 then
|
153 |
|
|
-- Here we can compute Last directly, in the normal way. We know that
|
154 |
|
|
-- No_Index is less than 0, so there is no danger of overflow when
|
155 |
|
|
-- adding the (positive) value of length.
|
156 |
|
|
|
157 |
|
|
J := Count_Type'Base (No_Index) + N; -- Last
|
158 |
|
|
|
159 |
|
|
if J > Count_Type'Base (Index_Type'Last) then
|
160 |
|
|
raise Constraint_Error with "new length is out of range";
|
161 |
|
|
end if;
|
162 |
|
|
|
163 |
|
|
-- We know that the computed value (having type Count_Type) of Last
|
164 |
|
|
-- is within the range of the generic actual index subtype, so it is
|
165 |
|
|
-- safe to convert to Index_Type:
|
166 |
|
|
|
167 |
|
|
Last := Index_Type'Base (J);
|
168 |
|
|
|
169 |
|
|
else
|
170 |
|
|
-- Here Index_Type'First (and Index_Type'Last) is positive, so we
|
171 |
|
|
-- must test the length indirectly (by working backwards from the
|
172 |
|
|
-- largest possible value of Last), in order to prevent overflow.
|
173 |
|
|
|
174 |
|
|
J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
|
175 |
|
|
|
176 |
|
|
if J < Count_Type'Base (No_Index) then
|
177 |
|
|
raise Constraint_Error with "new length is out of range";
|
178 |
|
|
end if;
|
179 |
|
|
|
180 |
|
|
-- We have determined that the result length would not create a Last
|
181 |
|
|
-- index value outside of the range of Index_Type, so we can now
|
182 |
|
|
-- safely compute its value.
|
183 |
|
|
|
184 |
|
|
Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
|
185 |
|
|
end if;
|
186 |
|
|
|
187 |
|
|
declare
|
188 |
|
|
LE : Elements_Array renames Left.Elements (1 .. LN);
|
189 |
|
|
RE : Elements_Array renames Right.Elements (1 .. RN);
|
190 |
|
|
|
191 |
|
|
begin
|
192 |
|
|
return Vector'(Capacity => N,
|
193 |
|
|
Elements => LE & RE,
|
194 |
|
|
Last => Last,
|
195 |
|
|
others => <>);
|
196 |
|
|
end;
|
197 |
|
|
end "&";
|
198 |
|
|
|
199 |
|
|
function "&" (Left : Vector; Right : Element_Type) return Vector is
|
200 |
|
|
LN : constant Count_Type := Length (Left);
|
201 |
|
|
|
202 |
|
|
begin
|
203 |
|
|
-- We decide that the capacity of the result is the sum of the lengths
|
204 |
|
|
-- of the parameters. We could decide to make it larger, but we have no
|
205 |
|
|
-- basis for knowing how much larger, so we just allocate the minimum
|
206 |
|
|
-- amount of storage.
|
207 |
|
|
|
208 |
|
|
-- We must compute the length of the result vector and its last index,
|
209 |
|
|
-- but in such a way that overflow is avoided. We must satisfy two
|
210 |
|
|
-- constraints: the new length cannot exceed Count_Type'Last, and the
|
211 |
|
|
-- new Last index cannot exceed Index_Type'Last.
|
212 |
|
|
|
213 |
|
|
if LN = Count_Type'Last then
|
214 |
|
|
raise Constraint_Error with "new length is out of range";
|
215 |
|
|
end if;
|
216 |
|
|
|
217 |
|
|
if Left.Last >= Index_Type'Last then
|
218 |
|
|
raise Constraint_Error with "new length is out of range";
|
219 |
|
|
end if;
|
220 |
|
|
|
221 |
|
|
return Vector'(Capacity => LN + 1,
|
222 |
|
|
Elements => Left.Elements (1 .. LN) & Right,
|
223 |
|
|
Last => Left.Last + 1,
|
224 |
|
|
others => <>);
|
225 |
|
|
end "&";
|
226 |
|
|
|
227 |
|
|
function "&" (Left : Element_Type; Right : Vector) return Vector is
|
228 |
|
|
RN : constant Count_Type := Length (Right);
|
229 |
|
|
|
230 |
|
|
begin
|
231 |
|
|
-- We decide that the capacity of the result is the sum of the lengths
|
232 |
|
|
-- of the parameters. We could decide to make it larger, but we have no
|
233 |
|
|
-- basis for knowing how much larger, so we just allocate the minimum
|
234 |
|
|
-- amount of storage.
|
235 |
|
|
|
236 |
|
|
-- We compute the length of the result vector and its last index, but in
|
237 |
|
|
-- such a way that overflow is avoided. We must satisfy two constraints:
|
238 |
|
|
-- the new length cannot exceed Count_Type'Last, and the new Last index
|
239 |
|
|
-- cannot exceed Index_Type'Last.
|
240 |
|
|
|
241 |
|
|
if RN = Count_Type'Last then
|
242 |
|
|
raise Constraint_Error with "new length is out of range";
|
243 |
|
|
end if;
|
244 |
|
|
|
245 |
|
|
if Right.Last >= Index_Type'Last then
|
246 |
|
|
raise Constraint_Error with "new length is out of range";
|
247 |
|
|
end if;
|
248 |
|
|
|
249 |
|
|
return Vector'(Capacity => 1 + RN,
|
250 |
|
|
Elements => Left & Right.Elements (1 .. RN),
|
251 |
|
|
Last => Right.Last + 1,
|
252 |
|
|
others => <>);
|
253 |
|
|
end "&";
|
254 |
|
|
|
255 |
|
|
function "&" (Left, Right : Element_Type) return Vector is
|
256 |
|
|
begin
|
257 |
|
|
-- We decide that the capacity of the result is the sum of the lengths
|
258 |
|
|
-- of the parameters. We could decide to make it larger, but we have no
|
259 |
|
|
-- basis for knowing how much larger, so we just allocate the minimum
|
260 |
|
|
-- amount of storage.
|
261 |
|
|
|
262 |
|
|
-- We must compute the length of the result vector and its last index,
|
263 |
|
|
-- but in such a way that overflow is avoided. We must satisfy two
|
264 |
|
|
-- constraints: the new length cannot exceed Count_Type'Last (here, we
|
265 |
|
|
-- know that that condition is satisfied), and the new Last index cannot
|
266 |
|
|
-- exceed Index_Type'Last.
|
267 |
|
|
|
268 |
|
|
if Index_Type'First >= Index_Type'Last then
|
269 |
|
|
raise Constraint_Error with "new length is out of range";
|
270 |
|
|
end if;
|
271 |
|
|
|
272 |
|
|
return Vector'(Capacity => 2,
|
273 |
|
|
Elements => (Left, Right),
|
274 |
|
|
Last => Index_Type'First + 1,
|
275 |
|
|
others => <>);
|
276 |
|
|
end "&";
|
277 |
|
|
|
278 |
|
|
---------
|
279 |
|
|
-- "=" --
|
280 |
|
|
---------
|
281 |
|
|
|
282 |
|
|
overriding function "=" (Left, Right : Vector) return Boolean is
|
283 |
|
|
begin
|
284 |
|
|
if Left'Address = Right'Address then
|
285 |
|
|
return True;
|
286 |
|
|
end if;
|
287 |
|
|
|
288 |
|
|
if Left.Last /= Right.Last then
|
289 |
|
|
return False;
|
290 |
|
|
end if;
|
291 |
|
|
|
292 |
|
|
for J in Count_Type range 1 .. Left.Length loop
|
293 |
|
|
if Left.Elements (J) /= Right.Elements (J) then
|
294 |
|
|
return False;
|
295 |
|
|
end if;
|
296 |
|
|
end loop;
|
297 |
|
|
|
298 |
|
|
return True;
|
299 |
|
|
end "=";
|
300 |
|
|
|
301 |
|
|
------------
|
302 |
|
|
-- Assign --
|
303 |
|
|
------------
|
304 |
|
|
|
305 |
|
|
procedure Assign (Target : in out Vector; Source : Vector) is
|
306 |
|
|
begin
|
307 |
|
|
if Target'Address = Source'Address then
|
308 |
|
|
return;
|
309 |
|
|
end if;
|
310 |
|
|
|
311 |
|
|
if Target.Capacity < Source.Length then
|
312 |
|
|
raise Capacity_Error -- ???
|
313 |
|
|
with "Target capacity is less than Source length";
|
314 |
|
|
end if;
|
315 |
|
|
|
316 |
|
|
Target.Clear;
|
317 |
|
|
|
318 |
|
|
Target.Elements (1 .. Source.Length) :=
|
319 |
|
|
Source.Elements (1 .. Source.Length);
|
320 |
|
|
|
321 |
|
|
Target.Last := Source.Last;
|
322 |
|
|
end Assign;
|
323 |
|
|
|
324 |
|
|
------------
|
325 |
|
|
-- Append --
|
326 |
|
|
------------
|
327 |
|
|
|
328 |
|
|
procedure Append (Container : in out Vector; New_Item : Vector) is
|
329 |
|
|
begin
|
330 |
|
|
if New_Item.Is_Empty then
|
331 |
|
|
return;
|
332 |
|
|
end if;
|
333 |
|
|
|
334 |
|
|
if Container.Last >= Index_Type'Last then
|
335 |
|
|
raise Constraint_Error with "vector is already at its maximum length";
|
336 |
|
|
end if;
|
337 |
|
|
|
338 |
|
|
Container.Insert (Container.Last + 1, New_Item);
|
339 |
|
|
end Append;
|
340 |
|
|
|
341 |
|
|
procedure Append
|
342 |
|
|
(Container : in out Vector;
|
343 |
|
|
New_Item : Element_Type;
|
344 |
|
|
Count : Count_Type := 1)
|
345 |
|
|
is
|
346 |
|
|
begin
|
347 |
|
|
if Count = 0 then
|
348 |
|
|
return;
|
349 |
|
|
end if;
|
350 |
|
|
|
351 |
|
|
if Container.Last >= Index_Type'Last then
|
352 |
|
|
raise Constraint_Error with "vector is already at its maximum length";
|
353 |
|
|
end if;
|
354 |
|
|
|
355 |
|
|
Container.Insert (Container.Last + 1, New_Item, Count);
|
356 |
|
|
end Append;
|
357 |
|
|
|
358 |
|
|
--------------
|
359 |
|
|
-- Capacity --
|
360 |
|
|
--------------
|
361 |
|
|
|
362 |
|
|
function Capacity (Container : Vector) return Count_Type is
|
363 |
|
|
begin
|
364 |
|
|
return Container.Elements'Length;
|
365 |
|
|
end Capacity;
|
366 |
|
|
|
367 |
|
|
-----------
|
368 |
|
|
-- Clear --
|
369 |
|
|
-----------
|
370 |
|
|
|
371 |
|
|
procedure Clear (Container : in out Vector) is
|
372 |
|
|
begin
|
373 |
|
|
if Container.Busy > 0 then
|
374 |
|
|
raise Program_Error with
|
375 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
376 |
|
|
end if;
|
377 |
|
|
|
378 |
|
|
Container.Last := No_Index;
|
379 |
|
|
end Clear;
|
380 |
|
|
|
381 |
|
|
------------------------
|
382 |
|
|
-- Constant_Reference --
|
383 |
|
|
------------------------
|
384 |
|
|
|
385 |
|
|
function Constant_Reference
|
386 |
|
|
(Container : aliased Vector;
|
387 |
|
|
Position : Cursor) return Constant_Reference_Type
|
388 |
|
|
is
|
389 |
|
|
begin
|
390 |
|
|
if Position.Container = null then
|
391 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
392 |
|
|
end if;
|
393 |
|
|
|
394 |
|
|
if Position.Container /= Container'Unrestricted_Access then
|
395 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
396 |
|
|
end if;
|
397 |
|
|
|
398 |
|
|
if Position.Index > Position.Container.Last then
|
399 |
|
|
raise Constraint_Error with "Position cursor is out of range";
|
400 |
|
|
end if;
|
401 |
|
|
|
402 |
|
|
declare
|
403 |
|
|
A : Elements_Array renames Container.Elements;
|
404 |
|
|
I : constant Count_Type := To_Array_Index (Position.Index);
|
405 |
|
|
begin
|
406 |
|
|
return (Element => A (I)'Access);
|
407 |
|
|
end;
|
408 |
|
|
end Constant_Reference;
|
409 |
|
|
|
410 |
|
|
function Constant_Reference
|
411 |
|
|
(Container : aliased Vector;
|
412 |
|
|
Index : Index_Type) return Constant_Reference_Type
|
413 |
|
|
is
|
414 |
|
|
begin
|
415 |
|
|
if Index > Container.Last then
|
416 |
|
|
raise Constraint_Error with "Index is out of range";
|
417 |
|
|
end if;
|
418 |
|
|
|
419 |
|
|
declare
|
420 |
|
|
A : Elements_Array renames Container.Elements;
|
421 |
|
|
I : constant Count_Type := To_Array_Index (Index);
|
422 |
|
|
begin
|
423 |
|
|
return (Element => A (I)'Access);
|
424 |
|
|
end;
|
425 |
|
|
end Constant_Reference;
|
426 |
|
|
|
427 |
|
|
--------------
|
428 |
|
|
-- Contains --
|
429 |
|
|
--------------
|
430 |
|
|
|
431 |
|
|
function Contains
|
432 |
|
|
(Container : Vector;
|
433 |
|
|
Item : Element_Type) return Boolean
|
434 |
|
|
is
|
435 |
|
|
begin
|
436 |
|
|
return Find_Index (Container, Item) /= No_Index;
|
437 |
|
|
end Contains;
|
438 |
|
|
|
439 |
|
|
----------
|
440 |
|
|
-- Copy --
|
441 |
|
|
----------
|
442 |
|
|
|
443 |
|
|
function Copy
|
444 |
|
|
(Source : Vector;
|
445 |
|
|
Capacity : Count_Type := 0) return Vector
|
446 |
|
|
is
|
447 |
|
|
C : Count_Type;
|
448 |
|
|
|
449 |
|
|
begin
|
450 |
|
|
if Capacity = 0 then
|
451 |
|
|
C := Source.Length;
|
452 |
|
|
|
453 |
|
|
elsif Capacity >= Source.Length then
|
454 |
|
|
C := Capacity;
|
455 |
|
|
|
456 |
|
|
else
|
457 |
|
|
raise Capacity_Error
|
458 |
|
|
with "Requested capacity is less than Source length";
|
459 |
|
|
end if;
|
460 |
|
|
|
461 |
|
|
return Target : Vector (C) do
|
462 |
|
|
Target.Elements (1 .. Source.Length) :=
|
463 |
|
|
Source.Elements (1 .. Source.Length);
|
464 |
|
|
|
465 |
|
|
Target.Last := Source.Last;
|
466 |
|
|
end return;
|
467 |
|
|
end Copy;
|
468 |
|
|
|
469 |
|
|
------------
|
470 |
|
|
-- Delete --
|
471 |
|
|
------------
|
472 |
|
|
|
473 |
|
|
procedure Delete
|
474 |
|
|
(Container : in out Vector;
|
475 |
|
|
Index : Extended_Index;
|
476 |
|
|
Count : Count_Type := 1)
|
477 |
|
|
is
|
478 |
|
|
Old_Last : constant Index_Type'Base := Container.Last;
|
479 |
|
|
Old_Len : constant Count_Type := Container.Length;
|
480 |
|
|
New_Last : Index_Type'Base;
|
481 |
|
|
Count2 : Count_Type'Base; -- count of items from Index to Old_Last
|
482 |
|
|
Off : Count_Type'Base; -- Index expressed as offset from IT'First
|
483 |
|
|
|
484 |
|
|
begin
|
485 |
|
|
-- Delete removes items from the vector, the number of which is the
|
486 |
|
|
-- minimum of the specified Count and the items (if any) that exist from
|
487 |
|
|
-- Index to Container.Last. There are no constraints on the specified
|
488 |
|
|
-- value of Count (it can be larger than what's available at this
|
489 |
|
|
-- position in the vector, for example), but there are constraints on
|
490 |
|
|
-- the allowed values of the Index.
|
491 |
|
|
|
492 |
|
|
-- As a precondition on the generic actual Index_Type, the base type
|
493 |
|
|
-- must include Index_Type'Pred (Index_Type'First); this is the value
|
494 |
|
|
-- that Container.Last assumes when the vector is empty. However, we do
|
495 |
|
|
-- not allow that as the value for Index when specifying which items
|
496 |
|
|
-- should be deleted, so we must manually check. (That the user is
|
497 |
|
|
-- allowed to specify the value at all here is a consequence of the
|
498 |
|
|
-- declaration of the Extended_Index subtype, which includes the values
|
499 |
|
|
-- in the base range that immediately precede and immediately follow the
|
500 |
|
|
-- values in the Index_Type.)
|
501 |
|
|
|
502 |
|
|
if Index < Index_Type'First then
|
503 |
|
|
raise Constraint_Error with "Index is out of range (too small)";
|
504 |
|
|
end if;
|
505 |
|
|
|
506 |
|
|
-- We do allow a value greater than Container.Last to be specified as
|
507 |
|
|
-- the Index, but only if it's immediately greater. This allows the
|
508 |
|
|
-- corner case of deleting no items from the back end of the vector to
|
509 |
|
|
-- be treated as a no-op. (It is assumed that specifying an index value
|
510 |
|
|
-- greater than Last + 1 indicates some deeper flaw in the caller's
|
511 |
|
|
-- algorithm, so that case is treated as a proper error.)
|
512 |
|
|
|
513 |
|
|
if Index > Old_Last then
|
514 |
|
|
if Index > Old_Last + 1 then
|
515 |
|
|
raise Constraint_Error with "Index is out of range (too large)";
|
516 |
|
|
end if;
|
517 |
|
|
|
518 |
|
|
return;
|
519 |
|
|
end if;
|
520 |
|
|
|
521 |
|
|
-- Here and elsewhere we treat deleting 0 items from the container as a
|
522 |
|
|
-- no-op, even when the container is busy, so we simply return.
|
523 |
|
|
|
524 |
|
|
if Count = 0 then
|
525 |
|
|
return;
|
526 |
|
|
end if;
|
527 |
|
|
|
528 |
|
|
-- The tampering bits exist to prevent an item from being deleted (or
|
529 |
|
|
-- otherwise harmfully manipulated) while it is being visited. Query,
|
530 |
|
|
-- Update, and Iterate increment the busy count on entry, and decrement
|
531 |
|
|
-- the count on exit. Delete checks the count to determine whether it is
|
532 |
|
|
-- being called while the associated callback procedure is executing.
|
533 |
|
|
|
534 |
|
|
if Container.Busy > 0 then
|
535 |
|
|
raise Program_Error with
|
536 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
537 |
|
|
end if;
|
538 |
|
|
|
539 |
|
|
-- We first calculate what's available for deletion starting at
|
540 |
|
|
-- Index. Here and elsewhere we use the wider of Index_Type'Base and
|
541 |
|
|
-- Count_Type'Base as the type for intermediate values. (See function
|
542 |
|
|
-- Length for more information.)
|
543 |
|
|
|
544 |
|
|
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
|
545 |
|
|
Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
|
546 |
|
|
|
547 |
|
|
else
|
548 |
|
|
Count2 := Count_Type'Base (Old_Last - Index + 1);
|
549 |
|
|
end if;
|
550 |
|
|
|
551 |
|
|
-- If more elements are requested (Count) for deletion than are
|
552 |
|
|
-- available (Count2) for deletion beginning at Index, then everything
|
553 |
|
|
-- from Index is deleted. There are no elements to slide down, and so
|
554 |
|
|
-- all we need to do is set the value of Container.Last.
|
555 |
|
|
|
556 |
|
|
if Count >= Count2 then
|
557 |
|
|
Container.Last := Index - 1;
|
558 |
|
|
return;
|
559 |
|
|
end if;
|
560 |
|
|
|
561 |
|
|
-- There are some elements aren't being deleted (the requested count was
|
562 |
|
|
-- less than the available count), so we must slide them down to
|
563 |
|
|
-- Index. We first calculate the index values of the respective array
|
564 |
|
|
-- slices, using the wider of Index_Type'Base and Count_Type'Base as the
|
565 |
|
|
-- type for intermediate calculations.
|
566 |
|
|
|
567 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
568 |
|
|
Off := Count_Type'Base (Index - Index_Type'First);
|
569 |
|
|
New_Last := Old_Last - Index_Type'Base (Count);
|
570 |
|
|
|
571 |
|
|
else
|
572 |
|
|
Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
|
573 |
|
|
New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
|
574 |
|
|
end if;
|
575 |
|
|
|
576 |
|
|
-- The array index values for each slice have already been determined,
|
577 |
|
|
-- so we just slide down to Index the elements that weren't deleted.
|
578 |
|
|
|
579 |
|
|
declare
|
580 |
|
|
EA : Elements_Array renames Container.Elements;
|
581 |
|
|
Idx : constant Count_Type := EA'First + Off;
|
582 |
|
|
|
583 |
|
|
begin
|
584 |
|
|
EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
|
585 |
|
|
Container.Last := New_Last;
|
586 |
|
|
end;
|
587 |
|
|
end Delete;
|
588 |
|
|
|
589 |
|
|
procedure Delete
|
590 |
|
|
(Container : in out Vector;
|
591 |
|
|
Position : in out Cursor;
|
592 |
|
|
Count : Count_Type := 1)
|
593 |
|
|
is
|
594 |
|
|
pragma Warnings (Off, Position);
|
595 |
|
|
|
596 |
|
|
begin
|
597 |
|
|
if Position.Container = null then
|
598 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
599 |
|
|
end if;
|
600 |
|
|
|
601 |
|
|
if Position.Container /= Container'Unrestricted_Access then
|
602 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
603 |
|
|
end if;
|
604 |
|
|
|
605 |
|
|
if Position.Index > Container.Last then
|
606 |
|
|
raise Program_Error with "Position index is out of range";
|
607 |
|
|
end if;
|
608 |
|
|
|
609 |
|
|
Delete (Container, Position.Index, Count);
|
610 |
|
|
Position := No_Element;
|
611 |
|
|
end Delete;
|
612 |
|
|
|
613 |
|
|
------------------
|
614 |
|
|
-- Delete_First --
|
615 |
|
|
------------------
|
616 |
|
|
|
617 |
|
|
procedure Delete_First
|
618 |
|
|
(Container : in out Vector;
|
619 |
|
|
Count : Count_Type := 1)
|
620 |
|
|
is
|
621 |
|
|
begin
|
622 |
|
|
if Count = 0 then
|
623 |
|
|
return;
|
624 |
|
|
end if;
|
625 |
|
|
|
626 |
|
|
if Count >= Length (Container) then
|
627 |
|
|
Clear (Container);
|
628 |
|
|
return;
|
629 |
|
|
end if;
|
630 |
|
|
|
631 |
|
|
Delete (Container, Index_Type'First, Count);
|
632 |
|
|
end Delete_First;
|
633 |
|
|
|
634 |
|
|
-----------------
|
635 |
|
|
-- Delete_Last --
|
636 |
|
|
-----------------
|
637 |
|
|
|
638 |
|
|
procedure Delete_Last
|
639 |
|
|
(Container : in out Vector;
|
640 |
|
|
Count : Count_Type := 1)
|
641 |
|
|
is
|
642 |
|
|
begin
|
643 |
|
|
-- It is not permitted to delete items while the container is busy (for
|
644 |
|
|
-- example, we're in the middle of a passive iteration). However, we
|
645 |
|
|
-- always treat deleting 0 items as a no-op, even when we're busy, so we
|
646 |
|
|
-- simply return without checking.
|
647 |
|
|
|
648 |
|
|
if Count = 0 then
|
649 |
|
|
return;
|
650 |
|
|
end if;
|
651 |
|
|
|
652 |
|
|
-- The tampering bits exist to prevent an item from being deleted (or
|
653 |
|
|
-- otherwise harmfully manipulated) while it is being visited. Query,
|
654 |
|
|
-- Update, and Iterate increment the busy count on entry, and decrement
|
655 |
|
|
-- the count on exit. Delete_Last checks the count to determine whether
|
656 |
|
|
-- it is being called while the associated callback procedure is
|
657 |
|
|
-- executing.
|
658 |
|
|
|
659 |
|
|
if Container.Busy > 0 then
|
660 |
|
|
raise Program_Error with
|
661 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
662 |
|
|
end if;
|
663 |
|
|
|
664 |
|
|
-- There is no restriction on how large Count can be when deleting
|
665 |
|
|
-- items. If it is equal or greater than the current length, then this
|
666 |
|
|
-- is equivalent to clearing the vector. (In particular, there's no need
|
667 |
|
|
-- for us to actually calculate the new value for Last.)
|
668 |
|
|
|
669 |
|
|
-- If the requested count is less than the current length, then we must
|
670 |
|
|
-- calculate the new value for Last. For the type we use the widest of
|
671 |
|
|
-- Index_Type'Base and Count_Type'Base for the intermediate values of
|
672 |
|
|
-- our calculation. (See the comments in Length for more information.)
|
673 |
|
|
|
674 |
|
|
if Count >= Container.Length then
|
675 |
|
|
Container.Last := No_Index;
|
676 |
|
|
|
677 |
|
|
elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
678 |
|
|
Container.Last := Container.Last - Index_Type'Base (Count);
|
679 |
|
|
|
680 |
|
|
else
|
681 |
|
|
Container.Last :=
|
682 |
|
|
Index_Type'Base (Count_Type'Base (Container.Last) - Count);
|
683 |
|
|
end if;
|
684 |
|
|
end Delete_Last;
|
685 |
|
|
|
686 |
|
|
-------------
|
687 |
|
|
-- Element --
|
688 |
|
|
-------------
|
689 |
|
|
|
690 |
|
|
function Element
|
691 |
|
|
(Container : Vector;
|
692 |
|
|
Index : Index_Type) return Element_Type
|
693 |
|
|
is
|
694 |
|
|
begin
|
695 |
|
|
if Index > Container.Last then
|
696 |
|
|
raise Constraint_Error with "Index is out of range";
|
697 |
|
|
else
|
698 |
|
|
return Container.Elements (To_Array_Index (Index));
|
699 |
|
|
end if;
|
700 |
|
|
end Element;
|
701 |
|
|
|
702 |
|
|
function Element (Position : Cursor) return Element_Type is
|
703 |
|
|
begin
|
704 |
|
|
if Position.Container = null then
|
705 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
706 |
|
|
else
|
707 |
|
|
return Position.Container.Element (Position.Index);
|
708 |
|
|
end if;
|
709 |
|
|
end Element;
|
710 |
|
|
|
711 |
|
|
--------------
|
712 |
|
|
-- Finalize --
|
713 |
|
|
--------------
|
714 |
|
|
|
715 |
|
|
procedure Finalize (Object : in out Iterator) is
|
716 |
|
|
B : Natural renames Object.Container.Busy;
|
717 |
|
|
begin
|
718 |
|
|
B := B - 1;
|
719 |
|
|
end Finalize;
|
720 |
|
|
|
721 |
|
|
----------
|
722 |
|
|
-- Find --
|
723 |
|
|
----------
|
724 |
|
|
|
725 |
|
|
function Find
|
726 |
|
|
(Container : Vector;
|
727 |
|
|
Item : Element_Type;
|
728 |
|
|
Position : Cursor := No_Element) return Cursor
|
729 |
|
|
is
|
730 |
|
|
begin
|
731 |
|
|
if Position.Container /= null then
|
732 |
|
|
if Position.Container /= Container'Unrestricted_Access then
|
733 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
734 |
|
|
end if;
|
735 |
|
|
|
736 |
|
|
if Position.Index > Container.Last then
|
737 |
|
|
raise Program_Error with "Position index is out of range";
|
738 |
|
|
end if;
|
739 |
|
|
end if;
|
740 |
|
|
|
741 |
|
|
for J in Position.Index .. Container.Last loop
|
742 |
|
|
if Container.Elements (To_Array_Index (J)) = Item then
|
743 |
|
|
return (Container'Unrestricted_Access, J);
|
744 |
|
|
end if;
|
745 |
|
|
end loop;
|
746 |
|
|
|
747 |
|
|
return No_Element;
|
748 |
|
|
end Find;
|
749 |
|
|
|
750 |
|
|
----------------
|
751 |
|
|
-- Find_Index --
|
752 |
|
|
----------------
|
753 |
|
|
|
754 |
|
|
function Find_Index
|
755 |
|
|
(Container : Vector;
|
756 |
|
|
Item : Element_Type;
|
757 |
|
|
Index : Index_Type := Index_Type'First) return Extended_Index
|
758 |
|
|
is
|
759 |
|
|
begin
|
760 |
|
|
for Indx in Index .. Container.Last loop
|
761 |
|
|
if Container.Elements (To_Array_Index (Indx)) = Item then
|
762 |
|
|
return Indx;
|
763 |
|
|
end if;
|
764 |
|
|
end loop;
|
765 |
|
|
|
766 |
|
|
return No_Index;
|
767 |
|
|
end Find_Index;
|
768 |
|
|
|
769 |
|
|
-----------
|
770 |
|
|
-- First --
|
771 |
|
|
-----------
|
772 |
|
|
|
773 |
|
|
function First (Container : Vector) return Cursor is
|
774 |
|
|
begin
|
775 |
|
|
if Is_Empty (Container) then
|
776 |
|
|
return No_Element;
|
777 |
|
|
else
|
778 |
|
|
return (Container'Unrestricted_Access, Index_Type'First);
|
779 |
|
|
end if;
|
780 |
|
|
end First;
|
781 |
|
|
|
782 |
|
|
function First (Object : Iterator) return Cursor is
|
783 |
|
|
begin
|
784 |
|
|
-- The value of the iterator object's Index component influences the
|
785 |
|
|
-- behavior of the First (and Last) selector function.
|
786 |
|
|
|
787 |
|
|
-- When the Index component is No_Index, this means the iterator
|
788 |
|
|
-- object was constructed without a start expression, in which case the
|
789 |
|
|
-- (forward) iteration starts from the (logical) beginning of the entire
|
790 |
|
|
-- sequence of items (corresponding to Container.First, for a forward
|
791 |
|
|
-- iterator).
|
792 |
|
|
|
793 |
|
|
-- Otherwise, this is iteration over a partial sequence of items.
|
794 |
|
|
-- When the Index component isn't No_Index, the iterator object was
|
795 |
|
|
-- constructed with a start expression, that specifies the position
|
796 |
|
|
-- from which the (forward) partial iteration begins.
|
797 |
|
|
|
798 |
|
|
if Object.Index = No_Index then
|
799 |
|
|
return First (Object.Container.all);
|
800 |
|
|
else
|
801 |
|
|
return Cursor'(Object.Container, Object.Index);
|
802 |
|
|
end if;
|
803 |
|
|
end First;
|
804 |
|
|
|
805 |
|
|
-------------------
|
806 |
|
|
-- First_Element --
|
807 |
|
|
-------------------
|
808 |
|
|
|
809 |
|
|
function First_Element (Container : Vector) return Element_Type is
|
810 |
|
|
begin
|
811 |
|
|
if Container.Last = No_Index then
|
812 |
|
|
raise Constraint_Error with "Container is empty";
|
813 |
|
|
else
|
814 |
|
|
return Container.Elements (To_Array_Index (Index_Type'First));
|
815 |
|
|
end if;
|
816 |
|
|
end First_Element;
|
817 |
|
|
|
818 |
|
|
-----------------
|
819 |
|
|
-- First_Index --
|
820 |
|
|
-----------------
|
821 |
|
|
|
822 |
|
|
function First_Index (Container : Vector) return Index_Type is
|
823 |
|
|
pragma Unreferenced (Container);
|
824 |
|
|
begin
|
825 |
|
|
return Index_Type'First;
|
826 |
|
|
end First_Index;
|
827 |
|
|
|
828 |
|
|
---------------------
|
829 |
|
|
-- Generic_Sorting --
|
830 |
|
|
---------------------
|
831 |
|
|
|
832 |
|
|
package body Generic_Sorting is
|
833 |
|
|
|
834 |
|
|
---------------
|
835 |
|
|
-- Is_Sorted --
|
836 |
|
|
---------------
|
837 |
|
|
|
838 |
|
|
function Is_Sorted (Container : Vector) return Boolean is
|
839 |
|
|
begin
|
840 |
|
|
if Container.Last <= Index_Type'First then
|
841 |
|
|
return True;
|
842 |
|
|
end if;
|
843 |
|
|
|
844 |
|
|
declare
|
845 |
|
|
EA : Elements_Array renames Container.Elements;
|
846 |
|
|
begin
|
847 |
|
|
for J in 1 .. Container.Length - 1 loop
|
848 |
|
|
if EA (J + 1) < EA (J) then
|
849 |
|
|
return False;
|
850 |
|
|
end if;
|
851 |
|
|
end loop;
|
852 |
|
|
end;
|
853 |
|
|
|
854 |
|
|
return True;
|
855 |
|
|
end Is_Sorted;
|
856 |
|
|
|
857 |
|
|
-----------
|
858 |
|
|
-- Merge --
|
859 |
|
|
-----------
|
860 |
|
|
|
861 |
|
|
procedure Merge (Target, Source : in out Vector) is
|
862 |
|
|
I, J : Count_Type;
|
863 |
|
|
|
864 |
|
|
begin
|
865 |
|
|
|
866 |
|
|
-- The semantics of Merge changed slightly per AI05-0021. It was
|
867 |
|
|
-- originally the case that if Target and Source denoted the same
|
868 |
|
|
-- container object, then the GNAT implementation of Merge did
|
869 |
|
|
-- nothing. However, it was argued that RM05 did not precisely
|
870 |
|
|
-- specify the semantics for this corner case. The decision of the
|
871 |
|
|
-- ARG was that if Target and Source denote the same non-empty
|
872 |
|
|
-- container object, then Program_Error is raised.
|
873 |
|
|
|
874 |
|
|
if Source.Is_Empty then
|
875 |
|
|
return;
|
876 |
|
|
end if;
|
877 |
|
|
|
878 |
|
|
if Target'Address = Source'Address then
|
879 |
|
|
raise Program_Error with
|
880 |
|
|
"Target and Source denote same non-empty container";
|
881 |
|
|
end if;
|
882 |
|
|
|
883 |
|
|
if Target.Is_Empty then
|
884 |
|
|
Move (Target => Target, Source => Source);
|
885 |
|
|
return;
|
886 |
|
|
end if;
|
887 |
|
|
|
888 |
|
|
if Source.Busy > 0 then
|
889 |
|
|
raise Program_Error with
|
890 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
891 |
|
|
end if;
|
892 |
|
|
|
893 |
|
|
I := Target.Length;
|
894 |
|
|
Target.Set_Length (I + Source.Length);
|
895 |
|
|
|
896 |
|
|
declare
|
897 |
|
|
TA : Elements_Array renames Target.Elements;
|
898 |
|
|
SA : Elements_Array renames Source.Elements;
|
899 |
|
|
|
900 |
|
|
begin
|
901 |
|
|
J := Target.Length;
|
902 |
|
|
while not Source.Is_Empty loop
|
903 |
|
|
pragma Assert (Source.Length <= 1
|
904 |
|
|
or else not (SA (Source.Length) <
|
905 |
|
|
SA (Source.Length - 1)));
|
906 |
|
|
|
907 |
|
|
if I = 0 then
|
908 |
|
|
TA (1 .. J) := SA (1 .. Source.Length);
|
909 |
|
|
Source.Last := No_Index;
|
910 |
|
|
return;
|
911 |
|
|
end if;
|
912 |
|
|
|
913 |
|
|
pragma Assert (I <= 1
|
914 |
|
|
or else not (TA (I) < TA (I - 1)));
|
915 |
|
|
|
916 |
|
|
if SA (Source.Length) < TA (I) then
|
917 |
|
|
TA (J) := TA (I);
|
918 |
|
|
I := I - 1;
|
919 |
|
|
|
920 |
|
|
else
|
921 |
|
|
TA (J) := SA (Source.Length);
|
922 |
|
|
Source.Last := Source.Last - 1;
|
923 |
|
|
end if;
|
924 |
|
|
|
925 |
|
|
J := J - 1;
|
926 |
|
|
end loop;
|
927 |
|
|
end;
|
928 |
|
|
end Merge;
|
929 |
|
|
|
930 |
|
|
----------
|
931 |
|
|
-- Sort --
|
932 |
|
|
----------
|
933 |
|
|
|
934 |
|
|
procedure Sort (Container : in out Vector) is
|
935 |
|
|
procedure Sort is
|
936 |
|
|
new Generic_Array_Sort
|
937 |
|
|
(Index_Type => Count_Type,
|
938 |
|
|
Element_Type => Element_Type,
|
939 |
|
|
Array_Type => Elements_Array,
|
940 |
|
|
"<" => "<");
|
941 |
|
|
|
942 |
|
|
begin
|
943 |
|
|
if Container.Last <= Index_Type'First then
|
944 |
|
|
return;
|
945 |
|
|
end if;
|
946 |
|
|
|
947 |
|
|
-- The exception behavior for the vector container must match that
|
948 |
|
|
-- for the list container, so we check for cursor tampering here
|
949 |
|
|
-- (which will catch more things) instead of for element tampering
|
950 |
|
|
-- (which will catch fewer things). It's true that the elements of
|
951 |
|
|
-- this vector container could be safely moved around while (say) an
|
952 |
|
|
-- iteration is taking place (iteration only increments the busy
|
953 |
|
|
-- counter), and so technically all we would need here is a test for
|
954 |
|
|
-- element tampering (indicated by the lock counter), that's simply
|
955 |
|
|
-- an artifact of our array-based implementation. Logically Sort
|
956 |
|
|
-- requires a check for cursor tampering.
|
957 |
|
|
|
958 |
|
|
if Container.Busy > 0 then
|
959 |
|
|
raise Program_Error with
|
960 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
961 |
|
|
end if;
|
962 |
|
|
|
963 |
|
|
Sort (Container.Elements (1 .. Container.Length));
|
964 |
|
|
end Sort;
|
965 |
|
|
|
966 |
|
|
end Generic_Sorting;
|
967 |
|
|
|
968 |
|
|
-----------------
|
969 |
|
|
-- Has_Element --
|
970 |
|
|
-----------------
|
971 |
|
|
|
972 |
|
|
function Has_Element (Position : Cursor) return Boolean is
|
973 |
|
|
begin
|
974 |
|
|
if Position.Container = null then
|
975 |
|
|
return False;
|
976 |
|
|
end if;
|
977 |
|
|
|
978 |
|
|
return Position.Index <= Position.Container.Last;
|
979 |
|
|
end Has_Element;
|
980 |
|
|
|
981 |
|
|
------------
|
982 |
|
|
-- Insert --
|
983 |
|
|
------------
|
984 |
|
|
|
985 |
|
|
procedure Insert
|
986 |
|
|
(Container : in out Vector;
|
987 |
|
|
Before : Extended_Index;
|
988 |
|
|
New_Item : Element_Type;
|
989 |
|
|
Count : Count_Type := 1)
|
990 |
|
|
is
|
991 |
|
|
EA : Elements_Array renames Container.Elements;
|
992 |
|
|
Old_Length : constant Count_Type := Container.Length;
|
993 |
|
|
|
994 |
|
|
Max_Length : Count_Type'Base; -- determined from range of Index_Type
|
995 |
|
|
New_Length : Count_Type'Base; -- sum of current length and Count
|
996 |
|
|
|
997 |
|
|
Index : Index_Type'Base; -- scratch for intermediate values
|
998 |
|
|
J : Count_Type'Base; -- scratch
|
999 |
|
|
|
1000 |
|
|
begin
|
1001 |
|
|
-- As a precondition on the generic actual Index_Type, the base type
|
1002 |
|
|
-- must include Index_Type'Pred (Index_Type'First); this is the value
|
1003 |
|
|
-- that Container.Last assumes when the vector is empty. However, we do
|
1004 |
|
|
-- not allow that as the value for Index when specifying where the new
|
1005 |
|
|
-- items should be inserted, so we must manually check. (That the user
|
1006 |
|
|
-- is allowed to specify the value at all here is a consequence of the
|
1007 |
|
|
-- declaration of the Extended_Index subtype, which includes the values
|
1008 |
|
|
-- in the base range that immediately precede and immediately follow the
|
1009 |
|
|
-- values in the Index_Type.)
|
1010 |
|
|
|
1011 |
|
|
if Before < Index_Type'First then
|
1012 |
|
|
raise Constraint_Error with
|
1013 |
|
|
"Before index is out of range (too small)";
|
1014 |
|
|
end if;
|
1015 |
|
|
|
1016 |
|
|
-- We do allow a value greater than Container.Last to be specified as
|
1017 |
|
|
-- the Index, but only if it's immediately greater. This allows for the
|
1018 |
|
|
-- case of appending items to the back end of the vector. (It is assumed
|
1019 |
|
|
-- that specifying an index value greater than Last + 1 indicates some
|
1020 |
|
|
-- deeper flaw in the caller's algorithm, so that case is treated as a
|
1021 |
|
|
-- proper error.)
|
1022 |
|
|
|
1023 |
|
|
if Before > Container.Last
|
1024 |
|
|
and then Before > Container.Last + 1
|
1025 |
|
|
then
|
1026 |
|
|
raise Constraint_Error with
|
1027 |
|
|
"Before index is out of range (too large)";
|
1028 |
|
|
end if;
|
1029 |
|
|
|
1030 |
|
|
-- We treat inserting 0 items into the container as a no-op, even when
|
1031 |
|
|
-- the container is busy, so we simply return.
|
1032 |
|
|
|
1033 |
|
|
if Count = 0 then
|
1034 |
|
|
return;
|
1035 |
|
|
end if;
|
1036 |
|
|
|
1037 |
|
|
-- There are two constraints we need to satisfy. The first constraint is
|
1038 |
|
|
-- that a container cannot have more than Count_Type'Last elements, so
|
1039 |
|
|
-- we must check the sum of the current length and the insertion
|
1040 |
|
|
-- count. Note that we cannot simply add these values, because of the
|
1041 |
|
|
-- possibility of overflow.
|
1042 |
|
|
|
1043 |
|
|
if Old_Length > Count_Type'Last - Count then
|
1044 |
|
|
raise Constraint_Error with "Count is out of range";
|
1045 |
|
|
end if;
|
1046 |
|
|
|
1047 |
|
|
-- It is now safe compute the length of the new vector, without fear of
|
1048 |
|
|
-- overflow.
|
1049 |
|
|
|
1050 |
|
|
New_Length := Old_Length + Count;
|
1051 |
|
|
|
1052 |
|
|
-- The second constraint is that the new Last index value cannot exceed
|
1053 |
|
|
-- Index_Type'Last. In each branch below, we calculate the maximum
|
1054 |
|
|
-- length (computed from the range of values in Index_Type), and then
|
1055 |
|
|
-- compare the new length to the maximum length. If the new length is
|
1056 |
|
|
-- acceptable, then we compute the new last index from that.
|
1057 |
|
|
|
1058 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
1059 |
|
|
-- We have to handle the case when there might be more values in the
|
1060 |
|
|
-- range of Index_Type than in the range of Count_Type.
|
1061 |
|
|
|
1062 |
|
|
if Index_Type'First <= 0 then
|
1063 |
|
|
-- We know that No_Index (the same as Index_Type'First - 1) is
|
1064 |
|
|
-- less than 0, so it is safe to compute the following sum without
|
1065 |
|
|
-- fear of overflow.
|
1066 |
|
|
|
1067 |
|
|
Index := No_Index + Index_Type'Base (Count_Type'Last);
|
1068 |
|
|
|
1069 |
|
|
if Index <= Index_Type'Last then
|
1070 |
|
|
-- We have determined that range of Index_Type has at least as
|
1071 |
|
|
-- many values as in Count_Type, so Count_Type'Last is the
|
1072 |
|
|
-- maximum number of items that are allowed.
|
1073 |
|
|
|
1074 |
|
|
Max_Length := Count_Type'Last;
|
1075 |
|
|
|
1076 |
|
|
else
|
1077 |
|
|
-- The range of Index_Type has fewer values than in Count_Type,
|
1078 |
|
|
-- so the maximum number of items is computed from the range of
|
1079 |
|
|
-- the Index_Type.
|
1080 |
|
|
|
1081 |
|
|
Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
1082 |
|
|
end if;
|
1083 |
|
|
|
1084 |
|
|
else
|
1085 |
|
|
-- No_Index is equal or greater than 0, so we can safely compute
|
1086 |
|
|
-- the difference without fear of overflow (which we would have to
|
1087 |
|
|
-- worry about if No_Index were less than 0, but that case is
|
1088 |
|
|
-- handled above).
|
1089 |
|
|
|
1090 |
|
|
Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
1091 |
|
|
end if;
|
1092 |
|
|
|
1093 |
|
|
elsif Index_Type'First <= 0 then
|
1094 |
|
|
-- We know that No_Index (the same as Index_Type'First - 1) is less
|
1095 |
|
|
-- than 0, so it is safe to compute the following sum without fear of
|
1096 |
|
|
-- overflow.
|
1097 |
|
|
|
1098 |
|
|
J := Count_Type'Base (No_Index) + Count_Type'Last;
|
1099 |
|
|
|
1100 |
|
|
if J <= Count_Type'Base (Index_Type'Last) then
|
1101 |
|
|
-- We have determined that range of Index_Type has at least as
|
1102 |
|
|
-- many values as in Count_Type, so Count_Type'Last is the maximum
|
1103 |
|
|
-- number of items that are allowed.
|
1104 |
|
|
|
1105 |
|
|
Max_Length := Count_Type'Last;
|
1106 |
|
|
|
1107 |
|
|
else
|
1108 |
|
|
-- The range of Index_Type has fewer values than Count_Type does,
|
1109 |
|
|
-- so the maximum number of items is computed from the range of
|
1110 |
|
|
-- the Index_Type.
|
1111 |
|
|
|
1112 |
|
|
Max_Length :=
|
1113 |
|
|
Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
1114 |
|
|
end if;
|
1115 |
|
|
|
1116 |
|
|
else
|
1117 |
|
|
-- No_Index is equal or greater than 0, so we can safely compute the
|
1118 |
|
|
-- difference without fear of overflow (which we would have to worry
|
1119 |
|
|
-- about if No_Index were less than 0, but that case is handled
|
1120 |
|
|
-- above).
|
1121 |
|
|
|
1122 |
|
|
Max_Length :=
|
1123 |
|
|
Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
1124 |
|
|
end if;
|
1125 |
|
|
|
1126 |
|
|
-- We have just computed the maximum length (number of items). We must
|
1127 |
|
|
-- now compare the requested length to the maximum length, as we do not
|
1128 |
|
|
-- allow a vector expand beyond the maximum (because that would create
|
1129 |
|
|
-- an internal array with a last index value greater than
|
1130 |
|
|
-- Index_Type'Last, with no way to index those elements).
|
1131 |
|
|
|
1132 |
|
|
if New_Length > Max_Length then
|
1133 |
|
|
raise Constraint_Error with "Count is out of range";
|
1134 |
|
|
end if;
|
1135 |
|
|
|
1136 |
|
|
-- The tampering bits exist to prevent an item from being harmfully
|
1137 |
|
|
-- manipulated while it is being visited. Query, Update, and Iterate
|
1138 |
|
|
-- increment the busy count on entry, and decrement the count on
|
1139 |
|
|
-- exit. Insert checks the count to determine whether it is being called
|
1140 |
|
|
-- while the associated callback procedure is executing.
|
1141 |
|
|
|
1142 |
|
|
if Container.Busy > 0 then
|
1143 |
|
|
raise Program_Error with
|
1144 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
1145 |
|
|
end if;
|
1146 |
|
|
|
1147 |
|
|
if New_Length > Container.Capacity then
|
1148 |
|
|
raise Capacity_Error with "New length is larger than capacity";
|
1149 |
|
|
end if;
|
1150 |
|
|
|
1151 |
|
|
J := To_Array_Index (Before);
|
1152 |
|
|
|
1153 |
|
|
if Before > Container.Last then
|
1154 |
|
|
-- The new items are being appended to the vector, so no
|
1155 |
|
|
-- sliding of existing elements is required.
|
1156 |
|
|
|
1157 |
|
|
EA (J .. New_Length) := (others => New_Item);
|
1158 |
|
|
|
1159 |
|
|
else
|
1160 |
|
|
-- The new items are being inserted before some existing
|
1161 |
|
|
-- elements, so we must slide the existing elements up to their
|
1162 |
|
|
-- new home.
|
1163 |
|
|
|
1164 |
|
|
EA (J + Count .. New_Length) := EA (J .. Old_Length);
|
1165 |
|
|
EA (J .. J + Count - 1) := (others => New_Item);
|
1166 |
|
|
end if;
|
1167 |
|
|
|
1168 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
1169 |
|
|
Container.Last := No_Index + Index_Type'Base (New_Length);
|
1170 |
|
|
|
1171 |
|
|
else
|
1172 |
|
|
Container.Last :=
|
1173 |
|
|
Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
|
1174 |
|
|
end if;
|
1175 |
|
|
end Insert;
|
1176 |
|
|
|
1177 |
|
|
procedure Insert
|
1178 |
|
|
(Container : in out Vector;
|
1179 |
|
|
Before : Extended_Index;
|
1180 |
|
|
New_Item : Vector)
|
1181 |
|
|
is
|
1182 |
|
|
N : constant Count_Type := Length (New_Item);
|
1183 |
|
|
B : Count_Type; -- index Before converted to Count_Type
|
1184 |
|
|
|
1185 |
|
|
begin
|
1186 |
|
|
-- Use Insert_Space to create the "hole" (the destination slice) into
|
1187 |
|
|
-- which we copy the source items.
|
1188 |
|
|
|
1189 |
|
|
Insert_Space (Container, Before, Count => N);
|
1190 |
|
|
|
1191 |
|
|
if N = 0 then
|
1192 |
|
|
-- There's nothing else to do here (vetting of parameters was
|
1193 |
|
|
-- performed already in Insert_Space), so we simply return.
|
1194 |
|
|
|
1195 |
|
|
return;
|
1196 |
|
|
end if;
|
1197 |
|
|
|
1198 |
|
|
B := To_Array_Index (Before);
|
1199 |
|
|
|
1200 |
|
|
if Container'Address /= New_Item'Address then
|
1201 |
|
|
-- This is the simple case. New_Item denotes an object different
|
1202 |
|
|
-- from Container, so there's nothing special we need to do to copy
|
1203 |
|
|
-- the source items to their destination, because all of the source
|
1204 |
|
|
-- items are contiguous.
|
1205 |
|
|
|
1206 |
|
|
Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N);
|
1207 |
|
|
return;
|
1208 |
|
|
end if;
|
1209 |
|
|
|
1210 |
|
|
-- We refer to array index value Before + N - 1 as J. This is the last
|
1211 |
|
|
-- index value of the destination slice.
|
1212 |
|
|
|
1213 |
|
|
-- New_Item denotes the same object as Container, so an insertion has
|
1214 |
|
|
-- potentially split the source items. The destination is always the
|
1215 |
|
|
-- range [Before, J], but the source is [Index_Type'First, Before) and
|
1216 |
|
|
-- (J, Container.Last]. We perform the copy in two steps, using each of
|
1217 |
|
|
-- the two slices of the source items.
|
1218 |
|
|
|
1219 |
|
|
declare
|
1220 |
|
|
subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1;
|
1221 |
|
|
|
1222 |
|
|
Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
|
1223 |
|
|
|
1224 |
|
|
begin
|
1225 |
|
|
-- We first copy the source items that precede the space we
|
1226 |
|
|
-- inserted. (If Before equals Index_Type'First, then this first
|
1227 |
|
|
-- source slice will be empty, which is harmless.)
|
1228 |
|
|
|
1229 |
|
|
Container.Elements (B .. B + Src'Length - 1) := Src;
|
1230 |
|
|
end;
|
1231 |
|
|
|
1232 |
|
|
declare
|
1233 |
|
|
subtype Src_Index_Subtype is Count_Type'Base range
|
1234 |
|
|
B + N .. Container.Length;
|
1235 |
|
|
|
1236 |
|
|
Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
|
1237 |
|
|
|
1238 |
|
|
begin
|
1239 |
|
|
-- We next copy the source items that follow the space we inserted.
|
1240 |
|
|
|
1241 |
|
|
Container.Elements (B + N - Src'Length .. B + N - 1) := Src;
|
1242 |
|
|
end;
|
1243 |
|
|
end Insert;
|
1244 |
|
|
|
1245 |
|
|
procedure Insert
|
1246 |
|
|
(Container : in out Vector;
|
1247 |
|
|
Before : Cursor;
|
1248 |
|
|
New_Item : Vector)
|
1249 |
|
|
is
|
1250 |
|
|
Index : Index_Type'Base;
|
1251 |
|
|
|
1252 |
|
|
begin
|
1253 |
|
|
if Before.Container /= null
|
1254 |
|
|
and then Before.Container /= Container'Unchecked_Access
|
1255 |
|
|
then
|
1256 |
|
|
raise Program_Error with "Before cursor denotes wrong container";
|
1257 |
|
|
end if;
|
1258 |
|
|
|
1259 |
|
|
if Is_Empty (New_Item) then
|
1260 |
|
|
return;
|
1261 |
|
|
end if;
|
1262 |
|
|
|
1263 |
|
|
if Before.Container = null
|
1264 |
|
|
or else Before.Index > Container.Last
|
1265 |
|
|
then
|
1266 |
|
|
if Container.Last = Index_Type'Last then
|
1267 |
|
|
raise Constraint_Error with
|
1268 |
|
|
"vector is already at its maximum length";
|
1269 |
|
|
end if;
|
1270 |
|
|
|
1271 |
|
|
Index := Container.Last + 1;
|
1272 |
|
|
|
1273 |
|
|
else
|
1274 |
|
|
Index := Before.Index;
|
1275 |
|
|
end if;
|
1276 |
|
|
|
1277 |
|
|
Insert (Container, Index, New_Item);
|
1278 |
|
|
end Insert;
|
1279 |
|
|
|
1280 |
|
|
procedure Insert
|
1281 |
|
|
(Container : in out Vector;
|
1282 |
|
|
Before : Cursor;
|
1283 |
|
|
New_Item : Vector;
|
1284 |
|
|
Position : out Cursor)
|
1285 |
|
|
is
|
1286 |
|
|
Index : Index_Type'Base;
|
1287 |
|
|
|
1288 |
|
|
begin
|
1289 |
|
|
if Before.Container /= null
|
1290 |
|
|
and then Before.Container /= Container'Unchecked_Access
|
1291 |
|
|
then
|
1292 |
|
|
raise Program_Error with "Before cursor denotes wrong container";
|
1293 |
|
|
end if;
|
1294 |
|
|
|
1295 |
|
|
if Is_Empty (New_Item) then
|
1296 |
|
|
if Before.Container = null
|
1297 |
|
|
or else Before.Index > Container.Last
|
1298 |
|
|
then
|
1299 |
|
|
Position := No_Element;
|
1300 |
|
|
else
|
1301 |
|
|
Position := (Container'Unchecked_Access, Before.Index);
|
1302 |
|
|
end if;
|
1303 |
|
|
|
1304 |
|
|
return;
|
1305 |
|
|
end if;
|
1306 |
|
|
|
1307 |
|
|
if Before.Container = null
|
1308 |
|
|
or else Before.Index > Container.Last
|
1309 |
|
|
then
|
1310 |
|
|
if Container.Last = Index_Type'Last then
|
1311 |
|
|
raise Constraint_Error with
|
1312 |
|
|
"vector is already at its maximum length";
|
1313 |
|
|
end if;
|
1314 |
|
|
|
1315 |
|
|
Index := Container.Last + 1;
|
1316 |
|
|
|
1317 |
|
|
else
|
1318 |
|
|
Index := Before.Index;
|
1319 |
|
|
end if;
|
1320 |
|
|
|
1321 |
|
|
Insert (Container, Index, New_Item);
|
1322 |
|
|
|
1323 |
|
|
Position := Cursor'(Container'Unchecked_Access, Index);
|
1324 |
|
|
end Insert;
|
1325 |
|
|
|
1326 |
|
|
procedure Insert
|
1327 |
|
|
(Container : in out Vector;
|
1328 |
|
|
Before : Cursor;
|
1329 |
|
|
New_Item : Element_Type;
|
1330 |
|
|
Count : Count_Type := 1)
|
1331 |
|
|
is
|
1332 |
|
|
Index : Index_Type'Base;
|
1333 |
|
|
|
1334 |
|
|
begin
|
1335 |
|
|
if Before.Container /= null
|
1336 |
|
|
and then Before.Container /= Container'Unchecked_Access
|
1337 |
|
|
then
|
1338 |
|
|
raise Program_Error with "Before cursor denotes wrong container";
|
1339 |
|
|
end if;
|
1340 |
|
|
|
1341 |
|
|
if Count = 0 then
|
1342 |
|
|
return;
|
1343 |
|
|
end if;
|
1344 |
|
|
|
1345 |
|
|
if Before.Container = null
|
1346 |
|
|
or else Before.Index > Container.Last
|
1347 |
|
|
then
|
1348 |
|
|
if Container.Last = Index_Type'Last then
|
1349 |
|
|
raise Constraint_Error with
|
1350 |
|
|
"vector is already at its maximum length";
|
1351 |
|
|
end if;
|
1352 |
|
|
|
1353 |
|
|
Index := Container.Last + 1;
|
1354 |
|
|
|
1355 |
|
|
else
|
1356 |
|
|
Index := Before.Index;
|
1357 |
|
|
end if;
|
1358 |
|
|
|
1359 |
|
|
Insert (Container, Index, New_Item, Count);
|
1360 |
|
|
end Insert;
|
1361 |
|
|
|
1362 |
|
|
procedure Insert
|
1363 |
|
|
(Container : in out Vector;
|
1364 |
|
|
Before : Cursor;
|
1365 |
|
|
New_Item : Element_Type;
|
1366 |
|
|
Position : out Cursor;
|
1367 |
|
|
Count : Count_Type := 1)
|
1368 |
|
|
is
|
1369 |
|
|
Index : Index_Type'Base;
|
1370 |
|
|
|
1371 |
|
|
begin
|
1372 |
|
|
if Before.Container /= null
|
1373 |
|
|
and then Before.Container /= Container'Unchecked_Access
|
1374 |
|
|
then
|
1375 |
|
|
raise Program_Error with "Before cursor denotes wrong container";
|
1376 |
|
|
end if;
|
1377 |
|
|
|
1378 |
|
|
if Count = 0 then
|
1379 |
|
|
if Before.Container = null
|
1380 |
|
|
or else Before.Index > Container.Last
|
1381 |
|
|
then
|
1382 |
|
|
Position := No_Element;
|
1383 |
|
|
else
|
1384 |
|
|
Position := (Container'Unchecked_Access, Before.Index);
|
1385 |
|
|
end if;
|
1386 |
|
|
|
1387 |
|
|
return;
|
1388 |
|
|
end if;
|
1389 |
|
|
|
1390 |
|
|
if Before.Container = null
|
1391 |
|
|
or else Before.Index > Container.Last
|
1392 |
|
|
then
|
1393 |
|
|
if Container.Last = Index_Type'Last then
|
1394 |
|
|
raise Constraint_Error with
|
1395 |
|
|
"vector is already at its maximum length";
|
1396 |
|
|
end if;
|
1397 |
|
|
|
1398 |
|
|
Index := Container.Last + 1;
|
1399 |
|
|
|
1400 |
|
|
else
|
1401 |
|
|
Index := Before.Index;
|
1402 |
|
|
end if;
|
1403 |
|
|
|
1404 |
|
|
Insert (Container, Index, New_Item, Count);
|
1405 |
|
|
|
1406 |
|
|
Position := Cursor'(Container'Unchecked_Access, Index);
|
1407 |
|
|
end Insert;
|
1408 |
|
|
|
1409 |
|
|
procedure Insert
|
1410 |
|
|
(Container : in out Vector;
|
1411 |
|
|
Before : Extended_Index;
|
1412 |
|
|
Count : Count_Type := 1)
|
1413 |
|
|
is
|
1414 |
|
|
New_Item : Element_Type; -- Default-initialized value
|
1415 |
|
|
pragma Warnings (Off, New_Item);
|
1416 |
|
|
|
1417 |
|
|
begin
|
1418 |
|
|
Insert (Container, Before, New_Item, Count);
|
1419 |
|
|
end Insert;
|
1420 |
|
|
|
1421 |
|
|
procedure Insert
|
1422 |
|
|
(Container : in out Vector;
|
1423 |
|
|
Before : Cursor;
|
1424 |
|
|
Position : out Cursor;
|
1425 |
|
|
Count : Count_Type := 1)
|
1426 |
|
|
is
|
1427 |
|
|
New_Item : Element_Type; -- Default-initialized value
|
1428 |
|
|
pragma Warnings (Off, New_Item);
|
1429 |
|
|
|
1430 |
|
|
begin
|
1431 |
|
|
Insert (Container, Before, New_Item, Position, Count);
|
1432 |
|
|
end Insert;
|
1433 |
|
|
|
1434 |
|
|
------------------
|
1435 |
|
|
-- Insert_Space --
|
1436 |
|
|
------------------
|
1437 |
|
|
|
1438 |
|
|
procedure Insert_Space
|
1439 |
|
|
(Container : in out Vector;
|
1440 |
|
|
Before : Extended_Index;
|
1441 |
|
|
Count : Count_Type := 1)
|
1442 |
|
|
is
|
1443 |
|
|
EA : Elements_Array renames Container.Elements;
|
1444 |
|
|
Old_Length : constant Count_Type := Container.Length;
|
1445 |
|
|
|
1446 |
|
|
Max_Length : Count_Type'Base; -- determined from range of Index_Type
|
1447 |
|
|
New_Length : Count_Type'Base; -- sum of current length and Count
|
1448 |
|
|
|
1449 |
|
|
Index : Index_Type'Base; -- scratch for intermediate values
|
1450 |
|
|
J : Count_Type'Base; -- scratch
|
1451 |
|
|
|
1452 |
|
|
begin
|
1453 |
|
|
-- As a precondition on the generic actual Index_Type, the base type
|
1454 |
|
|
-- must include Index_Type'Pred (Index_Type'First); this is the value
|
1455 |
|
|
-- that Container.Last assumes when the vector is empty. However, we do
|
1456 |
|
|
-- not allow that as the value for Index when specifying where the new
|
1457 |
|
|
-- items should be inserted, so we must manually check. (That the user
|
1458 |
|
|
-- is allowed to specify the value at all here is a consequence of the
|
1459 |
|
|
-- declaration of the Extended_Index subtype, which includes the values
|
1460 |
|
|
-- in the base range that immediately precede and immediately follow the
|
1461 |
|
|
-- values in the Index_Type.)
|
1462 |
|
|
|
1463 |
|
|
if Before < Index_Type'First then
|
1464 |
|
|
raise Constraint_Error with
|
1465 |
|
|
"Before index is out of range (too small)";
|
1466 |
|
|
end if;
|
1467 |
|
|
|
1468 |
|
|
-- We do allow a value greater than Container.Last to be specified as
|
1469 |
|
|
-- the Index, but only if it's immediately greater. This allows for the
|
1470 |
|
|
-- case of appending items to the back end of the vector. (It is assumed
|
1471 |
|
|
-- that specifying an index value greater than Last + 1 indicates some
|
1472 |
|
|
-- deeper flaw in the caller's algorithm, so that case is treated as a
|
1473 |
|
|
-- proper error.)
|
1474 |
|
|
|
1475 |
|
|
if Before > Container.Last
|
1476 |
|
|
and then Before > Container.Last + 1
|
1477 |
|
|
then
|
1478 |
|
|
raise Constraint_Error with
|
1479 |
|
|
"Before index is out of range (too large)";
|
1480 |
|
|
end if;
|
1481 |
|
|
|
1482 |
|
|
-- We treat inserting 0 items into the container as a no-op, even when
|
1483 |
|
|
-- the container is busy, so we simply return.
|
1484 |
|
|
|
1485 |
|
|
if Count = 0 then
|
1486 |
|
|
return;
|
1487 |
|
|
end if;
|
1488 |
|
|
|
1489 |
|
|
-- There are two constraints we need to satisfy. The first constraint is
|
1490 |
|
|
-- that a container cannot have more than Count_Type'Last elements, so
|
1491 |
|
|
-- we must check the sum of the current length and the insertion count.
|
1492 |
|
|
-- Note that we cannot simply add these values, because of the
|
1493 |
|
|
-- possibility of overflow.
|
1494 |
|
|
|
1495 |
|
|
if Old_Length > Count_Type'Last - Count then
|
1496 |
|
|
raise Constraint_Error with "Count is out of range";
|
1497 |
|
|
end if;
|
1498 |
|
|
|
1499 |
|
|
-- It is now safe compute the length of the new vector, without fear of
|
1500 |
|
|
-- overflow.
|
1501 |
|
|
|
1502 |
|
|
New_Length := Old_Length + Count;
|
1503 |
|
|
|
1504 |
|
|
-- The second constraint is that the new Last index value cannot exceed
|
1505 |
|
|
-- Index_Type'Last. In each branch below, we calculate the maximum
|
1506 |
|
|
-- length (computed from the range of values in Index_Type), and then
|
1507 |
|
|
-- compare the new length to the maximum length. If the new length is
|
1508 |
|
|
-- acceptable, then we compute the new last index from that.
|
1509 |
|
|
|
1510 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
1511 |
|
|
-- We have to handle the case when there might be more values in the
|
1512 |
|
|
-- range of Index_Type than in the range of Count_Type.
|
1513 |
|
|
|
1514 |
|
|
if Index_Type'First <= 0 then
|
1515 |
|
|
-- We know that No_Index (the same as Index_Type'First - 1) is
|
1516 |
|
|
-- less than 0, so it is safe to compute the following sum without
|
1517 |
|
|
-- fear of overflow.
|
1518 |
|
|
|
1519 |
|
|
Index := No_Index + Index_Type'Base (Count_Type'Last);
|
1520 |
|
|
|
1521 |
|
|
if Index <= Index_Type'Last then
|
1522 |
|
|
-- We have determined that range of Index_Type has at least as
|
1523 |
|
|
-- many values as in Count_Type, so Count_Type'Last is the
|
1524 |
|
|
-- maximum number of items that are allowed.
|
1525 |
|
|
|
1526 |
|
|
Max_Length := Count_Type'Last;
|
1527 |
|
|
|
1528 |
|
|
else
|
1529 |
|
|
-- The range of Index_Type has fewer values than in Count_Type,
|
1530 |
|
|
-- so the maximum number of items is computed from the range of
|
1531 |
|
|
-- the Index_Type.
|
1532 |
|
|
|
1533 |
|
|
Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
1534 |
|
|
end if;
|
1535 |
|
|
|
1536 |
|
|
else
|
1537 |
|
|
-- No_Index is equal or greater than 0, so we can safely compute
|
1538 |
|
|
-- the difference without fear of overflow (which we would have to
|
1539 |
|
|
-- worry about if No_Index were less than 0, but that case is
|
1540 |
|
|
-- handled above).
|
1541 |
|
|
|
1542 |
|
|
Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
1543 |
|
|
end if;
|
1544 |
|
|
|
1545 |
|
|
elsif Index_Type'First <= 0 then
|
1546 |
|
|
-- We know that No_Index (the same as Index_Type'First - 1) is less
|
1547 |
|
|
-- than 0, so it is safe to compute the following sum without fear of
|
1548 |
|
|
-- overflow.
|
1549 |
|
|
|
1550 |
|
|
J := Count_Type'Base (No_Index) + Count_Type'Last;
|
1551 |
|
|
|
1552 |
|
|
if J <= Count_Type'Base (Index_Type'Last) then
|
1553 |
|
|
-- We have determined that range of Index_Type has at least as
|
1554 |
|
|
-- many values as in Count_Type, so Count_Type'Last is the maximum
|
1555 |
|
|
-- number of items that are allowed.
|
1556 |
|
|
|
1557 |
|
|
Max_Length := Count_Type'Last;
|
1558 |
|
|
|
1559 |
|
|
else
|
1560 |
|
|
-- The range of Index_Type has fewer values than Count_Type does,
|
1561 |
|
|
-- so the maximum number of items is computed from the range of
|
1562 |
|
|
-- the Index_Type.
|
1563 |
|
|
|
1564 |
|
|
Max_Length :=
|
1565 |
|
|
Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
1566 |
|
|
end if;
|
1567 |
|
|
|
1568 |
|
|
else
|
1569 |
|
|
-- No_Index is equal or greater than 0, so we can safely compute the
|
1570 |
|
|
-- difference without fear of overflow (which we would have to worry
|
1571 |
|
|
-- about if No_Index were less than 0, but that case is handled
|
1572 |
|
|
-- above).
|
1573 |
|
|
|
1574 |
|
|
Max_Length :=
|
1575 |
|
|
Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
1576 |
|
|
end if;
|
1577 |
|
|
|
1578 |
|
|
-- We have just computed the maximum length (number of items). We must
|
1579 |
|
|
-- now compare the requested length to the maximum length, as we do not
|
1580 |
|
|
-- allow a vector expand beyond the maximum (because that would create
|
1581 |
|
|
-- an internal array with a last index value greater than
|
1582 |
|
|
-- Index_Type'Last, with no way to index those elements).
|
1583 |
|
|
|
1584 |
|
|
if New_Length > Max_Length then
|
1585 |
|
|
raise Constraint_Error with "Count is out of range";
|
1586 |
|
|
end if;
|
1587 |
|
|
|
1588 |
|
|
-- The tampering bits exist to prevent an item from being harmfully
|
1589 |
|
|
-- manipulated while it is being visited. Query, Update, and Iterate
|
1590 |
|
|
-- increment the busy count on entry, and decrement the count on
|
1591 |
|
|
-- exit. Insert checks the count to determine whether it is being called
|
1592 |
|
|
-- while the associated callback procedure is executing.
|
1593 |
|
|
|
1594 |
|
|
if Container.Busy > 0 then
|
1595 |
|
|
raise Program_Error with
|
1596 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
1597 |
|
|
end if;
|
1598 |
|
|
|
1599 |
|
|
-- An internal array has already been allocated, so we need to check
|
1600 |
|
|
-- whether there is enough unused storage for the new items.
|
1601 |
|
|
|
1602 |
|
|
if New_Length > Container.Capacity then
|
1603 |
|
|
raise Capacity_Error with "New length is larger than capacity";
|
1604 |
|
|
end if;
|
1605 |
|
|
|
1606 |
|
|
-- In this case, we're inserting space into a vector that has already
|
1607 |
|
|
-- allocated an internal array, and the existing array has enough
|
1608 |
|
|
-- unused storage for the new items.
|
1609 |
|
|
|
1610 |
|
|
if Before <= Container.Last then
|
1611 |
|
|
-- The space is being inserted before some existing elements,
|
1612 |
|
|
-- so we must slide the existing elements up to their new home.
|
1613 |
|
|
|
1614 |
|
|
J := To_Array_Index (Before);
|
1615 |
|
|
EA (J + Count .. New_Length) := EA (J .. Old_Length);
|
1616 |
|
|
end if;
|
1617 |
|
|
|
1618 |
|
|
-- New_Last is the last index value of the items in the container after
|
1619 |
|
|
-- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
|
1620 |
|
|
-- compute its value from the New_Length.
|
1621 |
|
|
|
1622 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
1623 |
|
|
Container.Last := No_Index + Index_Type'Base (New_Length);
|
1624 |
|
|
|
1625 |
|
|
else
|
1626 |
|
|
Container.Last :=
|
1627 |
|
|
Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
|
1628 |
|
|
end if;
|
1629 |
|
|
end Insert_Space;
|
1630 |
|
|
|
1631 |
|
|
procedure Insert_Space
|
1632 |
|
|
(Container : in out Vector;
|
1633 |
|
|
Before : Cursor;
|
1634 |
|
|
Position : out Cursor;
|
1635 |
|
|
Count : Count_Type := 1)
|
1636 |
|
|
is
|
1637 |
|
|
Index : Index_Type'Base;
|
1638 |
|
|
|
1639 |
|
|
begin
|
1640 |
|
|
if Before.Container /= null
|
1641 |
|
|
and then Before.Container /= Container'Unchecked_Access
|
1642 |
|
|
then
|
1643 |
|
|
raise Program_Error with "Before cursor denotes wrong container";
|
1644 |
|
|
end if;
|
1645 |
|
|
|
1646 |
|
|
if Count = 0 then
|
1647 |
|
|
if Before.Container = null
|
1648 |
|
|
or else Before.Index > Container.Last
|
1649 |
|
|
then
|
1650 |
|
|
Position := No_Element;
|
1651 |
|
|
else
|
1652 |
|
|
Position := (Container'Unchecked_Access, Before.Index);
|
1653 |
|
|
end if;
|
1654 |
|
|
|
1655 |
|
|
return;
|
1656 |
|
|
end if;
|
1657 |
|
|
|
1658 |
|
|
if Before.Container = null
|
1659 |
|
|
or else Before.Index > Container.Last
|
1660 |
|
|
then
|
1661 |
|
|
if Container.Last = Index_Type'Last then
|
1662 |
|
|
raise Constraint_Error with
|
1663 |
|
|
"vector is already at its maximum length";
|
1664 |
|
|
end if;
|
1665 |
|
|
|
1666 |
|
|
Index := Container.Last + 1;
|
1667 |
|
|
|
1668 |
|
|
else
|
1669 |
|
|
Index := Before.Index;
|
1670 |
|
|
end if;
|
1671 |
|
|
|
1672 |
|
|
Insert_Space (Container, Index, Count => Count);
|
1673 |
|
|
|
1674 |
|
|
Position := Cursor'(Container'Unchecked_Access, Index);
|
1675 |
|
|
end Insert_Space;
|
1676 |
|
|
|
1677 |
|
|
--------------
|
1678 |
|
|
-- Is_Empty --
|
1679 |
|
|
--------------
|
1680 |
|
|
|
1681 |
|
|
function Is_Empty (Container : Vector) return Boolean is
|
1682 |
|
|
begin
|
1683 |
|
|
return Container.Last < Index_Type'First;
|
1684 |
|
|
end Is_Empty;
|
1685 |
|
|
|
1686 |
|
|
-------------
|
1687 |
|
|
-- Iterate --
|
1688 |
|
|
-------------
|
1689 |
|
|
|
1690 |
|
|
procedure Iterate
|
1691 |
|
|
(Container : Vector;
|
1692 |
|
|
Process : not null access procedure (Position : Cursor))
|
1693 |
|
|
is
|
1694 |
|
|
B : Natural renames Container'Unrestricted_Access.all.Busy;
|
1695 |
|
|
|
1696 |
|
|
begin
|
1697 |
|
|
B := B + 1;
|
1698 |
|
|
|
1699 |
|
|
begin
|
1700 |
|
|
for Indx in Index_Type'First .. Container.Last loop
|
1701 |
|
|
Process (Cursor'(Container'Unrestricted_Access, Indx));
|
1702 |
|
|
end loop;
|
1703 |
|
|
exception
|
1704 |
|
|
when others =>
|
1705 |
|
|
B := B - 1;
|
1706 |
|
|
raise;
|
1707 |
|
|
end;
|
1708 |
|
|
|
1709 |
|
|
B := B - 1;
|
1710 |
|
|
end Iterate;
|
1711 |
|
|
|
1712 |
|
|
function Iterate
|
1713 |
|
|
(Container : Vector)
|
1714 |
|
|
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
|
1715 |
|
|
is
|
1716 |
|
|
V : constant Vector_Access := Container'Unrestricted_Access;
|
1717 |
|
|
B : Natural renames V.Busy;
|
1718 |
|
|
|
1719 |
|
|
begin
|
1720 |
|
|
-- The value of its Index component influences the behavior of the First
|
1721 |
|
|
-- and Last selector functions of the iterator object. When the Index
|
1722 |
|
|
-- component is No_Index (as is the case here), this means the iterator
|
1723 |
|
|
-- object was constructed without a start expression. This is a complete
|
1724 |
|
|
-- iterator, meaning that the iteration starts from the (logical)
|
1725 |
|
|
-- beginning of the sequence of items.
|
1726 |
|
|
|
1727 |
|
|
-- Note: For a forward iterator, Container.First is the beginning, and
|
1728 |
|
|
-- for a reverse iterator, Container.Last is the beginning.
|
1729 |
|
|
|
1730 |
|
|
return It : constant Iterator :=
|
1731 |
|
|
(Limited_Controlled with
|
1732 |
|
|
Container => V,
|
1733 |
|
|
Index => No_Index)
|
1734 |
|
|
do
|
1735 |
|
|
B := B + 1;
|
1736 |
|
|
end return;
|
1737 |
|
|
end Iterate;
|
1738 |
|
|
|
1739 |
|
|
function Iterate
|
1740 |
|
|
(Container : Vector;
|
1741 |
|
|
Start : Cursor)
|
1742 |
|
|
return Vector_Iterator_Interfaces.Reversible_Iterator'Class
|
1743 |
|
|
is
|
1744 |
|
|
V : constant Vector_Access := Container'Unrestricted_Access;
|
1745 |
|
|
B : Natural renames V.Busy;
|
1746 |
|
|
|
1747 |
|
|
begin
|
1748 |
|
|
-- It was formerly the case that when Start = No_Element, the partial
|
1749 |
|
|
-- iterator was defined to behave the same as for a complete iterator,
|
1750 |
|
|
-- and iterate over the entire sequence of items. However, those
|
1751 |
|
|
-- semantics were unintuitive and arguably error-prone (it is too easy
|
1752 |
|
|
-- to accidentally create an endless loop), and so they were changed,
|
1753 |
|
|
-- per the ARG meeting in Denver on 2011/11. However, there was no
|
1754 |
|
|
-- consensus about what positive meaning this corner case should have,
|
1755 |
|
|
-- and so it was decided to simply raise an exception. This does imply,
|
1756 |
|
|
-- however, that it is not possible to use a partial iterator to specify
|
1757 |
|
|
-- an empty sequence of items.
|
1758 |
|
|
|
1759 |
|
|
if Start.Container = null then
|
1760 |
|
|
raise Constraint_Error with
|
1761 |
|
|
"Start position for iterator equals No_Element";
|
1762 |
|
|
end if;
|
1763 |
|
|
|
1764 |
|
|
if Start.Container /= V then
|
1765 |
|
|
raise Program_Error with
|
1766 |
|
|
"Start cursor of Iterate designates wrong vector";
|
1767 |
|
|
end if;
|
1768 |
|
|
|
1769 |
|
|
if Start.Index > V.Last then
|
1770 |
|
|
raise Constraint_Error with
|
1771 |
|
|
"Start position for iterator equals No_Element";
|
1772 |
|
|
end if;
|
1773 |
|
|
|
1774 |
|
|
-- The value of its Index component influences the behavior of the First
|
1775 |
|
|
-- and Last selector functions of the iterator object. When the Index
|
1776 |
|
|
-- component is not No_Index (as is the case here), it means that this
|
1777 |
|
|
-- is a partial iteration, over a subset of the complete sequence of
|
1778 |
|
|
-- items. The iterator object was constructed with a start expression,
|
1779 |
|
|
-- indicating the position from which the iteration begins. Note that
|
1780 |
|
|
-- the start position has the same value irrespective of whether this is
|
1781 |
|
|
-- a forward or reverse iteration.
|
1782 |
|
|
|
1783 |
|
|
return It : constant Iterator :=
|
1784 |
|
|
(Limited_Controlled with
|
1785 |
|
|
Container => V,
|
1786 |
|
|
Index => Start.Index)
|
1787 |
|
|
do
|
1788 |
|
|
B := B + 1;
|
1789 |
|
|
end return;
|
1790 |
|
|
end Iterate;
|
1791 |
|
|
|
1792 |
|
|
----------
|
1793 |
|
|
-- Last --
|
1794 |
|
|
----------
|
1795 |
|
|
|
1796 |
|
|
function Last (Container : Vector) return Cursor is
|
1797 |
|
|
begin
|
1798 |
|
|
if Is_Empty (Container) then
|
1799 |
|
|
return No_Element;
|
1800 |
|
|
else
|
1801 |
|
|
return (Container'Unrestricted_Access, Container.Last);
|
1802 |
|
|
end if;
|
1803 |
|
|
end Last;
|
1804 |
|
|
|
1805 |
|
|
function Last (Object : Iterator) return Cursor is
|
1806 |
|
|
begin
|
1807 |
|
|
-- The value of the iterator object's Index component influences the
|
1808 |
|
|
-- behavior of the Last (and First) selector function.
|
1809 |
|
|
|
1810 |
|
|
-- When the Index component is No_Index, this means the iterator object
|
1811 |
|
|
-- was constructed without a start expression, in which case the
|
1812 |
|
|
-- (reverse) iteration starts from the (logical) beginning of the entire
|
1813 |
|
|
-- sequence (corresponding to Container.Last, for a reverse iterator).
|
1814 |
|
|
|
1815 |
|
|
-- Otherwise, this is iteration over a partial sequence of items. When
|
1816 |
|
|
-- the Index component is not No_Index, the iterator object was
|
1817 |
|
|
-- constructed with a start expression, that specifies the position from
|
1818 |
|
|
-- which the (reverse) partial iteration begins.
|
1819 |
|
|
|
1820 |
|
|
if Object.Index = No_Index then
|
1821 |
|
|
return Last (Object.Container.all);
|
1822 |
|
|
else
|
1823 |
|
|
return Cursor'(Object.Container, Object.Index);
|
1824 |
|
|
end if;
|
1825 |
|
|
end Last;
|
1826 |
|
|
|
1827 |
|
|
------------------
|
1828 |
|
|
-- Last_Element --
|
1829 |
|
|
------------------
|
1830 |
|
|
|
1831 |
|
|
function Last_Element (Container : Vector) return Element_Type is
|
1832 |
|
|
begin
|
1833 |
|
|
if Container.Last = No_Index then
|
1834 |
|
|
raise Constraint_Error with "Container is empty";
|
1835 |
|
|
else
|
1836 |
|
|
return Container.Elements (Container.Length);
|
1837 |
|
|
end if;
|
1838 |
|
|
end Last_Element;
|
1839 |
|
|
|
1840 |
|
|
----------------
|
1841 |
|
|
-- Last_Index --
|
1842 |
|
|
----------------
|
1843 |
|
|
|
1844 |
|
|
function Last_Index (Container : Vector) return Extended_Index is
|
1845 |
|
|
begin
|
1846 |
|
|
return Container.Last;
|
1847 |
|
|
end Last_Index;
|
1848 |
|
|
|
1849 |
|
|
------------
|
1850 |
|
|
-- Length --
|
1851 |
|
|
------------
|
1852 |
|
|
|
1853 |
|
|
function Length (Container : Vector) return Count_Type is
|
1854 |
|
|
L : constant Index_Type'Base := Container.Last;
|
1855 |
|
|
F : constant Index_Type := Index_Type'First;
|
1856 |
|
|
|
1857 |
|
|
begin
|
1858 |
|
|
-- The base range of the index type (Index_Type'Base) might not include
|
1859 |
|
|
-- all values for length (Count_Type). Contrariwise, the index type
|
1860 |
|
|
-- might include values outside the range of length. Hence we use
|
1861 |
|
|
-- whatever type is wider for intermediate values when calculating
|
1862 |
|
|
-- length. Note that no matter what the index type is, the maximum
|
1863 |
|
|
-- length to which a vector is allowed to grow is always the minimum
|
1864 |
|
|
-- of Count_Type'Last and (IT'Last - IT'First + 1).
|
1865 |
|
|
|
1866 |
|
|
-- For example, an Index_Type with range -127 .. 127 is only guaranteed
|
1867 |
|
|
-- to have a base range of -128 .. 127, but the corresponding vector
|
1868 |
|
|
-- would have lengths in the range 0 .. 255. In this case we would need
|
1869 |
|
|
-- to use Count_Type'Base for intermediate values.
|
1870 |
|
|
|
1871 |
|
|
-- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
|
1872 |
|
|
-- vector would have a maximum length of 10, but the index values lie
|
1873 |
|
|
-- outside the range of Count_Type (which is only 32 bits). In this
|
1874 |
|
|
-- case we would need to use Index_Type'Base for intermediate values.
|
1875 |
|
|
|
1876 |
|
|
if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
|
1877 |
|
|
return Count_Type'Base (L) - Count_Type'Base (F) + 1;
|
1878 |
|
|
else
|
1879 |
|
|
return Count_Type (L - F + 1);
|
1880 |
|
|
end if;
|
1881 |
|
|
end Length;
|
1882 |
|
|
|
1883 |
|
|
----------
|
1884 |
|
|
-- Move --
|
1885 |
|
|
----------
|
1886 |
|
|
|
1887 |
|
|
procedure Move
|
1888 |
|
|
(Target : in out Vector;
|
1889 |
|
|
Source : in out Vector)
|
1890 |
|
|
is
|
1891 |
|
|
begin
|
1892 |
|
|
if Target'Address = Source'Address then
|
1893 |
|
|
return;
|
1894 |
|
|
end if;
|
1895 |
|
|
|
1896 |
|
|
if Target.Capacity < Source.Length then
|
1897 |
|
|
raise Capacity_Error -- ???
|
1898 |
|
|
with "Target capacity is less than Source length";
|
1899 |
|
|
end if;
|
1900 |
|
|
|
1901 |
|
|
if Target.Busy > 0 then
|
1902 |
|
|
raise Program_Error with
|
1903 |
|
|
"attempt to tamper with cursors (Target is busy)";
|
1904 |
|
|
end if;
|
1905 |
|
|
|
1906 |
|
|
if Source.Busy > 0 then
|
1907 |
|
|
raise Program_Error with
|
1908 |
|
|
"attempt to tamper with cursors (Source is busy)";
|
1909 |
|
|
end if;
|
1910 |
|
|
|
1911 |
|
|
-- Clear Target now, in case element assignment fails
|
1912 |
|
|
|
1913 |
|
|
Target.Last := No_Index;
|
1914 |
|
|
|
1915 |
|
|
Target.Elements (1 .. Source.Length) :=
|
1916 |
|
|
Source.Elements (1 .. Source.Length);
|
1917 |
|
|
|
1918 |
|
|
Target.Last := Source.Last;
|
1919 |
|
|
Source.Last := No_Index;
|
1920 |
|
|
end Move;
|
1921 |
|
|
|
1922 |
|
|
----------
|
1923 |
|
|
-- Next --
|
1924 |
|
|
----------
|
1925 |
|
|
|
1926 |
|
|
function Next (Position : Cursor) return Cursor is
|
1927 |
|
|
begin
|
1928 |
|
|
if Position.Container = null then
|
1929 |
|
|
return No_Element;
|
1930 |
|
|
end if;
|
1931 |
|
|
|
1932 |
|
|
if Position.Index < Position.Container.Last then
|
1933 |
|
|
return (Position.Container, Position.Index + 1);
|
1934 |
|
|
end if;
|
1935 |
|
|
|
1936 |
|
|
return No_Element;
|
1937 |
|
|
end Next;
|
1938 |
|
|
|
1939 |
|
|
function Next (Object : Iterator; Position : Cursor) return Cursor is
|
1940 |
|
|
begin
|
1941 |
|
|
if Position.Container = null then
|
1942 |
|
|
return No_Element;
|
1943 |
|
|
end if;
|
1944 |
|
|
|
1945 |
|
|
if Position.Container /= Object.Container then
|
1946 |
|
|
raise Program_Error with
|
1947 |
|
|
"Position cursor of Next designates wrong vector";
|
1948 |
|
|
end if;
|
1949 |
|
|
|
1950 |
|
|
return Next (Position);
|
1951 |
|
|
end Next;
|
1952 |
|
|
|
1953 |
|
|
procedure Next (Position : in out Cursor) is
|
1954 |
|
|
begin
|
1955 |
|
|
if Position.Container = null then
|
1956 |
|
|
return;
|
1957 |
|
|
end if;
|
1958 |
|
|
|
1959 |
|
|
if Position.Index < Position.Container.Last then
|
1960 |
|
|
Position.Index := Position.Index + 1;
|
1961 |
|
|
else
|
1962 |
|
|
Position := No_Element;
|
1963 |
|
|
end if;
|
1964 |
|
|
end Next;
|
1965 |
|
|
|
1966 |
|
|
-------------
|
1967 |
|
|
-- Prepend --
|
1968 |
|
|
-------------
|
1969 |
|
|
|
1970 |
|
|
procedure Prepend (Container : in out Vector; New_Item : Vector) is
|
1971 |
|
|
begin
|
1972 |
|
|
Insert (Container, Index_Type'First, New_Item);
|
1973 |
|
|
end Prepend;
|
1974 |
|
|
|
1975 |
|
|
procedure Prepend
|
1976 |
|
|
(Container : in out Vector;
|
1977 |
|
|
New_Item : Element_Type;
|
1978 |
|
|
Count : Count_Type := 1)
|
1979 |
|
|
is
|
1980 |
|
|
begin
|
1981 |
|
|
Insert (Container,
|
1982 |
|
|
Index_Type'First,
|
1983 |
|
|
New_Item,
|
1984 |
|
|
Count);
|
1985 |
|
|
end Prepend;
|
1986 |
|
|
|
1987 |
|
|
--------------
|
1988 |
|
|
-- Previous --
|
1989 |
|
|
--------------
|
1990 |
|
|
|
1991 |
|
|
procedure Previous (Position : in out Cursor) is
|
1992 |
|
|
begin
|
1993 |
|
|
if Position.Container = null then
|
1994 |
|
|
return;
|
1995 |
|
|
end if;
|
1996 |
|
|
|
1997 |
|
|
if Position.Index > Index_Type'First then
|
1998 |
|
|
Position.Index := Position.Index - 1;
|
1999 |
|
|
else
|
2000 |
|
|
Position := No_Element;
|
2001 |
|
|
end if;
|
2002 |
|
|
end Previous;
|
2003 |
|
|
|
2004 |
|
|
function Previous (Position : Cursor) return Cursor is
|
2005 |
|
|
begin
|
2006 |
|
|
if Position.Container = null then
|
2007 |
|
|
return No_Element;
|
2008 |
|
|
end if;
|
2009 |
|
|
|
2010 |
|
|
if Position.Index > Index_Type'First then
|
2011 |
|
|
return (Position.Container, Position.Index - 1);
|
2012 |
|
|
end if;
|
2013 |
|
|
|
2014 |
|
|
return No_Element;
|
2015 |
|
|
end Previous;
|
2016 |
|
|
|
2017 |
|
|
function Previous (Object : Iterator; Position : Cursor) return Cursor is
|
2018 |
|
|
begin
|
2019 |
|
|
if Position.Container = null then
|
2020 |
|
|
return No_Element;
|
2021 |
|
|
end if;
|
2022 |
|
|
|
2023 |
|
|
if Position.Container /= Object.Container then
|
2024 |
|
|
raise Program_Error with
|
2025 |
|
|
"Position cursor of Previous designates wrong vector";
|
2026 |
|
|
end if;
|
2027 |
|
|
|
2028 |
|
|
return Previous (Position);
|
2029 |
|
|
end Previous;
|
2030 |
|
|
|
2031 |
|
|
-------------------
|
2032 |
|
|
-- Query_Element --
|
2033 |
|
|
-------------------
|
2034 |
|
|
|
2035 |
|
|
procedure Query_Element
|
2036 |
|
|
(Container : Vector;
|
2037 |
|
|
Index : Index_Type;
|
2038 |
|
|
Process : not null access procedure (Element : Element_Type))
|
2039 |
|
|
is
|
2040 |
|
|
V : Vector renames Container'Unrestricted_Access.all;
|
2041 |
|
|
B : Natural renames V.Busy;
|
2042 |
|
|
L : Natural renames V.Lock;
|
2043 |
|
|
|
2044 |
|
|
begin
|
2045 |
|
|
if Index > Container.Last then
|
2046 |
|
|
raise Constraint_Error with "Index is out of range";
|
2047 |
|
|
end if;
|
2048 |
|
|
|
2049 |
|
|
B := B + 1;
|
2050 |
|
|
L := L + 1;
|
2051 |
|
|
|
2052 |
|
|
begin
|
2053 |
|
|
Process (V.Elements (To_Array_Index (Index)));
|
2054 |
|
|
exception
|
2055 |
|
|
when others =>
|
2056 |
|
|
L := L - 1;
|
2057 |
|
|
B := B - 1;
|
2058 |
|
|
raise;
|
2059 |
|
|
end;
|
2060 |
|
|
|
2061 |
|
|
L := L - 1;
|
2062 |
|
|
B := B - 1;
|
2063 |
|
|
end Query_Element;
|
2064 |
|
|
|
2065 |
|
|
procedure Query_Element
|
2066 |
|
|
(Position : Cursor;
|
2067 |
|
|
Process : not null access procedure (Element : Element_Type))
|
2068 |
|
|
is
|
2069 |
|
|
begin
|
2070 |
|
|
if Position.Container = null then
|
2071 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
2072 |
|
|
end if;
|
2073 |
|
|
|
2074 |
|
|
Query_Element (Position.Container.all, Position.Index, Process);
|
2075 |
|
|
end Query_Element;
|
2076 |
|
|
|
2077 |
|
|
----------
|
2078 |
|
|
-- Read --
|
2079 |
|
|
----------
|
2080 |
|
|
|
2081 |
|
|
procedure Read
|
2082 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2083 |
|
|
Container : out Vector)
|
2084 |
|
|
is
|
2085 |
|
|
Length : Count_Type'Base;
|
2086 |
|
|
Last : Index_Type'Base := No_Index;
|
2087 |
|
|
|
2088 |
|
|
begin
|
2089 |
|
|
Clear (Container);
|
2090 |
|
|
|
2091 |
|
|
Count_Type'Base'Read (Stream, Length);
|
2092 |
|
|
|
2093 |
|
|
Reserve_Capacity (Container, Capacity => Length);
|
2094 |
|
|
|
2095 |
|
|
for Idx in Count_Type range 1 .. Length loop
|
2096 |
|
|
Last := Last + 1;
|
2097 |
|
|
Element_Type'Read (Stream, Container.Elements (Idx));
|
2098 |
|
|
Container.Last := Last;
|
2099 |
|
|
end loop;
|
2100 |
|
|
end Read;
|
2101 |
|
|
|
2102 |
|
|
procedure Read
|
2103 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2104 |
|
|
Position : out Cursor)
|
2105 |
|
|
is
|
2106 |
|
|
begin
|
2107 |
|
|
raise Program_Error with "attempt to stream vector cursor";
|
2108 |
|
|
end Read;
|
2109 |
|
|
|
2110 |
|
|
procedure Read
|
2111 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2112 |
|
|
Item : out Reference_Type)
|
2113 |
|
|
is
|
2114 |
|
|
begin
|
2115 |
|
|
raise Program_Error with "attempt to stream reference";
|
2116 |
|
|
end Read;
|
2117 |
|
|
|
2118 |
|
|
procedure Read
|
2119 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2120 |
|
|
Item : out Constant_Reference_Type)
|
2121 |
|
|
is
|
2122 |
|
|
begin
|
2123 |
|
|
raise Program_Error with "attempt to stream reference";
|
2124 |
|
|
end Read;
|
2125 |
|
|
|
2126 |
|
|
---------------
|
2127 |
|
|
-- Reference --
|
2128 |
|
|
---------------
|
2129 |
|
|
|
2130 |
|
|
function Reference
|
2131 |
|
|
(Container : aliased in out Vector;
|
2132 |
|
|
Position : Cursor) return Reference_Type
|
2133 |
|
|
is
|
2134 |
|
|
begin
|
2135 |
|
|
if Position.Container = null then
|
2136 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
2137 |
|
|
end if;
|
2138 |
|
|
|
2139 |
|
|
if Position.Container /= Container'Unrestricted_Access then
|
2140 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
2141 |
|
|
end if;
|
2142 |
|
|
|
2143 |
|
|
if Position.Index > Position.Container.Last then
|
2144 |
|
|
raise Constraint_Error with "Position cursor is out of range";
|
2145 |
|
|
end if;
|
2146 |
|
|
|
2147 |
|
|
declare
|
2148 |
|
|
A : Elements_Array renames Container.Elements;
|
2149 |
|
|
I : constant Count_Type := To_Array_Index (Position.Index);
|
2150 |
|
|
begin
|
2151 |
|
|
return (Element => A (I)'Access);
|
2152 |
|
|
end;
|
2153 |
|
|
end Reference;
|
2154 |
|
|
|
2155 |
|
|
function Reference
|
2156 |
|
|
(Container : aliased in out Vector;
|
2157 |
|
|
Index : Index_Type) return Reference_Type
|
2158 |
|
|
is
|
2159 |
|
|
begin
|
2160 |
|
|
if Index > Container.Last then
|
2161 |
|
|
raise Constraint_Error with "Index is out of range";
|
2162 |
|
|
end if;
|
2163 |
|
|
|
2164 |
|
|
declare
|
2165 |
|
|
A : Elements_Array renames Container.Elements;
|
2166 |
|
|
I : constant Count_Type := To_Array_Index (Index);
|
2167 |
|
|
begin
|
2168 |
|
|
return (Element => A (I)'Access);
|
2169 |
|
|
end;
|
2170 |
|
|
end Reference;
|
2171 |
|
|
|
2172 |
|
|
---------------------
|
2173 |
|
|
-- Replace_Element --
|
2174 |
|
|
---------------------
|
2175 |
|
|
|
2176 |
|
|
procedure Replace_Element
|
2177 |
|
|
(Container : in out Vector;
|
2178 |
|
|
Index : Index_Type;
|
2179 |
|
|
New_Item : Element_Type)
|
2180 |
|
|
is
|
2181 |
|
|
begin
|
2182 |
|
|
if Index > Container.Last then
|
2183 |
|
|
raise Constraint_Error with "Index is out of range";
|
2184 |
|
|
end if;
|
2185 |
|
|
|
2186 |
|
|
if Container.Lock > 0 then
|
2187 |
|
|
raise Program_Error with
|
2188 |
|
|
"attempt to tamper with elements (vector is locked)";
|
2189 |
|
|
end if;
|
2190 |
|
|
|
2191 |
|
|
Container.Elements (To_Array_Index (Index)) := New_Item;
|
2192 |
|
|
end Replace_Element;
|
2193 |
|
|
|
2194 |
|
|
procedure Replace_Element
|
2195 |
|
|
(Container : in out Vector;
|
2196 |
|
|
Position : Cursor;
|
2197 |
|
|
New_Item : Element_Type)
|
2198 |
|
|
is
|
2199 |
|
|
begin
|
2200 |
|
|
if Position.Container = null then
|
2201 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
2202 |
|
|
end if;
|
2203 |
|
|
|
2204 |
|
|
if Position.Container /= Container'Unrestricted_Access then
|
2205 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
2206 |
|
|
end if;
|
2207 |
|
|
|
2208 |
|
|
if Position.Index > Container.Last then
|
2209 |
|
|
raise Constraint_Error with "Position cursor is out of range";
|
2210 |
|
|
end if;
|
2211 |
|
|
|
2212 |
|
|
if Container.Lock > 0 then
|
2213 |
|
|
raise Program_Error with
|
2214 |
|
|
"attempt to tamper with elements (vector is locked)";
|
2215 |
|
|
end if;
|
2216 |
|
|
|
2217 |
|
|
Container.Elements (To_Array_Index (Position.Index)) := New_Item;
|
2218 |
|
|
end Replace_Element;
|
2219 |
|
|
|
2220 |
|
|
----------------------
|
2221 |
|
|
-- Reserve_Capacity --
|
2222 |
|
|
----------------------
|
2223 |
|
|
|
2224 |
|
|
procedure Reserve_Capacity
|
2225 |
|
|
(Container : in out Vector;
|
2226 |
|
|
Capacity : Count_Type)
|
2227 |
|
|
is
|
2228 |
|
|
begin
|
2229 |
|
|
if Capacity > Container.Capacity then
|
2230 |
|
|
raise Constraint_Error with "Capacity is out of range";
|
2231 |
|
|
end if;
|
2232 |
|
|
end Reserve_Capacity;
|
2233 |
|
|
|
2234 |
|
|
----------------------
|
2235 |
|
|
-- Reverse_Elements --
|
2236 |
|
|
----------------------
|
2237 |
|
|
|
2238 |
|
|
procedure Reverse_Elements (Container : in out Vector) is
|
2239 |
|
|
E : Elements_Array renames Container.Elements;
|
2240 |
|
|
Idx : Count_Type;
|
2241 |
|
|
Jdx : Count_Type;
|
2242 |
|
|
|
2243 |
|
|
begin
|
2244 |
|
|
if Container.Length <= 1 then
|
2245 |
|
|
return;
|
2246 |
|
|
end if;
|
2247 |
|
|
|
2248 |
|
|
-- The exception behavior for the vector container must match that for
|
2249 |
|
|
-- the list container, so we check for cursor tampering here (which will
|
2250 |
|
|
-- catch more things) instead of for element tampering (which will catch
|
2251 |
|
|
-- fewer things). It's true that the elements of this vector container
|
2252 |
|
|
-- could be safely moved around while (say) an iteration is taking place
|
2253 |
|
|
-- (iteration only increments the busy counter), and so technically
|
2254 |
|
|
-- all we would need here is a test for element tampering (indicated
|
2255 |
|
|
-- by the lock counter), that's simply an artifact of our array-based
|
2256 |
|
|
-- implementation. Logically Reverse_Elements requires a check for
|
2257 |
|
|
-- cursor tampering.
|
2258 |
|
|
|
2259 |
|
|
if Container.Busy > 0 then
|
2260 |
|
|
raise Program_Error with
|
2261 |
|
|
"attempt to tamper with cursors (vector is busy)";
|
2262 |
|
|
end if;
|
2263 |
|
|
|
2264 |
|
|
Idx := 1;
|
2265 |
|
|
Jdx := Container.Length;
|
2266 |
|
|
while Idx < Jdx loop
|
2267 |
|
|
declare
|
2268 |
|
|
EI : constant Element_Type := E (Idx);
|
2269 |
|
|
|
2270 |
|
|
begin
|
2271 |
|
|
E (Idx) := E (Jdx);
|
2272 |
|
|
E (Jdx) := EI;
|
2273 |
|
|
end;
|
2274 |
|
|
|
2275 |
|
|
Idx := Idx + 1;
|
2276 |
|
|
Jdx := Jdx - 1;
|
2277 |
|
|
end loop;
|
2278 |
|
|
end Reverse_Elements;
|
2279 |
|
|
|
2280 |
|
|
------------------
|
2281 |
|
|
-- Reverse_Find --
|
2282 |
|
|
------------------
|
2283 |
|
|
|
2284 |
|
|
function Reverse_Find
|
2285 |
|
|
(Container : Vector;
|
2286 |
|
|
Item : Element_Type;
|
2287 |
|
|
Position : Cursor := No_Element) return Cursor
|
2288 |
|
|
is
|
2289 |
|
|
Last : Index_Type'Base;
|
2290 |
|
|
|
2291 |
|
|
begin
|
2292 |
|
|
if Position.Container /= null
|
2293 |
|
|
and then Position.Container /= Container'Unrestricted_Access
|
2294 |
|
|
then
|
2295 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
2296 |
|
|
end if;
|
2297 |
|
|
|
2298 |
|
|
Last :=
|
2299 |
|
|
(if Position.Container = null or else Position.Index > Container.Last
|
2300 |
|
|
then Container.Last
|
2301 |
|
|
else Position.Index);
|
2302 |
|
|
|
2303 |
|
|
for Indx in reverse Index_Type'First .. Last loop
|
2304 |
|
|
if Container.Elements (To_Array_Index (Indx)) = Item then
|
2305 |
|
|
return (Container'Unrestricted_Access, Indx);
|
2306 |
|
|
end if;
|
2307 |
|
|
end loop;
|
2308 |
|
|
|
2309 |
|
|
return No_Element;
|
2310 |
|
|
end Reverse_Find;
|
2311 |
|
|
|
2312 |
|
|
------------------------
|
2313 |
|
|
-- Reverse_Find_Index --
|
2314 |
|
|
------------------------
|
2315 |
|
|
|
2316 |
|
|
function Reverse_Find_Index
|
2317 |
|
|
(Container : Vector;
|
2318 |
|
|
Item : Element_Type;
|
2319 |
|
|
Index : Index_Type := Index_Type'Last) return Extended_Index
|
2320 |
|
|
is
|
2321 |
|
|
Last : constant Index_Type'Base :=
|
2322 |
|
|
Index_Type'Min (Container.Last, Index);
|
2323 |
|
|
|
2324 |
|
|
begin
|
2325 |
|
|
for Indx in reverse Index_Type'First .. Last loop
|
2326 |
|
|
if Container.Elements (To_Array_Index (Indx)) = Item then
|
2327 |
|
|
return Indx;
|
2328 |
|
|
end if;
|
2329 |
|
|
end loop;
|
2330 |
|
|
|
2331 |
|
|
return No_Index;
|
2332 |
|
|
end Reverse_Find_Index;
|
2333 |
|
|
|
2334 |
|
|
---------------------
|
2335 |
|
|
-- Reverse_Iterate --
|
2336 |
|
|
---------------------
|
2337 |
|
|
|
2338 |
|
|
procedure Reverse_Iterate
|
2339 |
|
|
(Container : Vector;
|
2340 |
|
|
Process : not null access procedure (Position : Cursor))
|
2341 |
|
|
is
|
2342 |
|
|
V : Vector renames Container'Unrestricted_Access.all;
|
2343 |
|
|
B : Natural renames V.Busy;
|
2344 |
|
|
|
2345 |
|
|
begin
|
2346 |
|
|
B := B + 1;
|
2347 |
|
|
|
2348 |
|
|
begin
|
2349 |
|
|
for Indx in reverse Index_Type'First .. Container.Last loop
|
2350 |
|
|
Process (Cursor'(Container'Unrestricted_Access, Indx));
|
2351 |
|
|
end loop;
|
2352 |
|
|
exception
|
2353 |
|
|
when others =>
|
2354 |
|
|
B := B - 1;
|
2355 |
|
|
raise;
|
2356 |
|
|
end;
|
2357 |
|
|
|
2358 |
|
|
B := B - 1;
|
2359 |
|
|
end Reverse_Iterate;
|
2360 |
|
|
|
2361 |
|
|
----------------
|
2362 |
|
|
-- Set_Length --
|
2363 |
|
|
----------------
|
2364 |
|
|
|
2365 |
|
|
procedure Set_Length (Container : in out Vector; Length : Count_Type) is
|
2366 |
|
|
Count : constant Count_Type'Base := Container.Length - Length;
|
2367 |
|
|
|
2368 |
|
|
begin
|
2369 |
|
|
-- Set_Length allows the user to set the length explicitly, instead of
|
2370 |
|
|
-- implicitly as a side-effect of deletion or insertion. If the
|
2371 |
|
|
-- requested length is less then the current length, this is equivalent
|
2372 |
|
|
-- to deleting items from the back end of the vector. If the requested
|
2373 |
|
|
-- length is greater than the current length, then this is equivalent to
|
2374 |
|
|
-- inserting "space" (nonce items) at the end.
|
2375 |
|
|
|
2376 |
|
|
if Count >= 0 then
|
2377 |
|
|
Container.Delete_Last (Count);
|
2378 |
|
|
|
2379 |
|
|
elsif Container.Last >= Index_Type'Last then
|
2380 |
|
|
raise Constraint_Error with "vector is already at its maximum length";
|
2381 |
|
|
|
2382 |
|
|
else
|
2383 |
|
|
Container.Insert_Space (Container.Last + 1, -Count);
|
2384 |
|
|
end if;
|
2385 |
|
|
end Set_Length;
|
2386 |
|
|
|
2387 |
|
|
----------
|
2388 |
|
|
-- Swap --
|
2389 |
|
|
----------
|
2390 |
|
|
|
2391 |
|
|
procedure Swap (Container : in out Vector; I, J : Index_Type) is
|
2392 |
|
|
E : Elements_Array renames Container.Elements;
|
2393 |
|
|
|
2394 |
|
|
begin
|
2395 |
|
|
if I > Container.Last then
|
2396 |
|
|
raise Constraint_Error with "I index is out of range";
|
2397 |
|
|
end if;
|
2398 |
|
|
|
2399 |
|
|
if J > Container.Last then
|
2400 |
|
|
raise Constraint_Error with "J index is out of range";
|
2401 |
|
|
end if;
|
2402 |
|
|
|
2403 |
|
|
if I = J then
|
2404 |
|
|
return;
|
2405 |
|
|
end if;
|
2406 |
|
|
|
2407 |
|
|
if Container.Lock > 0 then
|
2408 |
|
|
raise Program_Error with
|
2409 |
|
|
"attempt to tamper with elements (vector is locked)";
|
2410 |
|
|
end if;
|
2411 |
|
|
|
2412 |
|
|
declare
|
2413 |
|
|
EI_Copy : constant Element_Type := E (To_Array_Index (I));
|
2414 |
|
|
begin
|
2415 |
|
|
E (To_Array_Index (I)) := E (To_Array_Index (J));
|
2416 |
|
|
E (To_Array_Index (J)) := EI_Copy;
|
2417 |
|
|
end;
|
2418 |
|
|
end Swap;
|
2419 |
|
|
|
2420 |
|
|
procedure Swap (Container : in out Vector; I, J : Cursor) is
|
2421 |
|
|
begin
|
2422 |
|
|
if I.Container = null then
|
2423 |
|
|
raise Constraint_Error with "I cursor has no element";
|
2424 |
|
|
end if;
|
2425 |
|
|
|
2426 |
|
|
if J.Container = null then
|
2427 |
|
|
raise Constraint_Error with "J cursor has no element";
|
2428 |
|
|
end if;
|
2429 |
|
|
|
2430 |
|
|
if I.Container /= Container'Unrestricted_Access then
|
2431 |
|
|
raise Program_Error with "I cursor denotes wrong container";
|
2432 |
|
|
end if;
|
2433 |
|
|
|
2434 |
|
|
if J.Container /= Container'Unrestricted_Access then
|
2435 |
|
|
raise Program_Error with "J cursor denotes wrong container";
|
2436 |
|
|
end if;
|
2437 |
|
|
|
2438 |
|
|
Swap (Container, I.Index, J.Index);
|
2439 |
|
|
end Swap;
|
2440 |
|
|
|
2441 |
|
|
--------------------
|
2442 |
|
|
-- To_Array_Index --
|
2443 |
|
|
--------------------
|
2444 |
|
|
|
2445 |
|
|
function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
|
2446 |
|
|
Offset : Count_Type'Base;
|
2447 |
|
|
|
2448 |
|
|
begin
|
2449 |
|
|
-- We know that
|
2450 |
|
|
-- Index >= Index_Type'First
|
2451 |
|
|
-- hence we also know that
|
2452 |
|
|
-- Index - Index_Type'First >= 0
|
2453 |
|
|
|
2454 |
|
|
-- The issue is that even though 0 is guaranteed to be a value
|
2455 |
|
|
-- in the type Index_Type'Base, there's no guarantee that the
|
2456 |
|
|
-- difference is a value in that type. To prevent overflow we
|
2457 |
|
|
-- use the wider of Count_Type'Base and Index_Type'Base to
|
2458 |
|
|
-- perform intermediate calculations.
|
2459 |
|
|
|
2460 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
2461 |
|
|
Offset := Count_Type'Base (Index - Index_Type'First);
|
2462 |
|
|
|
2463 |
|
|
else
|
2464 |
|
|
Offset := Count_Type'Base (Index) -
|
2465 |
|
|
Count_Type'Base (Index_Type'First);
|
2466 |
|
|
end if;
|
2467 |
|
|
|
2468 |
|
|
-- The array index subtype for all container element arrays
|
2469 |
|
|
-- always starts with 1.
|
2470 |
|
|
|
2471 |
|
|
return 1 + Offset;
|
2472 |
|
|
end To_Array_Index;
|
2473 |
|
|
|
2474 |
|
|
---------------
|
2475 |
|
|
-- To_Cursor --
|
2476 |
|
|
---------------
|
2477 |
|
|
|
2478 |
|
|
function To_Cursor
|
2479 |
|
|
(Container : Vector;
|
2480 |
|
|
Index : Extended_Index) return Cursor
|
2481 |
|
|
is
|
2482 |
|
|
begin
|
2483 |
|
|
if Index not in Index_Type'First .. Container.Last then
|
2484 |
|
|
return No_Element;
|
2485 |
|
|
end if;
|
2486 |
|
|
|
2487 |
|
|
return Cursor'(Container'Unrestricted_Access, Index);
|
2488 |
|
|
end To_Cursor;
|
2489 |
|
|
|
2490 |
|
|
--------------
|
2491 |
|
|
-- To_Index --
|
2492 |
|
|
--------------
|
2493 |
|
|
|
2494 |
|
|
function To_Index (Position : Cursor) return Extended_Index is
|
2495 |
|
|
begin
|
2496 |
|
|
if Position.Container = null then
|
2497 |
|
|
return No_Index;
|
2498 |
|
|
end if;
|
2499 |
|
|
|
2500 |
|
|
if Position.Index <= Position.Container.Last then
|
2501 |
|
|
return Position.Index;
|
2502 |
|
|
end if;
|
2503 |
|
|
|
2504 |
|
|
return No_Index;
|
2505 |
|
|
end To_Index;
|
2506 |
|
|
|
2507 |
|
|
---------------
|
2508 |
|
|
-- To_Vector --
|
2509 |
|
|
---------------
|
2510 |
|
|
|
2511 |
|
|
function To_Vector (Length : Count_Type) return Vector is
|
2512 |
|
|
Index : Count_Type'Base;
|
2513 |
|
|
Last : Index_Type'Base;
|
2514 |
|
|
|
2515 |
|
|
begin
|
2516 |
|
|
if Length = 0 then
|
2517 |
|
|
return Empty_Vector;
|
2518 |
|
|
end if;
|
2519 |
|
|
|
2520 |
|
|
-- We create a vector object with a capacity that matches the specified
|
2521 |
|
|
-- Length, but we do not allow the vector capacity (the length of the
|
2522 |
|
|
-- internal array) to exceed the number of values in Index_Type'Range
|
2523 |
|
|
-- (otherwise, there would be no way to refer to those components via an
|
2524 |
|
|
-- index). We must therefore check whether the specified Length would
|
2525 |
|
|
-- create a Last index value greater than Index_Type'Last.
|
2526 |
|
|
|
2527 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
2528 |
|
|
-- We perform a two-part test. First we determine whether the
|
2529 |
|
|
-- computed Last value lies in the base range of the type, and then
|
2530 |
|
|
-- determine whether it lies in the range of the index (sub)type.
|
2531 |
|
|
|
2532 |
|
|
-- Last must satisfy this relation:
|
2533 |
|
|
-- First + Length - 1 <= Last
|
2534 |
|
|
-- We regroup terms:
|
2535 |
|
|
-- First - 1 <= Last - Length
|
2536 |
|
|
-- Which can rewrite as:
|
2537 |
|
|
-- No_Index <= Last - Length
|
2538 |
|
|
|
2539 |
|
|
if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
|
2540 |
|
|
raise Constraint_Error with "Length is out of range";
|
2541 |
|
|
end if;
|
2542 |
|
|
|
2543 |
|
|
-- We now know that the computed value of Last is within the base
|
2544 |
|
|
-- range of the type, so it is safe to compute its value:
|
2545 |
|
|
|
2546 |
|
|
Last := No_Index + Index_Type'Base (Length);
|
2547 |
|
|
|
2548 |
|
|
-- Finally we test whether the value is within the range of the
|
2549 |
|
|
-- generic actual index subtype:
|
2550 |
|
|
|
2551 |
|
|
if Last > Index_Type'Last then
|
2552 |
|
|
raise Constraint_Error with "Length is out of range";
|
2553 |
|
|
end if;
|
2554 |
|
|
|
2555 |
|
|
elsif Index_Type'First <= 0 then
|
2556 |
|
|
|
2557 |
|
|
-- Here we can compute Last directly, in the normal way. We know that
|
2558 |
|
|
-- No_Index is less than 0, so there is no danger of overflow when
|
2559 |
|
|
-- adding the (positive) value of Length.
|
2560 |
|
|
|
2561 |
|
|
Index := Count_Type'Base (No_Index) + Length; -- Last
|
2562 |
|
|
|
2563 |
|
|
if Index > Count_Type'Base (Index_Type'Last) then
|
2564 |
|
|
raise Constraint_Error with "Length is out of range";
|
2565 |
|
|
end if;
|
2566 |
|
|
|
2567 |
|
|
-- We know that the computed value (having type Count_Type) of Last
|
2568 |
|
|
-- is within the range of the generic actual index subtype, so it is
|
2569 |
|
|
-- safe to convert to Index_Type:
|
2570 |
|
|
|
2571 |
|
|
Last := Index_Type'Base (Index);
|
2572 |
|
|
|
2573 |
|
|
else
|
2574 |
|
|
-- Here Index_Type'First (and Index_Type'Last) is positive, so we
|
2575 |
|
|
-- must test the length indirectly (by working backwards from the
|
2576 |
|
|
-- largest possible value of Last), in order to prevent overflow.
|
2577 |
|
|
|
2578 |
|
|
Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
|
2579 |
|
|
|
2580 |
|
|
if Index < Count_Type'Base (No_Index) then
|
2581 |
|
|
raise Constraint_Error with "Length is out of range";
|
2582 |
|
|
end if;
|
2583 |
|
|
|
2584 |
|
|
-- We have determined that the value of Length would not create a
|
2585 |
|
|
-- Last index value outside of the range of Index_Type, so we can now
|
2586 |
|
|
-- safely compute its value.
|
2587 |
|
|
|
2588 |
|
|
Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
|
2589 |
|
|
end if;
|
2590 |
|
|
|
2591 |
|
|
return V : Vector (Capacity => Length) do
|
2592 |
|
|
V.Last := Last;
|
2593 |
|
|
end return;
|
2594 |
|
|
end To_Vector;
|
2595 |
|
|
|
2596 |
|
|
function To_Vector
|
2597 |
|
|
(New_Item : Element_Type;
|
2598 |
|
|
Length : Count_Type) return Vector
|
2599 |
|
|
is
|
2600 |
|
|
Index : Count_Type'Base;
|
2601 |
|
|
Last : Index_Type'Base;
|
2602 |
|
|
|
2603 |
|
|
begin
|
2604 |
|
|
if Length = 0 then
|
2605 |
|
|
return Empty_Vector;
|
2606 |
|
|
end if;
|
2607 |
|
|
|
2608 |
|
|
-- We create a vector object with a capacity that matches the specified
|
2609 |
|
|
-- Length, but we do not allow the vector capacity (the length of the
|
2610 |
|
|
-- internal array) to exceed the number of values in Index_Type'Range
|
2611 |
|
|
-- (otherwise, there would be no way to refer to those components via an
|
2612 |
|
|
-- index). We must therefore check whether the specified Length would
|
2613 |
|
|
-- create a Last index value greater than Index_Type'Last.
|
2614 |
|
|
|
2615 |
|
|
if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
|
2616 |
|
|
|
2617 |
|
|
-- We perform a two-part test. First we determine whether the
|
2618 |
|
|
-- computed Last value lies in the base range of the type, and then
|
2619 |
|
|
-- determine whether it lies in the range of the index (sub)type.
|
2620 |
|
|
|
2621 |
|
|
-- Last must satisfy this relation:
|
2622 |
|
|
-- First + Length - 1 <= Last
|
2623 |
|
|
-- We regroup terms:
|
2624 |
|
|
-- First - 1 <= Last - Length
|
2625 |
|
|
-- Which can rewrite as:
|
2626 |
|
|
-- No_Index <= Last - Length
|
2627 |
|
|
|
2628 |
|
|
if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
|
2629 |
|
|
raise Constraint_Error with "Length is out of range";
|
2630 |
|
|
end if;
|
2631 |
|
|
|
2632 |
|
|
-- We now know that the computed value of Last is within the base
|
2633 |
|
|
-- range of the type, so it is safe to compute its value:
|
2634 |
|
|
|
2635 |
|
|
Last := No_Index + Index_Type'Base (Length);
|
2636 |
|
|
|
2637 |
|
|
-- Finally we test whether the value is within the range of the
|
2638 |
|
|
-- generic actual index subtype:
|
2639 |
|
|
|
2640 |
|
|
if Last > Index_Type'Last then
|
2641 |
|
|
raise Constraint_Error with "Length is out of range";
|
2642 |
|
|
end if;
|
2643 |
|
|
|
2644 |
|
|
elsif Index_Type'First <= 0 then
|
2645 |
|
|
|
2646 |
|
|
-- Here we can compute Last directly, in the normal way. We know that
|
2647 |
|
|
-- No_Index is less than 0, so there is no danger of overflow when
|
2648 |
|
|
-- adding the (positive) value of Length.
|
2649 |
|
|
|
2650 |
|
|
Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
|
2651 |
|
|
|
2652 |
|
|
if Index > Count_Type'Base (Index_Type'Last) then
|
2653 |
|
|
raise Constraint_Error with "Length is out of range";
|
2654 |
|
|
end if;
|
2655 |
|
|
|
2656 |
|
|
-- We know that the computed value (having type Count_Type) of Last
|
2657 |
|
|
-- is within the range of the generic actual index subtype, so it is
|
2658 |
|
|
-- safe to convert to Index_Type:
|
2659 |
|
|
|
2660 |
|
|
Last := Index_Type'Base (Index);
|
2661 |
|
|
|
2662 |
|
|
else
|
2663 |
|
|
-- Here Index_Type'First (and Index_Type'Last) is positive, so we
|
2664 |
|
|
-- must test the length indirectly (by working backwards from the
|
2665 |
|
|
-- largest possible value of Last), in order to prevent overflow.
|
2666 |
|
|
|
2667 |
|
|
Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
|
2668 |
|
|
|
2669 |
|
|
if Index < Count_Type'Base (No_Index) then
|
2670 |
|
|
raise Constraint_Error with "Length is out of range";
|
2671 |
|
|
end if;
|
2672 |
|
|
|
2673 |
|
|
-- We have determined that the value of Length would not create a
|
2674 |
|
|
-- Last index value outside of the range of Index_Type, so we can now
|
2675 |
|
|
-- safely compute its value.
|
2676 |
|
|
|
2677 |
|
|
Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
|
2678 |
|
|
end if;
|
2679 |
|
|
|
2680 |
|
|
return V : Vector (Capacity => Length) do
|
2681 |
|
|
V.Elements := (others => New_Item);
|
2682 |
|
|
V.Last := Last;
|
2683 |
|
|
end return;
|
2684 |
|
|
end To_Vector;
|
2685 |
|
|
|
2686 |
|
|
--------------------
|
2687 |
|
|
-- Update_Element --
|
2688 |
|
|
--------------------
|
2689 |
|
|
|
2690 |
|
|
procedure Update_Element
|
2691 |
|
|
(Container : in out Vector;
|
2692 |
|
|
Index : Index_Type;
|
2693 |
|
|
Process : not null access procedure (Element : in out Element_Type))
|
2694 |
|
|
is
|
2695 |
|
|
B : Natural renames Container.Busy;
|
2696 |
|
|
L : Natural renames Container.Lock;
|
2697 |
|
|
|
2698 |
|
|
begin
|
2699 |
|
|
if Index > Container.Last then
|
2700 |
|
|
raise Constraint_Error with "Index is out of range";
|
2701 |
|
|
end if;
|
2702 |
|
|
|
2703 |
|
|
B := B + 1;
|
2704 |
|
|
L := L + 1;
|
2705 |
|
|
|
2706 |
|
|
begin
|
2707 |
|
|
Process (Container.Elements (To_Array_Index (Index)));
|
2708 |
|
|
exception
|
2709 |
|
|
when others =>
|
2710 |
|
|
L := L - 1;
|
2711 |
|
|
B := B - 1;
|
2712 |
|
|
raise;
|
2713 |
|
|
end;
|
2714 |
|
|
|
2715 |
|
|
L := L - 1;
|
2716 |
|
|
B := B - 1;
|
2717 |
|
|
end Update_Element;
|
2718 |
|
|
|
2719 |
|
|
procedure Update_Element
|
2720 |
|
|
(Container : in out Vector;
|
2721 |
|
|
Position : Cursor;
|
2722 |
|
|
Process : not null access procedure (Element : in out Element_Type))
|
2723 |
|
|
is
|
2724 |
|
|
begin
|
2725 |
|
|
if Position.Container = null then
|
2726 |
|
|
raise Constraint_Error with "Position cursor has no element";
|
2727 |
|
|
end if;
|
2728 |
|
|
|
2729 |
|
|
if Position.Container /= Container'Unrestricted_Access then
|
2730 |
|
|
raise Program_Error with "Position cursor denotes wrong container";
|
2731 |
|
|
end if;
|
2732 |
|
|
|
2733 |
|
|
Update_Element (Container, Position.Index, Process);
|
2734 |
|
|
end Update_Element;
|
2735 |
|
|
|
2736 |
|
|
-----------
|
2737 |
|
|
-- Write --
|
2738 |
|
|
-----------
|
2739 |
|
|
|
2740 |
|
|
procedure Write
|
2741 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2742 |
|
|
Container : Vector)
|
2743 |
|
|
is
|
2744 |
|
|
N : Count_Type;
|
2745 |
|
|
|
2746 |
|
|
begin
|
2747 |
|
|
N := Container.Length;
|
2748 |
|
|
Count_Type'Base'Write (Stream, N);
|
2749 |
|
|
|
2750 |
|
|
for J in 1 .. N loop
|
2751 |
|
|
Element_Type'Write (Stream, Container.Elements (J));
|
2752 |
|
|
end loop;
|
2753 |
|
|
end Write;
|
2754 |
|
|
|
2755 |
|
|
procedure Write
|
2756 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2757 |
|
|
Position : Cursor)
|
2758 |
|
|
is
|
2759 |
|
|
begin
|
2760 |
|
|
raise Program_Error with "attempt to stream vector cursor";
|
2761 |
|
|
end Write;
|
2762 |
|
|
|
2763 |
|
|
procedure Write
|
2764 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2765 |
|
|
Item : Reference_Type)
|
2766 |
|
|
is
|
2767 |
|
|
begin
|
2768 |
|
|
raise Program_Error with "attempt to stream reference";
|
2769 |
|
|
end Write;
|
2770 |
|
|
|
2771 |
|
|
procedure Write
|
2772 |
|
|
(Stream : not null access Root_Stream_Type'Class;
|
2773 |
|
|
Item : Constant_Reference_Type)
|
2774 |
|
|
is
|
2775 |
|
|
begin
|
2776 |
|
|
raise Program_Error with "attempt to stream reference";
|
2777 |
|
|
end Write;
|
2778 |
|
|
|
2779 |
|
|
end Ada.Containers.Bounded_Vectors;
|