111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
4 -- --
|
|
5 -- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
145
|
9 -- Copyright (C) 2004-2019, Free Software Foundation, Inc. --
|
111
|
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.Unchecked_Deallocation;
|
|
32
|
|
33 with System; use type System.Address;
|
|
34
|
|
35 package body Ada.Containers.Indefinite_Vectors is
|
|
36
|
|
37 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
38 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
39 -- See comment in Ada.Containers.Helpers
|
|
40
|
|
41 procedure Free is
|
|
42 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
|
|
43
|
|
44 procedure Free is
|
|
45 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
|
|
46
|
|
47 procedure Append_Slow_Path
|
|
48 (Container : in out Vector;
|
|
49 New_Item : Element_Type;
|
|
50 Count : Count_Type);
|
|
51 -- This is the slow path for Append. This is split out to minimize the size
|
|
52 -- of Append, because we have Inline (Append).
|
|
53
|
|
54 ---------
|
|
55 -- "&" --
|
|
56 ---------
|
|
57
|
|
58 -- We decide that the capacity of the result of "&" is the minimum needed
|
|
59 -- -- the sum of the lengths of the vector parameters. We could decide to
|
|
60 -- make it larger, but we have no basis for knowing how much larger, so we
|
|
61 -- just allocate the minimum amount of storage.
|
|
62
|
|
63 function "&" (Left, Right : Vector) return Vector is
|
|
64 begin
|
|
65 return Result : Vector do
|
|
66 Reserve_Capacity (Result, Length (Left) + Length (Right));
|
|
67 Append (Result, Left);
|
|
68 Append (Result, Right);
|
|
69 end return;
|
|
70 end "&";
|
|
71
|
|
72 function "&" (Left : Vector; Right : Element_Type) return Vector is
|
|
73 begin
|
|
74 return Result : Vector do
|
|
75 Reserve_Capacity (Result, Length (Left) + 1);
|
|
76 Append (Result, Left);
|
|
77 Append (Result, Right);
|
|
78 end return;
|
|
79 end "&";
|
|
80
|
|
81 function "&" (Left : Element_Type; Right : Vector) return Vector is
|
|
82 begin
|
|
83 return Result : Vector do
|
|
84 Reserve_Capacity (Result, 1 + Length (Right));
|
|
85 Append (Result, Left);
|
|
86 Append (Result, Right);
|
|
87 end return;
|
|
88 end "&";
|
|
89
|
|
90 function "&" (Left, Right : Element_Type) return Vector is
|
|
91 begin
|
|
92 return Result : Vector do
|
|
93 Reserve_Capacity (Result, 1 + 1);
|
|
94 Append (Result, Left);
|
|
95 Append (Result, Right);
|
|
96 end return;
|
|
97 end "&";
|
|
98
|
|
99 ---------
|
|
100 -- "=" --
|
|
101 ---------
|
|
102
|
|
103 overriding function "=" (Left, Right : Vector) return Boolean is
|
|
104 begin
|
|
105 if Left.Last /= Right.Last then
|
|
106 return False;
|
|
107 end if;
|
|
108
|
|
109 if Left.Length = 0 then
|
|
110 return True;
|
|
111 end if;
|
|
112
|
|
113 declare
|
|
114 -- Per AI05-0022, the container implementation is required to detect
|
|
115 -- element tampering by a generic actual subprogram.
|
|
116
|
|
117 Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
|
|
118 Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
|
|
119 begin
|
|
120 for J in Index_Type range Index_Type'First .. Left.Last loop
|
|
121 if Left.Elements.EA (J) = null then
|
|
122 if Right.Elements.EA (J) /= null then
|
|
123 return False;
|
|
124 end if;
|
|
125
|
|
126 elsif Right.Elements.EA (J) = null then
|
|
127 return False;
|
|
128
|
|
129 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
|
|
130 return False;
|
|
131 end if;
|
|
132 end loop;
|
|
133 end;
|
|
134
|
|
135 return True;
|
|
136 end "=";
|
|
137
|
|
138 ------------
|
|
139 -- Adjust --
|
|
140 ------------
|
|
141
|
|
142 procedure Adjust (Container : in out Vector) is
|
|
143 begin
|
|
144 -- If the counts are nonzero, execution is technically erroneous, but
|
|
145 -- it seems friendly to allow things like concurrent "=" on shared
|
|
146 -- constants.
|
|
147
|
|
148 Zero_Counts (Container.TC);
|
|
149
|
|
150 if Container.Last = No_Index then
|
|
151 Container.Elements := null;
|
|
152 return;
|
|
153 end if;
|
|
154
|
|
155 declare
|
|
156 L : constant Index_Type := Container.Last;
|
|
157 E : Elements_Array renames
|
|
158 Container.Elements.EA (Index_Type'First .. L);
|
|
159
|
|
160 begin
|
|
161 Container.Elements := null;
|
|
162 Container.Last := No_Index;
|
|
163
|
|
164 Container.Elements := new Elements_Type (L);
|
|
165
|
|
166 for J in E'Range loop
|
|
167 if E (J) /= null then
|
|
168 Container.Elements.EA (J) := new Element_Type'(E (J).all);
|
|
169 end if;
|
|
170
|
|
171 Container.Last := J;
|
|
172 end loop;
|
|
173 end;
|
|
174 end Adjust;
|
|
175
|
|
176 ------------
|
|
177 -- Append --
|
|
178 ------------
|
|
179
|
|
180 procedure Append (Container : in out Vector; New_Item : Vector) is
|
|
181 begin
|
|
182 if Is_Empty (New_Item) then
|
|
183 return;
|
|
184 elsif Checks and then Container.Last = Index_Type'Last then
|
|
185 raise Constraint_Error with "vector is already at its maximum length";
|
|
186 else
|
|
187 Insert (Container, Container.Last + 1, New_Item);
|
|
188 end if;
|
|
189 end Append;
|
|
190
|
|
191 procedure Append
|
|
192 (Container : in out Vector;
|
|
193 New_Item : Element_Type;
|
|
194 Count : Count_Type := 1)
|
|
195 is
|
|
196 begin
|
|
197 -- In the general case, we pass the buck to Insert, but for efficiency,
|
|
198 -- we check for the usual case where Count = 1 and the vector has enough
|
|
199 -- room for at least one more element.
|
|
200
|
|
201 if Count = 1
|
|
202 and then Container.Elements /= null
|
|
203 and then Container.Last /= Container.Elements.Last
|
|
204 then
|
|
205 TC_Check (Container.TC);
|
|
206
|
|
207 -- Increment Container.Last after assigning the New_Item, so we
|
|
208 -- leave the Container unmodified in case Finalize/Adjust raises
|
|
209 -- an exception.
|
|
210
|
|
211 declare
|
|
212 New_Last : constant Index_Type := Container.Last + 1;
|
|
213
|
|
214 -- The element allocator may need an accessibility check in the
|
|
215 -- case actual type is class-wide or has access discriminants
|
|
216 -- (see RM 4.8(10.1) and AI12-0035).
|
|
217
|
|
218 pragma Unsuppress (Accessibility_Check);
|
|
219 begin
|
|
220 Container.Elements.EA (New_Last) := new Element_Type'(New_Item);
|
|
221 Container.Last := New_Last;
|
|
222 end;
|
|
223
|
|
224 else
|
|
225 Append_Slow_Path (Container, New_Item, Count);
|
|
226 end if;
|
|
227 end Append;
|
|
228
|
|
229 ----------------------
|
|
230 -- Append_Slow_Path --
|
|
231 ----------------------
|
|
232
|
|
233 procedure Append_Slow_Path
|
|
234 (Container : in out Vector;
|
|
235 New_Item : Element_Type;
|
|
236 Count : Count_Type)
|
|
237 is
|
|
238 begin
|
|
239 if Count = 0 then
|
|
240 return;
|
|
241 elsif Checks and then Container.Last = Index_Type'Last then
|
|
242 raise Constraint_Error with "vector is already at its maximum length";
|
|
243 else
|
|
244 Insert (Container, Container.Last + 1, New_Item, Count);
|
|
245 end if;
|
|
246 end Append_Slow_Path;
|
|
247
|
|
248 ------------
|
|
249 -- Assign --
|
|
250 ------------
|
|
251
|
|
252 procedure Assign (Target : in out Vector; Source : Vector) is
|
|
253 begin
|
|
254 if Target'Address = Source'Address then
|
|
255 return;
|
|
256 else
|
|
257 Target.Clear;
|
|
258 Target.Append (Source);
|
|
259 end if;
|
|
260 end Assign;
|
|
261
|
|
262 --------------
|
|
263 -- Capacity --
|
|
264 --------------
|
|
265
|
|
266 function Capacity (Container : Vector) return Count_Type is
|
|
267 begin
|
|
268 if Container.Elements = null then
|
|
269 return 0;
|
|
270 else
|
|
271 return Container.Elements.EA'Length;
|
|
272 end if;
|
|
273 end Capacity;
|
|
274
|
|
275 -----------
|
|
276 -- Clear --
|
|
277 -----------
|
|
278
|
|
279 procedure Clear (Container : in out Vector) is
|
|
280 begin
|
|
281 TC_Check (Container.TC);
|
|
282
|
|
283 while Container.Last >= Index_Type'First loop
|
|
284 declare
|
|
285 X : Element_Access := Container.Elements.EA (Container.Last);
|
|
286 begin
|
|
287 Container.Elements.EA (Container.Last) := null;
|
|
288 Container.Last := Container.Last - 1;
|
|
289 Free (X);
|
|
290 end;
|
|
291 end loop;
|
|
292 end Clear;
|
|
293
|
|
294 ------------------------
|
|
295 -- Constant_Reference --
|
|
296 ------------------------
|
|
297
|
|
298 function Constant_Reference
|
|
299 (Container : aliased Vector;
|
|
300 Position : Cursor) return Constant_Reference_Type
|
|
301 is
|
|
302 begin
|
|
303 if Checks then
|
|
304 if Position.Container = null then
|
|
305 raise Constraint_Error with "Position cursor has no element";
|
|
306 end if;
|
|
307
|
|
308 if Position.Container /= Container'Unrestricted_Access then
|
|
309 raise Program_Error with "Position cursor denotes wrong container";
|
|
310 end if;
|
|
311
|
|
312 if Position.Index > Position.Container.Last then
|
|
313 raise Constraint_Error with "Position cursor is out of range";
|
|
314 end if;
|
|
315 end if;
|
|
316
|
|
317 declare
|
|
318 TC : constant Tamper_Counts_Access :=
|
|
319 Container.TC'Unrestricted_Access;
|
|
320 begin
|
|
321 -- The following will raise Constraint_Error if Element is null
|
|
322
|
|
323 return R : constant Constant_Reference_Type :=
|
|
324 (Element => Container.Elements.EA (Position.Index),
|
|
325 Control => (Controlled with TC))
|
|
326 do
|
145
|
327 Busy (TC.all);
|
111
|
328 end return;
|
|
329 end;
|
|
330 end Constant_Reference;
|
|
331
|
|
332 function Constant_Reference
|
|
333 (Container : aliased Vector;
|
|
334 Index : Index_Type) return Constant_Reference_Type
|
|
335 is
|
|
336 begin
|
|
337 if Checks and then Index > Container.Last then
|
|
338 raise Constraint_Error with "Index is out of range";
|
|
339 end if;
|
|
340
|
|
341 declare
|
|
342 TC : constant Tamper_Counts_Access :=
|
|
343 Container.TC'Unrestricted_Access;
|
|
344 begin
|
|
345 -- The following will raise Constraint_Error if Element is null
|
|
346
|
|
347 return R : constant Constant_Reference_Type :=
|
|
348 (Element => Container.Elements.EA (Index),
|
|
349 Control => (Controlled with TC))
|
|
350 do
|
145
|
351 Busy (TC.all);
|
111
|
352 end return;
|
|
353 end;
|
|
354 end Constant_Reference;
|
|
355
|
|
356 --------------
|
|
357 -- Contains --
|
|
358 --------------
|
|
359
|
|
360 function Contains
|
|
361 (Container : Vector;
|
|
362 Item : Element_Type) return Boolean
|
|
363 is
|
|
364 begin
|
|
365 return Find_Index (Container, Item) /= No_Index;
|
|
366 end Contains;
|
|
367
|
|
368 ----------
|
|
369 -- Copy --
|
|
370 ----------
|
|
371
|
|
372 function Copy
|
|
373 (Source : Vector;
|
|
374 Capacity : Count_Type := 0) return Vector
|
|
375 is
|
|
376 C : Count_Type;
|
|
377
|
|
378 begin
|
|
379 if Capacity < Source.Length then
|
|
380 if Checks and then Capacity /= 0 then
|
|
381 raise Capacity_Error
|
|
382 with "Requested capacity is less than Source length";
|
|
383 end if;
|
|
384
|
|
385 C := Source.Length;
|
|
386 else
|
|
387 C := Capacity;
|
|
388 end if;
|
|
389
|
|
390 return Target : Vector do
|
|
391 Target.Reserve_Capacity (C);
|
|
392 Target.Assign (Source);
|
|
393 end return;
|
|
394 end Copy;
|
|
395
|
|
396 ------------
|
|
397 -- Delete --
|
|
398 ------------
|
|
399
|
|
400 procedure Delete
|
|
401 (Container : in out Vector;
|
|
402 Index : Extended_Index;
|
|
403 Count : Count_Type := 1)
|
|
404 is
|
|
405 Old_Last : constant Index_Type'Base := Container.Last;
|
|
406 New_Last : Index_Type'Base;
|
|
407 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
|
|
408 J : Index_Type'Base; -- first index of items that slide down
|
|
409
|
|
410 begin
|
|
411 -- Delete removes items from the vector, the number of which is the
|
|
412 -- minimum of the specified Count and the items (if any) that exist from
|
|
413 -- Index to Container.Last. There are no constraints on the specified
|
|
414 -- value of Count (it can be larger than what's available at this
|
|
415 -- position in the vector, for example), but there are constraints on
|
|
416 -- the allowed values of the Index.
|
|
417
|
|
418 -- As a precondition on the generic actual Index_Type, the base type
|
|
419 -- must include Index_Type'Pred (Index_Type'First); this is the value
|
|
420 -- that Container.Last assumes when the vector is empty. However, we do
|
|
421 -- not allow that as the value for Index when specifying which items
|
|
422 -- should be deleted, so we must manually check. (That the user is
|
|
423 -- allowed to specify the value at all here is a consequence of the
|
|
424 -- declaration of the Extended_Index subtype, which includes the values
|
|
425 -- in the base range that immediately precede and immediately follow the
|
|
426 -- values in the Index_Type.)
|
|
427
|
|
428 if Checks and then Index < Index_Type'First then
|
|
429 raise Constraint_Error with "Index is out of range (too small)";
|
|
430 end if;
|
|
431
|
|
432 -- We do allow a value greater than Container.Last to be specified as
|
|
433 -- the Index, but only if it's immediately greater. This allows the
|
|
434 -- corner case of deleting no items from the back end of the vector to
|
|
435 -- be treated as a no-op. (It is assumed that specifying an index value
|
|
436 -- greater than Last + 1 indicates some deeper flaw in the caller's
|
|
437 -- algorithm, so that case is treated as a proper error.)
|
|
438
|
|
439 if Index > Old_Last then
|
|
440 if Checks and then Index > Old_Last + 1 then
|
|
441 raise Constraint_Error with "Index is out of range (too large)";
|
|
442 else
|
|
443 return;
|
|
444 end if;
|
|
445 end if;
|
|
446
|
|
447 -- Here and elsewhere we treat deleting 0 items from the container as a
|
|
448 -- no-op, even when the container is busy, so we simply return.
|
|
449
|
|
450 if Count = 0 then
|
|
451 return;
|
|
452 end if;
|
|
453
|
|
454 -- The internal elements array isn't guaranteed to exist unless we have
|
|
455 -- elements, so we handle that case here in order to avoid having to
|
|
456 -- check it later. (Note that an empty vector can never be busy, so
|
|
457 -- there's no semantic harm in returning early.)
|
|
458
|
|
459 if Container.Is_Empty then
|
|
460 return;
|
|
461 end if;
|
|
462
|
|
463 -- The tampering bits exist to prevent an item from being deleted (or
|
|
464 -- otherwise harmfully manipulated) while it is being visited. Query,
|
|
465 -- Update, and Iterate increment the busy count on entry, and decrement
|
|
466 -- the count on exit. Delete checks the count to determine whether it is
|
|
467 -- being called while the associated callback procedure is executing.
|
|
468
|
|
469 TC_Check (Container.TC);
|
|
470
|
|
471 -- We first calculate what's available for deletion starting at
|
|
472 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
|
|
473 -- Count_Type'Base as the type for intermediate values. (See function
|
|
474 -- Length for more information.)
|
|
475
|
|
476 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
|
|
477 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
|
|
478 else
|
|
479 Count2 := Count_Type'Base (Old_Last - Index + 1);
|
|
480 end if;
|
|
481
|
|
482 -- If the number of elements requested (Count) for deletion is equal to
|
|
483 -- (or greater than) the number of elements available (Count2) for
|
|
484 -- deletion beginning at Index, then everything from Index to
|
|
485 -- Container.Last is deleted (this is equivalent to Delete_Last).
|
|
486
|
|
487 if Count >= Count2 then
|
|
488 -- Elements in an indefinite vector are allocated, so we must iterate
|
|
489 -- over the loop and deallocate elements one-at-a-time. We work from
|
|
490 -- back to front, deleting the last element during each pass, in
|
|
491 -- order to gracefully handle deallocation failures.
|
|
492
|
|
493 declare
|
|
494 EA : Elements_Array renames Container.Elements.EA;
|
|
495
|
|
496 begin
|
|
497 while Container.Last >= Index loop
|
|
498 declare
|
|
499 K : constant Index_Type := Container.Last;
|
|
500 X : Element_Access := EA (K);
|
|
501
|
|
502 begin
|
|
503 -- We first isolate the element we're deleting, removing it
|
|
504 -- from the vector before we attempt to deallocate it, in
|
|
505 -- case the deallocation fails.
|
|
506
|
|
507 EA (K) := null;
|
|
508 Container.Last := K - 1;
|
|
509
|
|
510 -- Container invariants have been restored, so it is now
|
|
511 -- safe to attempt to deallocate the element.
|
|
512
|
|
513 Free (X);
|
|
514 end;
|
|
515 end loop;
|
|
516 end;
|
|
517
|
|
518 return;
|
|
519 end if;
|
|
520
|
|
521 -- There are some elements that aren't being deleted (the requested
|
|
522 -- count was less than the available count), so we must slide them down
|
|
523 -- to Index. We first calculate the index values of the respective array
|
|
524 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
|
|
525 -- type for intermediate calculations. For the elements that slide down,
|
|
526 -- index value New_Last is the last index value of their new home, and
|
|
527 -- index value J is the first index of their old home.
|
|
528
|
|
529 if Index_Type'Base'Last >= Count_Type_Last then
|
|
530 New_Last := Old_Last - Index_Type'Base (Count);
|
|
531 J := Index + Index_Type'Base (Count);
|
|
532 else
|
|
533 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
|
|
534 J := Index_Type'Base (Count_Type'Base (Index) + Count);
|
|
535 end if;
|
|
536
|
|
537 -- The internal elements array isn't guaranteed to exist unless we have
|
|
538 -- elements, but we have that guarantee here because we know we have
|
|
539 -- elements to slide. The array index values for each slice have
|
|
540 -- already been determined, so what remains to be done is to first
|
|
541 -- deallocate the elements that are being deleted, and then slide down
|
|
542 -- to Index the elements that aren't being deleted.
|
|
543
|
|
544 declare
|
|
545 EA : Elements_Array renames Container.Elements.EA;
|
|
546
|
|
547 begin
|
|
548 -- Before we can slide down the elements that aren't being deleted,
|
|
549 -- we need to deallocate the elements that are being deleted.
|
|
550
|
|
551 for K in Index .. J - 1 loop
|
|
552 declare
|
|
553 X : Element_Access := EA (K);
|
|
554
|
|
555 begin
|
|
556 -- First we remove the element we're about to deallocate from
|
|
557 -- the vector, in case the deallocation fails, in order to
|
|
558 -- preserve representation invariants.
|
|
559
|
|
560 EA (K) := null;
|
|
561
|
|
562 -- The element has been removed from the vector, so it is now
|
|
563 -- safe to attempt to deallocate it.
|
|
564
|
|
565 Free (X);
|
|
566 end;
|
|
567 end loop;
|
|
568
|
|
569 EA (Index .. New_Last) := EA (J .. Old_Last);
|
|
570 Container.Last := New_Last;
|
|
571 end;
|
|
572 end Delete;
|
|
573
|
|
574 procedure Delete
|
|
575 (Container : in out Vector;
|
|
576 Position : in out Cursor;
|
|
577 Count : Count_Type := 1)
|
|
578 is
|
|
579 begin
|
|
580 if Checks then
|
|
581 if Position.Container = null then
|
|
582 raise Constraint_Error with "Position cursor has no element";
|
|
583
|
|
584 elsif Position.Container /= Container'Unrestricted_Access then
|
|
585 raise Program_Error with "Position cursor denotes wrong container";
|
|
586
|
|
587 elsif Position.Index > Container.Last then
|
|
588 raise Program_Error with "Position index is out of range";
|
|
589 end if;
|
|
590 end if;
|
|
591
|
|
592 Delete (Container, Position.Index, Count);
|
|
593 Position := No_Element;
|
|
594 end Delete;
|
|
595
|
|
596 ------------------
|
|
597 -- Delete_First --
|
|
598 ------------------
|
|
599
|
|
600 procedure Delete_First
|
|
601 (Container : in out Vector;
|
|
602 Count : Count_Type := 1)
|
|
603 is
|
|
604 begin
|
|
605 if Count = 0 then
|
|
606 return;
|
|
607
|
|
608 elsif Count >= Length (Container) then
|
|
609 Clear (Container);
|
|
610 return;
|
|
611
|
|
612 else
|
|
613 Delete (Container, Index_Type'First, Count);
|
|
614 end if;
|
|
615 end Delete_First;
|
|
616
|
|
617 -----------------
|
|
618 -- Delete_Last --
|
|
619 -----------------
|
|
620
|
|
621 procedure Delete_Last
|
|
622 (Container : in out Vector;
|
|
623 Count : Count_Type := 1)
|
|
624 is
|
|
625 begin
|
|
626 -- It is not permitted to delete items while the container is busy (for
|
|
627 -- example, we're in the middle of a passive iteration). However, we
|
|
628 -- always treat deleting 0 items as a no-op, even when we're busy, so we
|
|
629 -- simply return without checking.
|
|
630
|
|
631 if Count = 0 then
|
|
632 return;
|
|
633 end if;
|
|
634
|
|
635 -- We cannot simply subsume the empty case into the loop below (the loop
|
|
636 -- would iterate 0 times), because we rename the internal array object
|
|
637 -- (which is allocated), but an empty vector isn't guaranteed to have
|
|
638 -- actually allocated an array. (Note that an empty vector can never be
|
|
639 -- busy, so there's no semantic harm in returning early here.)
|
|
640
|
|
641 if Container.Is_Empty then
|
|
642 return;
|
|
643 end if;
|
|
644
|
|
645 -- The tampering bits exist to prevent an item from being deleted (or
|
|
646 -- otherwise harmfully manipulated) while it is being visited. Query,
|
|
647 -- Update, and Iterate increment the busy count on entry, and decrement
|
|
648 -- the count on exit. Delete_Last checks the count to determine whether
|
|
649 -- it is being called while the associated callback procedure is
|
|
650 -- executing.
|
|
651
|
|
652 TC_Check (Container.TC);
|
|
653
|
|
654 -- Elements in an indefinite vector are allocated, so we must iterate
|
|
655 -- over the loop and deallocate elements one-at-a-time. We work from
|
|
656 -- back to front, deleting the last element during each pass, in order
|
|
657 -- to gracefully handle deallocation failures.
|
|
658
|
|
659 declare
|
|
660 E : Elements_Array renames Container.Elements.EA;
|
|
661
|
|
662 begin
|
|
663 for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop
|
|
664 declare
|
|
665 J : constant Index_Type := Container.Last;
|
|
666 X : Element_Access := E (J);
|
|
667
|
|
668 begin
|
|
669 -- Note that we first isolate the element we're deleting,
|
|
670 -- removing it from the vector, before we actually deallocate
|
|
671 -- it, in order to preserve representation invariants even if
|
|
672 -- the deallocation fails.
|
|
673
|
|
674 E (J) := null;
|
|
675 Container.Last := J - 1;
|
|
676
|
|
677 -- Container invariants have been restored, so it is now safe
|
|
678 -- to deallocate the element.
|
|
679
|
|
680 Free (X);
|
|
681 end;
|
|
682 end loop;
|
|
683 end;
|
|
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 Checks and then Index > Container.Last then
|
|
696 raise Constraint_Error with "Index is out of range";
|
|
697 end if;
|
|
698
|
|
699 declare
|
|
700 EA : constant Element_Access := Container.Elements.EA (Index);
|
|
701 begin
|
|
702 if Checks and then EA = null then
|
|
703 raise Constraint_Error with "element is empty";
|
|
704 else
|
|
705 return EA.all;
|
|
706 end if;
|
|
707 end;
|
|
708 end Element;
|
|
709
|
|
710 function Element (Position : Cursor) return Element_Type is
|
|
711 begin
|
|
712 if Checks then
|
|
713 if Position.Container = null then
|
|
714 raise Constraint_Error with "Position cursor has no element";
|
|
715 end if;
|
|
716
|
|
717 if Position.Index > Position.Container.Last then
|
|
718 raise Constraint_Error with "Position cursor is out of range";
|
|
719 end if;
|
|
720 end if;
|
|
721
|
|
722 declare
|
|
723 EA : constant Element_Access :=
|
|
724 Position.Container.Elements.EA (Position.Index);
|
|
725 begin
|
|
726 if Checks and then EA = null then
|
|
727 raise Constraint_Error with "element is empty";
|
|
728 else
|
|
729 return EA.all;
|
|
730 end if;
|
|
731 end;
|
|
732 end Element;
|
|
733
|
|
734 --------------
|
|
735 -- Finalize --
|
|
736 --------------
|
|
737
|
|
738 procedure Finalize (Container : in out Vector) is
|
|
739 begin
|
|
740 Clear (Container); -- Checks busy-bit
|
|
741
|
|
742 declare
|
|
743 X : Elements_Access := Container.Elements;
|
|
744 begin
|
|
745 Container.Elements := null;
|
|
746 Free (X);
|
|
747 end;
|
|
748 end Finalize;
|
|
749
|
|
750 procedure Finalize (Object : in out Iterator) is
|
|
751 begin
|
|
752 Unbusy (Object.Container.TC);
|
|
753 end Finalize;
|
|
754
|
|
755 ----------
|
|
756 -- Find --
|
|
757 ----------
|
|
758
|
|
759 function Find
|
|
760 (Container : Vector;
|
|
761 Item : Element_Type;
|
|
762 Position : Cursor := No_Element) return Cursor
|
|
763 is
|
|
764 begin
|
|
765 if Checks and then Position.Container /= null then
|
|
766 if Position.Container /= Container'Unrestricted_Access then
|
|
767 raise Program_Error with "Position cursor denotes wrong container";
|
|
768 end if;
|
|
769
|
|
770 if Position.Index > Container.Last then
|
|
771 raise Program_Error with "Position index is out of range";
|
|
772 end if;
|
|
773 end if;
|
|
774
|
|
775 -- Per AI05-0022, the container implementation is required to detect
|
|
776 -- element tampering by a generic actual subprogram.
|
|
777
|
|
778 declare
|
|
779 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
780 begin
|
|
781 for J in Position.Index .. Container.Last loop
|
|
782 if Container.Elements.EA (J).all = Item then
|
|
783 return Cursor'(Container'Unrestricted_Access, J);
|
|
784 end if;
|
|
785 end loop;
|
|
786
|
|
787 return No_Element;
|
|
788 end;
|
|
789 end Find;
|
|
790
|
|
791 ----------------
|
|
792 -- Find_Index --
|
|
793 ----------------
|
|
794
|
|
795 function Find_Index
|
|
796 (Container : Vector;
|
|
797 Item : Element_Type;
|
|
798 Index : Index_Type := Index_Type'First) return Extended_Index
|
|
799 is
|
|
800 -- Per AI05-0022, the container implementation is required to detect
|
|
801 -- element tampering by a generic actual subprogram.
|
|
802
|
|
803 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
804 begin
|
|
805 for Indx in Index .. Container.Last loop
|
|
806 if Container.Elements.EA (Indx).all = Item then
|
|
807 return Indx;
|
|
808 end if;
|
|
809 end loop;
|
|
810
|
|
811 return No_Index;
|
|
812 end Find_Index;
|
|
813
|
|
814 -----------
|
|
815 -- First --
|
|
816 -----------
|
|
817
|
|
818 function First (Container : Vector) return Cursor is
|
|
819 begin
|
|
820 if Is_Empty (Container) then
|
|
821 return No_Element;
|
|
822 end if;
|
|
823
|
|
824 return (Container'Unrestricted_Access, Index_Type'First);
|
|
825 end First;
|
|
826
|
|
827 function First (Object : Iterator) return Cursor is
|
|
828 begin
|
|
829 -- The value of the iterator object's Index component influences the
|
|
830 -- behavior of the First (and Last) selector function.
|
|
831
|
|
832 -- When the Index component is No_Index, this means the iterator
|
|
833 -- object was constructed without a start expression, in which case the
|
|
834 -- (forward) iteration starts from the (logical) beginning of the entire
|
|
835 -- sequence of items (corresponding to Container.First, for a forward
|
|
836 -- iterator).
|
|
837
|
|
838 -- Otherwise, this is iteration over a partial sequence of items.
|
|
839 -- When the Index component isn't No_Index, the iterator object was
|
|
840 -- constructed with a start expression, that specifies the position
|
|
841 -- from which the (forward) partial iteration begins.
|
|
842
|
|
843 if Object.Index = No_Index then
|
|
844 return First (Object.Container.all);
|
|
845 else
|
|
846 return Cursor'(Object.Container, Object.Index);
|
|
847 end if;
|
|
848 end First;
|
|
849
|
|
850 -------------------
|
|
851 -- First_Element --
|
|
852 -------------------
|
|
853
|
|
854 function First_Element (Container : Vector) return Element_Type is
|
|
855 begin
|
|
856 if Checks and then Container.Last = No_Index then
|
|
857 raise Constraint_Error with "Container is empty";
|
|
858 end if;
|
|
859
|
|
860 declare
|
|
861 EA : constant Element_Access :=
|
|
862 Container.Elements.EA (Index_Type'First);
|
|
863 begin
|
|
864 if Checks and then EA = null then
|
|
865 raise Constraint_Error with "first element is empty";
|
|
866 else
|
|
867 return EA.all;
|
|
868 end if;
|
|
869 end;
|
|
870 end First_Element;
|
|
871
|
|
872 -----------------
|
|
873 -- First_Index --
|
|
874 -----------------
|
|
875
|
|
876 function First_Index (Container : Vector) return Index_Type is
|
|
877 pragma Unreferenced (Container);
|
|
878 begin
|
|
879 return Index_Type'First;
|
|
880 end First_Index;
|
|
881
|
|
882 ---------------------
|
|
883 -- Generic_Sorting --
|
|
884 ---------------------
|
|
885
|
|
886 package body Generic_Sorting is
|
|
887
|
|
888 -----------------------
|
|
889 -- Local Subprograms --
|
|
890 -----------------------
|
|
891
|
|
892 function Is_Less (L, R : Element_Access) return Boolean;
|
|
893 pragma Inline (Is_Less);
|
|
894
|
|
895 -------------
|
|
896 -- Is_Less --
|
|
897 -------------
|
|
898
|
|
899 function Is_Less (L, R : Element_Access) return Boolean is
|
|
900 begin
|
|
901 if L = null then
|
|
902 return R /= null;
|
|
903 elsif R = null then
|
|
904 return False;
|
|
905 else
|
|
906 return L.all < R.all;
|
|
907 end if;
|
|
908 end Is_Less;
|
|
909
|
|
910 ---------------
|
|
911 -- Is_Sorted --
|
|
912 ---------------
|
|
913
|
|
914 function Is_Sorted (Container : Vector) return Boolean is
|
|
915 begin
|
|
916 if Container.Last <= Index_Type'First then
|
|
917 return True;
|
|
918 end if;
|
|
919
|
|
920 -- Per AI05-0022, the container implementation is required to detect
|
|
921 -- element tampering by a generic actual subprogram.
|
|
922
|
|
923 declare
|
|
924 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
925 E : Elements_Array renames Container.Elements.EA;
|
|
926 begin
|
|
927 for J in Index_Type'First .. Container.Last - 1 loop
|
|
928 if Is_Less (E (J + 1), E (J)) then
|
|
929 return False;
|
|
930 end if;
|
|
931 end loop;
|
|
932
|
|
933 return True;
|
|
934 end;
|
|
935 end Is_Sorted;
|
|
936
|
|
937 -----------
|
|
938 -- Merge --
|
|
939 -----------
|
|
940
|
|
941 procedure Merge (Target, Source : in out Vector) is
|
|
942 I, J : Index_Type'Base;
|
|
943
|
|
944 begin
|
|
945 -- The semantics of Merge changed slightly per AI05-0021. It was
|
|
946 -- originally the case that if Target and Source denoted the same
|
|
947 -- container object, then the GNAT implementation of Merge did
|
|
948 -- nothing. However, it was argued that RM05 did not precisely
|
|
949 -- specify the semantics for this corner case. The decision of the
|
|
950 -- ARG was that if Target and Source denote the same non-empty
|
|
951 -- container object, then Program_Error is raised.
|
|
952
|
|
953 if Source.Last < Index_Type'First then -- Source is empty
|
|
954 return;
|
|
955 end if;
|
|
956
|
|
957 if Checks and then Target'Address = Source'Address then
|
|
958 raise Program_Error with
|
|
959 "Target and Source denote same non-empty container";
|
|
960 end if;
|
|
961
|
|
962 if Target.Last < Index_Type'First then -- Target is empty
|
|
963 Move (Target => Target, Source => Source);
|
|
964 return;
|
|
965 end if;
|
|
966
|
|
967 TC_Check (Source.TC);
|
|
968
|
|
969 I := Target.Last; -- original value (before Set_Length)
|
|
970 Target.Set_Length (Length (Target) + Length (Source));
|
|
971
|
|
972 -- Per AI05-0022, the container implementation is required to detect
|
|
973 -- element tampering by a generic actual subprogram.
|
|
974
|
|
975 declare
|
|
976 TA : Elements_Array renames Target.Elements.EA;
|
|
977 SA : Elements_Array renames Source.Elements.EA;
|
|
978
|
|
979 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
|
|
980 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
|
|
981 begin
|
|
982 J := Target.Last; -- new value (after Set_Length)
|
|
983 while Source.Last >= Index_Type'First loop
|
|
984 pragma Assert
|
|
985 (Source.Last <= Index_Type'First
|
|
986 or else not (Is_Less (SA (Source.Last),
|
|
987 SA (Source.Last - 1))));
|
|
988
|
|
989 if I < Index_Type'First then
|
|
990 declare
|
|
991 Src : Elements_Array renames
|
|
992 SA (Index_Type'First .. Source.Last);
|
|
993 begin
|
|
994 TA (Index_Type'First .. J) := Src;
|
|
995 Src := (others => null);
|
|
996 end;
|
|
997
|
|
998 Source.Last := No_Index;
|
|
999 exit;
|
|
1000 end if;
|
|
1001
|
|
1002 pragma Assert
|
|
1003 (I <= Index_Type'First
|
|
1004 or else not (Is_Less (TA (I), TA (I - 1))));
|
|
1005
|
|
1006 declare
|
|
1007 Src : Element_Access renames SA (Source.Last);
|
|
1008 Tgt : Element_Access renames TA (I);
|
|
1009
|
|
1010 begin
|
|
1011 if Is_Less (Src, Tgt) then
|
|
1012 Target.Elements.EA (J) := Tgt;
|
|
1013 Tgt := null;
|
|
1014 I := I - 1;
|
|
1015
|
|
1016 else
|
|
1017 Target.Elements.EA (J) := Src;
|
|
1018 Src := null;
|
|
1019 Source.Last := Source.Last - 1;
|
|
1020 end if;
|
|
1021 end;
|
|
1022
|
|
1023 J := J - 1;
|
|
1024 end loop;
|
|
1025 end;
|
|
1026 end Merge;
|
|
1027
|
|
1028 ----------
|
|
1029 -- Sort --
|
|
1030 ----------
|
|
1031
|
|
1032 procedure Sort (Container : in out Vector) is
|
|
1033 procedure Sort is new Generic_Array_Sort
|
|
1034 (Index_Type => Index_Type,
|
|
1035 Element_Type => Element_Access,
|
|
1036 Array_Type => Elements_Array,
|
|
1037 "<" => Is_Less);
|
|
1038
|
|
1039 -- Start of processing for Sort
|
|
1040
|
|
1041 begin
|
|
1042 if Container.Last <= Index_Type'First then
|
|
1043 return;
|
|
1044 end if;
|
|
1045
|
|
1046 -- The exception behavior for the vector container must match that
|
|
1047 -- for the list container, so we check for cursor tampering here
|
|
1048 -- (which will catch more things) instead of for element tampering
|
|
1049 -- (which will catch fewer things). It's true that the elements of
|
|
1050 -- this vector container could be safely moved around while (say) an
|
|
1051 -- iteration is taking place (iteration only increments the busy
|
|
1052 -- counter), and so technically all we would need here is a test for
|
|
1053 -- element tampering (indicated by the lock counter), that's simply
|
|
1054 -- an artifact of our array-based implementation. Logically Sort
|
|
1055 -- requires a check for cursor tampering.
|
|
1056
|
|
1057 TC_Check (Container.TC);
|
|
1058
|
|
1059 -- Per AI05-0022, the container implementation is required to detect
|
|
1060 -- element tampering by a generic actual subprogram.
|
|
1061
|
|
1062 declare
|
|
1063 Lock : With_Lock (Container.TC'Unchecked_Access);
|
|
1064 begin
|
|
1065 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
|
|
1066 end;
|
|
1067 end Sort;
|
|
1068
|
|
1069 end Generic_Sorting;
|
|
1070
|
|
1071 ------------------------
|
|
1072 -- Get_Element_Access --
|
|
1073 ------------------------
|
|
1074
|
|
1075 function Get_Element_Access
|
|
1076 (Position : Cursor) return not null Element_Access
|
|
1077 is
|
|
1078 Ptr : constant Element_Access :=
|
|
1079 Position.Container.Elements.EA (Position.Index);
|
|
1080
|
|
1081 begin
|
|
1082 -- An indefinite vector may contain spaces that hold no elements.
|
|
1083 -- Any iteration over an indefinite vector with spaces will raise
|
|
1084 -- Constraint_Error.
|
|
1085
|
|
1086 if Ptr = null then
|
|
1087 raise Constraint_Error;
|
|
1088
|
|
1089 else
|
|
1090 return Ptr;
|
|
1091 end if;
|
|
1092 end Get_Element_Access;
|
|
1093
|
|
1094 -----------------
|
|
1095 -- Has_Element --
|
|
1096 -----------------
|
|
1097
|
|
1098 function Has_Element (Position : Cursor) return Boolean is
|
|
1099 begin
|
|
1100 if Position.Container = null then
|
|
1101 return False;
|
|
1102 else
|
|
1103 return Position.Index <= Position.Container.Last;
|
|
1104 end if;
|
|
1105 end Has_Element;
|
|
1106
|
|
1107 ------------
|
|
1108 -- Insert --
|
|
1109 ------------
|
|
1110
|
|
1111 procedure Insert
|
|
1112 (Container : in out Vector;
|
|
1113 Before : Extended_Index;
|
|
1114 New_Item : Element_Type;
|
|
1115 Count : Count_Type := 1)
|
|
1116 is
|
|
1117 Old_Length : constant Count_Type := Container.Length;
|
|
1118
|
|
1119 Max_Length : Count_Type'Base; -- determined from range of Index_Type
|
|
1120 New_Length : Count_Type'Base; -- sum of current length and Count
|
|
1121 New_Last : Index_Type'Base; -- last index of vector after insertion
|
|
1122
|
|
1123 Index : Index_Type'Base; -- scratch for intermediate values
|
|
1124 J : Count_Type'Base; -- scratch
|
|
1125
|
|
1126 New_Capacity : Count_Type'Base; -- length of new, expanded array
|
|
1127 Dst_Last : Index_Type'Base; -- last index of new, expanded array
|
|
1128 Dst : Elements_Access; -- new, expanded internal array
|
|
1129
|
|
1130 begin
|
|
1131 if Checks then
|
|
1132 -- As a precondition on the generic actual Index_Type, the base type
|
|
1133 -- must include Index_Type'Pred (Index_Type'First); this is the value
|
|
1134 -- that Container.Last assumes when the vector is empty. However, we
|
|
1135 -- do not allow that as the value for Index when specifying where the
|
|
1136 -- new items should be inserted, so we must manually check. (That the
|
|
1137 -- user is allowed to specify the value at all here is a consequence
|
|
1138 -- of the declaration of the Extended_Index subtype, which includes
|
|
1139 -- the values in the base range that immediately precede and
|
|
1140 -- immediately follow the values in the Index_Type.)
|
|
1141
|
|
1142 if Before < Index_Type'First then
|
|
1143 raise Constraint_Error with
|
|
1144 "Before index is out of range (too small)";
|
|
1145 end if;
|
|
1146
|
|
1147 -- We do allow a value greater than Container.Last to be specified as
|
|
1148 -- the Index, but only if it's immediately greater. This allows for
|
|
1149 -- the case of appending items to the back end of the vector. (It is
|
|
1150 -- assumed that specifying an index value greater than Last + 1
|
|
1151 -- indicates some deeper flaw in the caller's algorithm, so that case
|
|
1152 -- is treated as a proper error.)
|
|
1153
|
|
1154 if Before > Container.Last + 1 then
|
|
1155 raise Constraint_Error with
|
|
1156 "Before index is out of range (too large)";
|
|
1157 end if;
|
|
1158 end if;
|
|
1159
|
|
1160 -- We treat inserting 0 items into the container as a no-op, even when
|
|
1161 -- the container is busy, so we simply return.
|
|
1162
|
|
1163 if Count = 0 then
|
|
1164 return;
|
|
1165 end if;
|
|
1166
|
|
1167 -- There are two constraints we need to satisfy. The first constraint is
|
|
1168 -- that a container cannot have more than Count_Type'Last elements, so
|
|
1169 -- we must check the sum of the current length and the insertion count.
|
|
1170 -- Note: we cannot simply add these values, because of the possibility
|
|
1171 -- of overflow.
|
|
1172
|
|
1173 if Checks and then Old_Length > Count_Type'Last - Count then
|
|
1174 raise Constraint_Error with "Count is out of range";
|
|
1175 end if;
|
|
1176
|
|
1177 -- It is now safe compute the length of the new vector, without fear of
|
|
1178 -- overflow.
|
|
1179
|
|
1180 New_Length := Old_Length + Count;
|
|
1181
|
|
1182 -- The second constraint is that the new Last index value cannot exceed
|
|
1183 -- Index_Type'Last. In each branch below, we calculate the maximum
|
|
1184 -- length (computed from the range of values in Index_Type), and then
|
|
1185 -- compare the new length to the maximum length. If the new length is
|
|
1186 -- acceptable, then we compute the new last index from that.
|
|
1187
|
|
1188 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1189
|
|
1190 -- We have to handle the case when there might be more values in the
|
|
1191 -- range of Index_Type than in the range of Count_Type.
|
|
1192
|
|
1193 if Index_Type'First <= 0 then
|
|
1194
|
|
1195 -- We know that No_Index (the same as Index_Type'First - 1) is
|
|
1196 -- less than 0, so it is safe to compute the following sum without
|
|
1197 -- fear of overflow.
|
|
1198
|
|
1199 Index := No_Index + Index_Type'Base (Count_Type'Last);
|
|
1200
|
|
1201 if Index <= Index_Type'Last then
|
|
1202
|
|
1203 -- We have determined that range of Index_Type has at least as
|
|
1204 -- many values as in Count_Type, so Count_Type'Last is the
|
|
1205 -- maximum number of items that are allowed.
|
|
1206
|
|
1207 Max_Length := Count_Type'Last;
|
|
1208
|
|
1209 else
|
|
1210 -- The range of Index_Type has fewer values than in Count_Type,
|
|
1211 -- so the maximum number of items is computed from the range of
|
|
1212 -- the Index_Type.
|
|
1213
|
|
1214 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
|
1215 end if;
|
|
1216
|
|
1217 else
|
|
1218 -- No_Index is equal or greater than 0, so we can safely compute
|
|
1219 -- the difference without fear of overflow (which we would have to
|
|
1220 -- worry about if No_Index were less than 0, but that case is
|
|
1221 -- handled above).
|
|
1222
|
|
1223 if Index_Type'Last - No_Index >= Count_Type_Last then
|
|
1224 -- We have determined that range of Index_Type has at least as
|
|
1225 -- many values as in Count_Type, so Count_Type'Last is the
|
|
1226 -- maximum number of items that are allowed.
|
|
1227
|
|
1228 Max_Length := Count_Type'Last;
|
|
1229
|
|
1230 else
|
|
1231 -- The range of Index_Type has fewer values than in Count_Type,
|
|
1232 -- so the maximum number of items is computed from the range of
|
|
1233 -- the Index_Type.
|
|
1234
|
|
1235 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
|
1236 end if;
|
|
1237 end if;
|
|
1238
|
|
1239 elsif Index_Type'First <= 0 then
|
|
1240
|
|
1241 -- We know that No_Index (the same as Index_Type'First - 1) is less
|
|
1242 -- than 0, so it is safe to compute the following sum without fear of
|
|
1243 -- overflow.
|
|
1244
|
|
1245 J := Count_Type'Base (No_Index) + Count_Type'Last;
|
|
1246
|
|
1247 if J <= Count_Type'Base (Index_Type'Last) then
|
|
1248
|
|
1249 -- We have determined that range of Index_Type has at least as
|
|
1250 -- many values as in Count_Type, so Count_Type'Last is the maximum
|
|
1251 -- number of items that are allowed.
|
|
1252
|
|
1253 Max_Length := Count_Type'Last;
|
|
1254
|
|
1255 else
|
|
1256 -- The range of Index_Type has fewer values than Count_Type does,
|
|
1257 -- so the maximum number of items is computed from the range of
|
|
1258 -- the Index_Type.
|
|
1259
|
|
1260 Max_Length :=
|
|
1261 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
|
1262 end if;
|
|
1263
|
|
1264 else
|
|
1265 -- No_Index is equal or greater than 0, so we can safely compute the
|
|
1266 -- difference without fear of overflow (which we would have to worry
|
|
1267 -- about if No_Index were less than 0, but that case is handled
|
|
1268 -- above).
|
|
1269
|
|
1270 Max_Length :=
|
|
1271 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
|
1272 end if;
|
|
1273
|
|
1274 -- We have just computed the maximum length (number of items). We must
|
|
1275 -- now compare the requested length to the maximum length, as we do not
|
|
1276 -- allow a vector expand beyond the maximum (because that would create
|
|
1277 -- an internal array with a last index value greater than
|
|
1278 -- Index_Type'Last, with no way to index those elements).
|
|
1279
|
|
1280 if Checks and then New_Length > Max_Length then
|
|
1281 raise Constraint_Error with "Count is out of range";
|
|
1282 end if;
|
|
1283
|
|
1284 -- New_Last is the last index value of the items in the container after
|
|
1285 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
|
|
1286 -- compute its value from the New_Length.
|
|
1287
|
|
1288 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1289 New_Last := No_Index + Index_Type'Base (New_Length);
|
|
1290 else
|
|
1291 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
|
|
1292 end if;
|
|
1293
|
|
1294 if Container.Elements = null then
|
|
1295 pragma Assert (Container.Last = No_Index);
|
|
1296
|
|
1297 -- This is the simplest case, with which we must always begin: we're
|
|
1298 -- inserting items into an empty vector that hasn't allocated an
|
|
1299 -- internal array yet. Note that we don't need to check the busy bit
|
|
1300 -- here, because an empty container cannot be busy.
|
|
1301
|
|
1302 -- In an indefinite vector, elements are allocated individually, and
|
|
1303 -- stored as access values on the internal array (the length of which
|
|
1304 -- represents the vector "capacity"), which is separately allocated.
|
|
1305
|
|
1306 Container.Elements := new Elements_Type (New_Last);
|
|
1307
|
|
1308 -- The element backbone has been successfully allocated, so now we
|
|
1309 -- allocate the elements.
|
|
1310
|
|
1311 for Idx in Container.Elements.EA'Range loop
|
|
1312
|
|
1313 -- In order to preserve container invariants, we always attempt
|
|
1314 -- the element allocation first, before setting the Last index
|
|
1315 -- value, in case the allocation fails (either because there is no
|
|
1316 -- storage available, or because element initialization fails).
|
|
1317
|
|
1318 declare
|
|
1319 -- The element allocator may need an accessibility check in the
|
|
1320 -- case actual type is class-wide or has access discriminants
|
|
1321 -- (see RM 4.8(10.1) and AI12-0035).
|
|
1322
|
|
1323 pragma Unsuppress (Accessibility_Check);
|
|
1324
|
|
1325 begin
|
|
1326 Container.Elements.EA (Idx) := new Element_Type'(New_Item);
|
|
1327 end;
|
|
1328
|
|
1329 -- The allocation of the element succeeded, so it is now safe to
|
|
1330 -- update the Last index, restoring container invariants.
|
|
1331
|
|
1332 Container.Last := Idx;
|
|
1333 end loop;
|
|
1334
|
|
1335 return;
|
|
1336 end if;
|
|
1337
|
|
1338 -- The tampering bits exist to prevent an item from being harmfully
|
|
1339 -- manipulated while it is being visited. Query, Update, and Iterate
|
|
1340 -- increment the busy count on entry, and decrement the count on
|
|
1341 -- exit. Insert checks the count to determine whether it is being called
|
|
1342 -- while the associated callback procedure is executing.
|
|
1343
|
|
1344 TC_Check (Container.TC);
|
|
1345
|
|
1346 if New_Length <= Container.Elements.EA'Length then
|
|
1347
|
|
1348 -- In this case, we're inserting elements into a vector that has
|
|
1349 -- already allocated an internal array, and the existing array has
|
|
1350 -- enough unused storage for the new items.
|
|
1351
|
|
1352 declare
|
|
1353 E : Elements_Array renames Container.Elements.EA;
|
|
1354 K : Index_Type'Base;
|
|
1355
|
|
1356 begin
|
|
1357 if Before > Container.Last then
|
|
1358
|
|
1359 -- The new items are being appended to the vector, so no
|
|
1360 -- sliding of existing elements is required.
|
|
1361
|
|
1362 for Idx in Before .. New_Last loop
|
|
1363
|
|
1364 -- In order to preserve container invariants, we always
|
|
1365 -- attempt the element allocation first, before setting the
|
|
1366 -- Last index value, in case the allocation fails (either
|
|
1367 -- because there is no storage available, or because element
|
|
1368 -- initialization fails).
|
|
1369
|
|
1370 declare
|
|
1371 -- The element allocator may need an accessibility check
|
|
1372 -- in case the actual type is class-wide or has access
|
|
1373 -- discriminants (see RM 4.8(10.1) and AI12-0035).
|
|
1374
|
|
1375 pragma Unsuppress (Accessibility_Check);
|
|
1376
|
|
1377 begin
|
|
1378 E (Idx) := new Element_Type'(New_Item);
|
|
1379 end;
|
|
1380
|
|
1381 -- The allocation of the element succeeded, so it is now
|
|
1382 -- safe to update the Last index, restoring container
|
|
1383 -- invariants.
|
|
1384
|
|
1385 Container.Last := Idx;
|
|
1386 end loop;
|
|
1387
|
|
1388 else
|
|
1389 -- The new items are being inserted before some existing
|
|
1390 -- elements, so we must slide the existing elements up to their
|
|
1391 -- new home. We use the wider of Index_Type'Base and
|
|
1392 -- Count_Type'Base as the type for intermediate index values.
|
|
1393
|
|
1394 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1395 Index := Before + Index_Type'Base (Count);
|
|
1396 else
|
|
1397 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
|
|
1398 end if;
|
|
1399
|
|
1400 -- The new items are being inserted in the middle of the array,
|
|
1401 -- in the range [Before, Index). Copy the existing elements to
|
|
1402 -- the end of the array, to make room for the new items.
|
|
1403
|
|
1404 E (Index .. New_Last) := E (Before .. Container.Last);
|
|
1405 Container.Last := New_Last;
|
|
1406
|
|
1407 -- We have copied the existing items up to the end of the
|
|
1408 -- array, to make room for the new items in the middle of
|
|
1409 -- the array. Now we actually allocate the new items.
|
|
1410
|
|
1411 -- Note: initialize K outside loop to make it clear that
|
|
1412 -- K always has a value if the exception handler triggers.
|
|
1413
|
|
1414 K := Before;
|
|
1415
|
|
1416 declare
|
|
1417 -- The element allocator may need an accessibility check in
|
|
1418 -- the case the actual type is class-wide or has access
|
|
1419 -- discriminants (see RM 4.8(10.1) and AI12-0035).
|
|
1420
|
|
1421 pragma Unsuppress (Accessibility_Check);
|
|
1422
|
|
1423 begin
|
|
1424 while K < Index loop
|
|
1425 E (K) := new Element_Type'(New_Item);
|
|
1426 K := K + 1;
|
|
1427 end loop;
|
|
1428
|
|
1429 exception
|
|
1430 when others =>
|
|
1431
|
|
1432 -- Values in the range [Before, K) were successfully
|
|
1433 -- allocated, but values in the range [K, Index) are
|
|
1434 -- stale (these array positions contain copies of the
|
|
1435 -- old items, that did not get assigned a new item,
|
|
1436 -- because the allocation failed). We must finish what
|
|
1437 -- we started by clearing out all of the stale values,
|
|
1438 -- leaving a "hole" in the middle of the array.
|
|
1439
|
|
1440 E (K .. Index - 1) := (others => null);
|
|
1441 raise;
|
|
1442 end;
|
|
1443 end if;
|
|
1444 end;
|
|
1445
|
|
1446 return;
|
|
1447 end if;
|
|
1448
|
|
1449 -- In this case, we're inserting elements into a vector that has already
|
|
1450 -- allocated an internal array, but the existing array does not have
|
|
1451 -- enough storage, so we must allocate a new, longer array. In order to
|
|
1452 -- guarantee that the amortized insertion cost is O(1), we always
|
|
1453 -- allocate an array whose length is some power-of-two factor of the
|
|
1454 -- current array length. (The new array cannot have a length less than
|
|
1455 -- the New_Length of the container, but its last index value cannot be
|
|
1456 -- greater than Index_Type'Last.)
|
|
1457
|
|
1458 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
|
|
1459 while New_Capacity < New_Length loop
|
|
1460 if New_Capacity > Count_Type'Last / 2 then
|
|
1461 New_Capacity := Count_Type'Last;
|
|
1462 exit;
|
|
1463 end if;
|
|
1464
|
|
1465 New_Capacity := 2 * New_Capacity;
|
|
1466 end loop;
|
|
1467
|
|
1468 if New_Capacity > Max_Length then
|
|
1469
|
|
1470 -- We have reached the limit of capacity, so no further expansion
|
|
1471 -- will occur. (This is not a problem, as there is never a need to
|
|
1472 -- have more capacity than the maximum container length.)
|
|
1473
|
|
1474 New_Capacity := Max_Length;
|
|
1475 end if;
|
|
1476
|
|
1477 -- We have computed the length of the new internal array (and this is
|
|
1478 -- what "vector capacity" means), so use that to compute its last index.
|
|
1479
|
|
1480 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1481 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
|
|
1482 else
|
|
1483 Dst_Last :=
|
|
1484 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
|
|
1485 end if;
|
|
1486
|
|
1487 -- Now we allocate the new, longer internal array. If the allocation
|
|
1488 -- fails, we have not changed any container state, so no side-effect
|
|
1489 -- will occur as a result of propagating the exception.
|
|
1490
|
|
1491 Dst := new Elements_Type (Dst_Last);
|
|
1492
|
|
1493 -- We have our new internal array. All that needs to be done now is to
|
|
1494 -- copy the existing items (if any) from the old array (the "source"
|
|
1495 -- array) to the new array (the "destination" array), and then
|
|
1496 -- deallocate the old array.
|
|
1497
|
|
1498 declare
|
|
1499 Src : Elements_Access := Container.Elements;
|
|
1500
|
|
1501 begin
|
|
1502 Dst.EA (Index_Type'First .. Before - 1) :=
|
|
1503 Src.EA (Index_Type'First .. Before - 1);
|
|
1504
|
|
1505 if Before > Container.Last then
|
|
1506
|
|
1507 -- The new items are being appended to the vector, so no
|
|
1508 -- sliding of existing elements is required.
|
|
1509
|
|
1510 -- We have copied the elements from to the old source array to the
|
|
1511 -- new destination array, so we can now deallocate the old array.
|
|
1512
|
|
1513 Container.Elements := Dst;
|
|
1514 Free (Src);
|
|
1515
|
|
1516 -- Now we append the new items.
|
|
1517
|
|
1518 for Idx in Before .. New_Last loop
|
|
1519
|
|
1520 -- In order to preserve container invariants, we always attempt
|
|
1521 -- the element allocation first, before setting the Last index
|
|
1522 -- value, in case the allocation fails (either because there
|
|
1523 -- is no storage available, or because element initialization
|
|
1524 -- fails).
|
|
1525
|
|
1526 declare
|
|
1527 -- The element allocator may need an accessibility check in
|
|
1528 -- the case the actual type is class-wide or has access
|
|
1529 -- discriminants (see RM 4.8(10.1) and AI12-0035).
|
|
1530
|
|
1531 pragma Unsuppress (Accessibility_Check);
|
|
1532
|
|
1533 begin
|
|
1534 Dst.EA (Idx) := new Element_Type'(New_Item);
|
|
1535 end;
|
|
1536
|
|
1537 -- The allocation of the element succeeded, so it is now safe
|
|
1538 -- to update the Last index, restoring container invariants.
|
|
1539
|
|
1540 Container.Last := Idx;
|
|
1541 end loop;
|
|
1542
|
|
1543 else
|
|
1544 -- The new items are being inserted before some existing elements,
|
|
1545 -- so we must slide the existing elements up to their new home.
|
|
1546
|
|
1547 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1548 Index := Before + Index_Type'Base (Count);
|
|
1549 else
|
|
1550 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
|
|
1551 end if;
|
|
1552
|
|
1553 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
|
|
1554
|
|
1555 -- We have copied the elements from to the old source array to the
|
|
1556 -- new destination array, so we can now deallocate the old array.
|
|
1557
|
|
1558 Container.Elements := Dst;
|
|
1559 Container.Last := New_Last;
|
|
1560 Free (Src);
|
|
1561
|
|
1562 -- The new array has a range in the middle containing null access
|
|
1563 -- values. Fill in that partition of the array with the new items.
|
|
1564
|
|
1565 for Idx in Before .. Index - 1 loop
|
|
1566
|
|
1567 -- Note that container invariants have already been satisfied
|
|
1568 -- (in particular, the Last index value of the vector has
|
|
1569 -- already been updated), so if this allocation fails we simply
|
|
1570 -- let it propagate.
|
|
1571
|
|
1572 declare
|
|
1573 -- The element allocator may need an accessibility check in
|
|
1574 -- the case the actual type is class-wide or has access
|
|
1575 -- discriminants (see RM 4.8(10.1) and AI12-0035).
|
|
1576
|
|
1577 pragma Unsuppress (Accessibility_Check);
|
|
1578
|
|
1579 begin
|
|
1580 Dst.EA (Idx) := new Element_Type'(New_Item);
|
|
1581 end;
|
|
1582 end loop;
|
|
1583 end if;
|
|
1584 end;
|
|
1585 end Insert;
|
|
1586
|
|
1587 procedure Insert
|
|
1588 (Container : in out Vector;
|
|
1589 Before : Extended_Index;
|
|
1590 New_Item : Vector)
|
|
1591 is
|
|
1592 N : constant Count_Type := Length (New_Item);
|
|
1593 J : Index_Type'Base;
|
|
1594
|
|
1595 begin
|
|
1596 -- Use Insert_Space to create the "hole" (the destination slice) into
|
|
1597 -- which we copy the source items.
|
|
1598
|
|
1599 Insert_Space (Container, Before, Count => N);
|
|
1600
|
|
1601 if N = 0 then
|
|
1602
|
|
1603 -- There's nothing else to do here (vetting of parameters was
|
|
1604 -- performed already in Insert_Space), so we simply return.
|
|
1605
|
|
1606 return;
|
|
1607 end if;
|
|
1608
|
|
1609 if Container'Address /= New_Item'Address then
|
|
1610
|
|
1611 -- This is the simple case. New_Item denotes an object different
|
|
1612 -- from Container, so there's nothing special we need to do to copy
|
|
1613 -- the source items to their destination, because all of the source
|
|
1614 -- items are contiguous.
|
|
1615
|
|
1616 declare
|
|
1617 subtype Src_Index_Subtype is Index_Type'Base range
|
|
1618 Index_Type'First .. New_Item.Last;
|
|
1619
|
|
1620 Src : Elements_Array renames
|
|
1621 New_Item.Elements.EA (Src_Index_Subtype);
|
|
1622
|
|
1623 Dst : Elements_Array renames Container.Elements.EA;
|
|
1624
|
|
1625 Dst_Index : Index_Type'Base;
|
|
1626
|
|
1627 begin
|
|
1628 Dst_Index := Before - 1;
|
|
1629 for Src_Index in Src'Range loop
|
|
1630 Dst_Index := Dst_Index + 1;
|
|
1631
|
|
1632 if Src (Src_Index) /= null then
|
|
1633 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
|
|
1634 end if;
|
|
1635 end loop;
|
|
1636 end;
|
|
1637
|
|
1638 return;
|
|
1639 end if;
|
|
1640
|
|
1641 -- New_Item denotes the same object as Container, so an insertion has
|
|
1642 -- potentially split the source items. The first source slice is
|
|
1643 -- [Index_Type'First, Before), and the second source slice is
|
|
1644 -- [J, Container.Last], where index value J is the first index of the
|
|
1645 -- second slice. (J gets computed below, but only after we have
|
|
1646 -- determined that the second source slice is non-empty.) The
|
|
1647 -- destination slice is always the range [Before, J). We perform the
|
|
1648 -- copy in two steps, using each of the two slices of the source items.
|
|
1649
|
|
1650 declare
|
|
1651 L : constant Index_Type'Base := Before - 1;
|
|
1652
|
|
1653 subtype Src_Index_Subtype is Index_Type'Base range
|
|
1654 Index_Type'First .. L;
|
|
1655
|
|
1656 Src : Elements_Array renames
|
|
1657 Container.Elements.EA (Src_Index_Subtype);
|
|
1658
|
|
1659 Dst : Elements_Array renames Container.Elements.EA;
|
|
1660
|
|
1661 Dst_Index : Index_Type'Base;
|
|
1662
|
|
1663 begin
|
|
1664 -- We first copy the source items that precede the space we
|
|
1665 -- inserted. (If Before equals Index_Type'First, then this first
|
|
1666 -- source slice will be empty, which is harmless.)
|
|
1667
|
|
1668 Dst_Index := Before - 1;
|
|
1669 for Src_Index in Src'Range loop
|
|
1670 Dst_Index := Dst_Index + 1;
|
|
1671
|
|
1672 if Src (Src_Index) /= null then
|
|
1673 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
|
|
1674 end if;
|
|
1675 end loop;
|
|
1676
|
|
1677 if Src'Length = N then
|
|
1678
|
|
1679 -- The new items were effectively appended to the container, so we
|
|
1680 -- have already copied all of the items that need to be copied.
|
|
1681 -- We return early here, even though the source slice below is
|
|
1682 -- empty (so the assignment would be harmless), because we want to
|
|
1683 -- avoid computing J, which will overflow if J is greater than
|
|
1684 -- Index_Type'Base'Last.
|
|
1685
|
|
1686 return;
|
|
1687 end if;
|
|
1688 end;
|
|
1689
|
|
1690 -- Index value J is the first index of the second source slice. (It is
|
|
1691 -- also 1 greater than the last index of the destination slice.) Note:
|
|
1692 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
|
|
1693 -- to avoid overflow. Prevent that by returning early above, immediately
|
|
1694 -- after copying the first slice of the source, and determining that
|
|
1695 -- this second slice of the source is empty.
|
|
1696
|
|
1697 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1698 J := Before + Index_Type'Base (N);
|
|
1699 else
|
|
1700 J := Index_Type'Base (Count_Type'Base (Before) + N);
|
|
1701 end if;
|
|
1702
|
|
1703 declare
|
|
1704 subtype Src_Index_Subtype is Index_Type'Base range
|
|
1705 J .. Container.Last;
|
|
1706
|
|
1707 Src : Elements_Array renames
|
|
1708 Container.Elements.EA (Src_Index_Subtype);
|
|
1709
|
|
1710 Dst : Elements_Array renames Container.Elements.EA;
|
|
1711
|
|
1712 Dst_Index : Index_Type'Base;
|
|
1713
|
|
1714 begin
|
|
1715 -- We next copy the source items that follow the space we inserted.
|
|
1716 -- Index value Dst_Index is the first index of that portion of the
|
|
1717 -- destination that receives this slice of the source. (For the
|
|
1718 -- reasons given above, this slice is guaranteed to be non-empty.)
|
|
1719
|
|
1720 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1721 Dst_Index := J - Index_Type'Base (Src'Length);
|
|
1722 else
|
|
1723 Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
|
|
1724 end if;
|
|
1725
|
|
1726 for Src_Index in Src'Range loop
|
|
1727 if Src (Src_Index) /= null then
|
|
1728 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
|
|
1729 end if;
|
|
1730
|
|
1731 Dst_Index := Dst_Index + 1;
|
|
1732 end loop;
|
|
1733 end;
|
|
1734 end Insert;
|
|
1735
|
|
1736 procedure Insert
|
|
1737 (Container : in out Vector;
|
|
1738 Before : Cursor;
|
|
1739 New_Item : Vector)
|
|
1740 is
|
|
1741 Index : Index_Type'Base;
|
|
1742
|
|
1743 begin
|
|
1744 if Checks and then Before.Container /= null
|
|
1745 and then Before.Container /= Container'Unrestricted_Access
|
|
1746 then
|
|
1747 raise Program_Error with "Before cursor denotes wrong container";
|
|
1748 end if;
|
|
1749
|
|
1750 if Is_Empty (New_Item) then
|
|
1751 return;
|
|
1752 end if;
|
|
1753
|
|
1754 if Before.Container = null or else Before.Index > Container.Last then
|
|
1755 if Checks and then Container.Last = Index_Type'Last then
|
|
1756 raise Constraint_Error with
|
|
1757 "vector is already at its maximum length";
|
|
1758 end if;
|
|
1759
|
|
1760 Index := Container.Last + 1;
|
|
1761
|
|
1762 else
|
|
1763 Index := Before.Index;
|
|
1764 end if;
|
|
1765
|
|
1766 Insert (Container, Index, New_Item);
|
|
1767 end Insert;
|
|
1768
|
|
1769 procedure Insert
|
|
1770 (Container : in out Vector;
|
|
1771 Before : Cursor;
|
|
1772 New_Item : Vector;
|
|
1773 Position : out Cursor)
|
|
1774 is
|
|
1775 Index : Index_Type'Base;
|
|
1776
|
|
1777 begin
|
|
1778 if Checks and then Before.Container /= null
|
|
1779 and then Before.Container /= Container'Unrestricted_Access
|
|
1780 then
|
|
1781 raise Program_Error with "Before cursor denotes wrong container";
|
|
1782 end if;
|
|
1783
|
|
1784 if Is_Empty (New_Item) then
|
|
1785 if Before.Container = null or else Before.Index > Container.Last then
|
|
1786 Position := No_Element;
|
|
1787 else
|
|
1788 Position := (Container'Unrestricted_Access, Before.Index);
|
|
1789 end if;
|
|
1790
|
|
1791 return;
|
|
1792 end if;
|
|
1793
|
|
1794 if Before.Container = null or else Before.Index > Container.Last then
|
|
1795 if Checks and then Container.Last = Index_Type'Last then
|
|
1796 raise Constraint_Error with
|
|
1797 "vector is already at its maximum length";
|
|
1798 end if;
|
|
1799
|
|
1800 Index := Container.Last + 1;
|
|
1801
|
|
1802 else
|
|
1803 Index := Before.Index;
|
|
1804 end if;
|
|
1805
|
|
1806 Insert (Container, Index, New_Item);
|
|
1807
|
|
1808 Position := (Container'Unrestricted_Access, Index);
|
|
1809 end Insert;
|
|
1810
|
|
1811 procedure Insert
|
|
1812 (Container : in out Vector;
|
|
1813 Before : Cursor;
|
|
1814 New_Item : Element_Type;
|
|
1815 Count : Count_Type := 1)
|
|
1816 is
|
|
1817 Index : Index_Type'Base;
|
|
1818
|
|
1819 begin
|
|
1820 if Checks and then Before.Container /= null
|
|
1821 and then Before.Container /= Container'Unrestricted_Access
|
|
1822 then
|
|
1823 raise Program_Error with "Before cursor denotes wrong container";
|
|
1824 end if;
|
|
1825
|
|
1826 if Count = 0 then
|
|
1827 return;
|
|
1828 end if;
|
|
1829
|
|
1830 if Before.Container = null or else Before.Index > Container.Last then
|
|
1831 if Checks and then Container.Last = Index_Type'Last then
|
|
1832 raise Constraint_Error with
|
|
1833 "vector is already at its maximum length";
|
|
1834 end if;
|
|
1835
|
|
1836 Index := Container.Last + 1;
|
|
1837
|
|
1838 else
|
|
1839 Index := Before.Index;
|
|
1840 end if;
|
|
1841
|
|
1842 Insert (Container, Index, New_Item, Count);
|
|
1843 end Insert;
|
|
1844
|
|
1845 procedure Insert
|
|
1846 (Container : in out Vector;
|
|
1847 Before : Cursor;
|
|
1848 New_Item : Element_Type;
|
|
1849 Position : out Cursor;
|
|
1850 Count : Count_Type := 1)
|
|
1851 is
|
|
1852 Index : Index_Type'Base;
|
|
1853
|
|
1854 begin
|
|
1855 if Checks and then Before.Container /= null
|
|
1856 and then Before.Container /= Container'Unrestricted_Access
|
|
1857 then
|
|
1858 raise Program_Error with "Before cursor denotes wrong container";
|
|
1859 end if;
|
|
1860
|
|
1861 if Count = 0 then
|
|
1862 if Before.Container = null or else Before.Index > Container.Last then
|
|
1863 Position := No_Element;
|
|
1864 else
|
|
1865 Position := (Container'Unrestricted_Access, Before.Index);
|
|
1866 end if;
|
|
1867
|
|
1868 return;
|
|
1869 end if;
|
|
1870
|
|
1871 if Before.Container = null or else Before.Index > Container.Last then
|
|
1872 if Checks and then Container.Last = Index_Type'Last then
|
|
1873 raise Constraint_Error with
|
|
1874 "vector is already at its maximum length";
|
|
1875 end if;
|
|
1876
|
|
1877 Index := Container.Last + 1;
|
|
1878
|
|
1879 else
|
|
1880 Index := Before.Index;
|
|
1881 end if;
|
|
1882
|
|
1883 Insert (Container, Index, New_Item, Count);
|
|
1884
|
|
1885 Position := (Container'Unrestricted_Access, Index);
|
|
1886 end Insert;
|
|
1887
|
|
1888 ------------------
|
|
1889 -- Insert_Space --
|
|
1890 ------------------
|
|
1891
|
|
1892 procedure Insert_Space
|
|
1893 (Container : in out Vector;
|
|
1894 Before : Extended_Index;
|
|
1895 Count : Count_Type := 1)
|
|
1896 is
|
|
1897 Old_Length : constant Count_Type := Container.Length;
|
|
1898
|
|
1899 Max_Length : Count_Type'Base; -- determined from range of Index_Type
|
|
1900 New_Length : Count_Type'Base; -- sum of current length and Count
|
|
1901 New_Last : Index_Type'Base; -- last index of vector after insertion
|
|
1902
|
|
1903 Index : Index_Type'Base; -- scratch for intermediate values
|
|
1904 J : Count_Type'Base; -- scratch
|
|
1905
|
|
1906 New_Capacity : Count_Type'Base; -- length of new, expanded array
|
|
1907 Dst_Last : Index_Type'Base; -- last index of new, expanded array
|
|
1908 Dst : Elements_Access; -- new, expanded internal array
|
|
1909
|
|
1910 begin
|
|
1911 if Checks then
|
|
1912 -- As a precondition on the generic actual Index_Type, the base type
|
|
1913 -- must include Index_Type'Pred (Index_Type'First); this is the value
|
|
1914 -- that Container.Last assumes when the vector is empty. However, we
|
|
1915 -- do not allow that as the value for Index when specifying where the
|
|
1916 -- new items should be inserted, so we must manually check. (That the
|
|
1917 -- user is allowed to specify the value at all here is a consequence
|
|
1918 -- of the declaration of the Extended_Index subtype, which includes
|
|
1919 -- the values in the base range that immediately precede and
|
|
1920 -- immediately follow the values in the Index_Type.)
|
|
1921
|
|
1922 if Before < Index_Type'First then
|
|
1923 raise Constraint_Error with
|
|
1924 "Before index is out of range (too small)";
|
|
1925 end if;
|
|
1926
|
|
1927 -- We do allow a value greater than Container.Last to be specified as
|
|
1928 -- the Index, but only if it's immediately greater. This allows for
|
|
1929 -- the case of appending items to the back end of the vector. (It is
|
|
1930 -- assumed that specifying an index value greater than Last + 1
|
|
1931 -- indicates some deeper flaw in the caller's algorithm, so that case
|
|
1932 -- is treated as a proper error.)
|
|
1933
|
|
1934 if Before > Container.Last + 1 then
|
|
1935 raise Constraint_Error with
|
|
1936 "Before index is out of range (too large)";
|
|
1937 end if;
|
|
1938 end if;
|
|
1939
|
|
1940 -- We treat inserting 0 items into the container as a no-op, even when
|
|
1941 -- the container is busy, so we simply return.
|
|
1942
|
|
1943 if Count = 0 then
|
|
1944 return;
|
|
1945 end if;
|
|
1946
|
|
1947 -- There are two constraints we need to satisfy. The first constraint is
|
|
1948 -- that a container cannot have more than Count_Type'Last elements, so
|
|
1949 -- we must check the sum of the current length and the insertion count.
|
|
1950 -- Note: we cannot simply add these values, because of the possibility
|
|
1951 -- of overflow.
|
|
1952
|
|
1953 if Checks and then Old_Length > Count_Type'Last - Count then
|
|
1954 raise Constraint_Error with "Count is out of range";
|
|
1955 end if;
|
|
1956
|
|
1957 -- It is now safe compute the length of the new vector, without fear of
|
|
1958 -- overflow.
|
|
1959
|
|
1960 New_Length := Old_Length + Count;
|
|
1961
|
|
1962 -- The second constraint is that the new Last index value cannot exceed
|
|
1963 -- Index_Type'Last. In each branch below, we calculate the maximum
|
|
1964 -- length (computed from the range of values in Index_Type), and then
|
|
1965 -- compare the new length to the maximum length. If the new length is
|
|
1966 -- acceptable, then we compute the new last index from that.
|
|
1967
|
|
1968 if Index_Type'Base'Last >= Count_Type_Last then
|
|
1969 -- We have to handle the case when there might be more values in the
|
|
1970 -- range of Index_Type than in the range of Count_Type.
|
|
1971
|
|
1972 if Index_Type'First <= 0 then
|
|
1973
|
|
1974 -- We know that No_Index (the same as Index_Type'First - 1) is
|
|
1975 -- less than 0, so it is safe to compute the following sum without
|
|
1976 -- fear of overflow.
|
|
1977
|
|
1978 Index := No_Index + Index_Type'Base (Count_Type'Last);
|
|
1979
|
|
1980 if Index <= Index_Type'Last then
|
|
1981
|
|
1982 -- We have determined that range of Index_Type has at least as
|
|
1983 -- many values as in Count_Type, so Count_Type'Last is the
|
|
1984 -- maximum number of items that are allowed.
|
|
1985
|
|
1986 Max_Length := Count_Type'Last;
|
|
1987
|
|
1988 else
|
|
1989 -- The range of Index_Type has fewer values than in Count_Type,
|
|
1990 -- so the maximum number of items is computed from the range of
|
|
1991 -- the Index_Type.
|
|
1992
|
|
1993 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
|
1994 end if;
|
|
1995
|
|
1996 else
|
|
1997 -- No_Index is equal or greater than 0, so we can safely compute
|
|
1998 -- the difference without fear of overflow (which we would have to
|
|
1999 -- worry about if No_Index were less than 0, but that case is
|
|
2000 -- handled above).
|
|
2001
|
|
2002 if Index_Type'Last - No_Index >= Count_Type_Last then
|
|
2003 -- We have determined that range of Index_Type has at least as
|
|
2004 -- many values as in Count_Type, so Count_Type'Last is the
|
|
2005 -- maximum number of items that are allowed.
|
|
2006
|
|
2007 Max_Length := Count_Type'Last;
|
|
2008
|
|
2009 else
|
|
2010 -- The range of Index_Type has fewer values than in Count_Type,
|
|
2011 -- so the maximum number of items is computed from the range of
|
|
2012 -- the Index_Type.
|
|
2013
|
|
2014 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
|
|
2015 end if;
|
|
2016 end if;
|
|
2017
|
|
2018 elsif Index_Type'First <= 0 then
|
|
2019
|
|
2020 -- We know that No_Index (the same as Index_Type'First - 1) is less
|
|
2021 -- than 0, so it is safe to compute the following sum without fear of
|
|
2022 -- overflow.
|
|
2023
|
|
2024 J := Count_Type'Base (No_Index) + Count_Type'Last;
|
|
2025
|
|
2026 if J <= Count_Type'Base (Index_Type'Last) then
|
|
2027
|
|
2028 -- We have determined that range of Index_Type has at least as
|
|
2029 -- many values as in Count_Type, so Count_Type'Last is the maximum
|
|
2030 -- number of items that are allowed.
|
|
2031
|
|
2032 Max_Length := Count_Type'Last;
|
|
2033
|
|
2034 else
|
|
2035 -- The range of Index_Type has fewer values than Count_Type does,
|
|
2036 -- so the maximum number of items is computed from the range of
|
|
2037 -- the Index_Type.
|
|
2038
|
|
2039 Max_Length :=
|
|
2040 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
|
2041 end if;
|
|
2042
|
|
2043 else
|
|
2044 -- No_Index is equal or greater than 0, so we can safely compute the
|
|
2045 -- difference without fear of overflow (which we would have to worry
|
|
2046 -- about if No_Index were less than 0, but that case is handled
|
|
2047 -- above).
|
|
2048
|
|
2049 Max_Length :=
|
|
2050 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
|
|
2051 end if;
|
|
2052
|
|
2053 -- We have just computed the maximum length (number of items). We must
|
|
2054 -- now compare the requested length to the maximum length, as we do not
|
|
2055 -- allow a vector expand beyond the maximum (because that would create
|
|
2056 -- an internal array with a last index value greater than
|
|
2057 -- Index_Type'Last, with no way to index those elements).
|
|
2058
|
|
2059 if Checks and then New_Length > Max_Length then
|
|
2060 raise Constraint_Error with "Count is out of range";
|
|
2061 end if;
|
|
2062
|
|
2063 -- New_Last is the last index value of the items in the container after
|
|
2064 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
|
|
2065 -- compute its value from the New_Length.
|
|
2066
|
|
2067 if Index_Type'Base'Last >= Count_Type_Last then
|
|
2068 New_Last := No_Index + Index_Type'Base (New_Length);
|
|
2069 else
|
|
2070 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
|
|
2071 end if;
|
|
2072
|
|
2073 if Container.Elements = null then
|
|
2074 pragma Assert (Container.Last = No_Index);
|
|
2075
|
|
2076 -- This is the simplest case, with which we must always begin: we're
|
|
2077 -- inserting items into an empty vector that hasn't allocated an
|
|
2078 -- internal array yet. Note that we don't need to check the busy bit
|
|
2079 -- here, because an empty container cannot be busy.
|
|
2080
|
|
2081 -- In an indefinite vector, elements are allocated individually, and
|
|
2082 -- stored as access values on the internal array (the length of which
|
|
2083 -- represents the vector "capacity"), which is separately allocated.
|
|
2084 -- We have no elements here (because we're inserting "space"), so all
|
|
2085 -- we need to do is allocate the backbone.
|
|
2086
|
|
2087 Container.Elements := new Elements_Type (New_Last);
|
|
2088 Container.Last := New_Last;
|
|
2089
|
|
2090 return;
|
|
2091 end if;
|
|
2092
|
|
2093 -- The tampering bits exist to prevent an item from being harmfully
|
|
2094 -- manipulated while it is being visited. Query, Update, and Iterate
|
|
2095 -- increment the busy count on entry, and decrement the count on exit.
|
|
2096 -- Insert checks the count to determine whether it is being called while
|
|
2097 -- the associated callback procedure is executing.
|
|
2098
|
|
2099 TC_Check (Container.TC);
|
|
2100
|
|
2101 if New_Length <= Container.Elements.EA'Length then
|
|
2102
|
|
2103 -- In this case, we are inserting elements into a vector that has
|
|
2104 -- already allocated an internal array, and the existing array has
|
|
2105 -- enough unused storage for the new items.
|
|
2106
|
|
2107 declare
|
|
2108 E : Elements_Array renames Container.Elements.EA;
|
|
2109
|
|
2110 begin
|
|
2111 if Before <= Container.Last then
|
|
2112
|
|
2113 -- The new space is being inserted before some existing
|
|
2114 -- elements, so we must slide the existing elements up to
|
|
2115 -- their new home. We use the wider of Index_Type'Base and
|
|
2116 -- Count_Type'Base as the type for intermediate index values.
|
|
2117
|
|
2118 if Index_Type'Base'Last >= Count_Type_Last then
|
|
2119 Index := Before + Index_Type'Base (Count);
|
|
2120 else
|
|
2121 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
|
|
2122 end if;
|
|
2123
|
|
2124 E (Index .. New_Last) := E (Before .. Container.Last);
|
|
2125 E (Before .. Index - 1) := (others => null);
|
|
2126 end if;
|
|
2127 end;
|
|
2128
|
|
2129 Container.Last := New_Last;
|
|
2130 return;
|
|
2131 end if;
|
|
2132
|
|
2133 -- In this case, we're inserting elements into a vector that has already
|
|
2134 -- allocated an internal array, but the existing array does not have
|
|
2135 -- enough storage, so we must allocate a new, longer array. In order to
|
|
2136 -- guarantee that the amortized insertion cost is O(1), we always
|
|
2137 -- allocate an array whose length is some power-of-two factor of the
|
|
2138 -- current array length. (The new array cannot have a length less than
|
|
2139 -- the New_Length of the container, but its last index value cannot be
|
|
2140 -- greater than Index_Type'Last.)
|
|
2141
|
|
2142 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
|
|
2143 while New_Capacity < New_Length loop
|
|
2144 if New_Capacity > Count_Type'Last / 2 then
|
|
2145 New_Capacity := Count_Type'Last;
|
|
2146 exit;
|
|
2147 end if;
|
|
2148
|
|
2149 New_Capacity := 2 * New_Capacity;
|
|
2150 end loop;
|
|
2151
|
|
2152 if New_Capacity > Max_Length then
|
|
2153
|
|
2154 -- We have reached the limit of capacity, so no further expansion
|
|
2155 -- will occur. (This is not a problem, as there is never a need to
|
|
2156 -- have more capacity than the maximum container length.)
|
|
2157
|
|
2158 New_Capacity := Max_Length;
|
|
2159 end if;
|
|
2160
|
|
2161 -- We have computed the length of the new internal array (and this is
|
|
2162 -- what "vector capacity" means), so use that to compute its last index.
|
|
2163
|
|
2164 if Index_Type'Base'Last >= Count_Type_Last then
|
|
2165 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
|
|
2166 else
|
|
2167 Dst_Last :=
|
|
2168 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
|
|
2169 end if;
|
|
2170
|
|
2171 -- Now we allocate the new, longer internal array. If the allocation
|
|
2172 -- fails, we have not changed any container state, so no side-effect
|
|
2173 -- will occur as a result of propagating the exception.
|
|
2174
|
|
2175 Dst := new Elements_Type (Dst_Last);
|
|
2176
|
|
2177 -- We have our new internal array. All that needs to be done now is to
|
|
2178 -- copy the existing items (if any) from the old array (the "source"
|
|
2179 -- array) to the new array (the "destination" array), and then
|
|
2180 -- deallocate the old array.
|
|
2181
|
|
2182 declare
|
|
2183 Src : Elements_Access := Container.Elements;
|
|
2184
|
|
2185 begin
|
|
2186 Dst.EA (Index_Type'First .. Before - 1) :=
|
|
2187 Src.EA (Index_Type'First .. Before - 1);
|
|
2188
|
|
2189 if Before <= Container.Last then
|
|
2190
|
|
2191 -- The new items are being inserted before some existing elements,
|
|
2192 -- so we must slide the existing elements up to their new home.
|
|
2193
|
|
2194 if Index_Type'Base'Last >= Count_Type_Last then
|
|
2195 Index := Before + Index_Type'Base (Count);
|
|
2196 else
|
|
2197 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
|
|
2198 end if;
|
|
2199
|
|
2200 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
|
|
2201 end if;
|
|
2202
|
|
2203 -- We have copied the elements from to the old, source array to the
|
|
2204 -- new, destination array, so we can now restore invariants, and
|
|
2205 -- deallocate the old array.
|
|
2206
|
|
2207 Container.Elements := Dst;
|
|
2208 Container.Last := New_Last;
|
|
2209 Free (Src);
|
|
2210 end;
|
|
2211 end Insert_Space;
|
|
2212
|
|
2213 procedure Insert_Space
|
|
2214 (Container : in out Vector;
|
|
2215 Before : Cursor;
|
|
2216 Position : out Cursor;
|
|
2217 Count : Count_Type := 1)
|
|
2218 is
|
|
2219 Index : Index_Type'Base;
|
|
2220
|
|
2221 begin
|
|
2222 if Checks and then Before.Container /= null
|
|
2223 and then Before.Container /= Container'Unrestricted_Access
|
|
2224 then
|
|
2225 raise Program_Error with "Before cursor denotes wrong container";
|
|
2226 end if;
|
|
2227
|
|
2228 if Count = 0 then
|
|
2229 if Before.Container = null or else Before.Index > Container.Last then
|
|
2230 Position := No_Element;
|
|
2231 else
|
|
2232 Position := (Container'Unrestricted_Access, Before.Index);
|
|
2233 end if;
|
|
2234
|
|
2235 return;
|
|
2236 end if;
|
|
2237
|
|
2238 if Before.Container = null or else Before.Index > Container.Last then
|
|
2239 if Checks and then Container.Last = Index_Type'Last then
|
|
2240 raise Constraint_Error with
|
|
2241 "vector is already at its maximum length";
|
|
2242 end if;
|
|
2243
|
|
2244 Index := Container.Last + 1;
|
|
2245
|
|
2246 else
|
|
2247 Index := Before.Index;
|
|
2248 end if;
|
|
2249
|
|
2250 Insert_Space (Container, Index, Count);
|
|
2251
|
|
2252 Position := (Container'Unrestricted_Access, Index);
|
|
2253 end Insert_Space;
|
|
2254
|
|
2255 --------------
|
|
2256 -- Is_Empty --
|
|
2257 --------------
|
|
2258
|
|
2259 function Is_Empty (Container : Vector) return Boolean is
|
|
2260 begin
|
|
2261 return Container.Last < Index_Type'First;
|
|
2262 end Is_Empty;
|
|
2263
|
|
2264 -------------
|
|
2265 -- Iterate --
|
|
2266 -------------
|
|
2267
|
|
2268 procedure Iterate
|
|
2269 (Container : Vector;
|
|
2270 Process : not null access procedure (Position : Cursor))
|
|
2271 is
|
|
2272 Busy : With_Busy (Container.TC'Unrestricted_Access);
|
|
2273 begin
|
|
2274 for Indx in Index_Type'First .. Container.Last loop
|
|
2275 Process (Cursor'(Container'Unrestricted_Access, Indx));
|
|
2276 end loop;
|
|
2277 end Iterate;
|
|
2278
|
|
2279 function Iterate
|
|
2280 (Container : Vector)
|
|
2281 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
|
|
2282 is
|
|
2283 V : constant Vector_Access := Container'Unrestricted_Access;
|
|
2284 begin
|
|
2285 -- The value of its Index component influences the behavior of the First
|
|
2286 -- and Last selector functions of the iterator object. When the Index
|
|
2287 -- component is No_Index (as is the case here), this means the iterator
|
|
2288 -- object was constructed without a start expression. This is a complete
|
|
2289 -- iterator, meaning that the iteration starts from the (logical)
|
|
2290 -- beginning of the sequence of items.
|
|
2291
|
|
2292 -- Note: For a forward iterator, Container.First is the beginning, and
|
|
2293 -- for a reverse iterator, Container.Last is the beginning.
|
|
2294
|
|
2295 return It : constant Iterator :=
|
|
2296 (Limited_Controlled with
|
|
2297 Container => V,
|
|
2298 Index => No_Index)
|
|
2299 do
|
|
2300 Busy (Container.TC'Unrestricted_Access.all);
|
|
2301 end return;
|
|
2302 end Iterate;
|
|
2303
|
|
2304 function Iterate
|
|
2305 (Container : Vector;
|
|
2306 Start : Cursor)
|
|
2307 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
|
|
2308 is
|
|
2309 V : constant Vector_Access := Container'Unrestricted_Access;
|
|
2310 begin
|
|
2311 -- It was formerly the case that when Start = No_Element, the partial
|
|
2312 -- iterator was defined to behave the same as for a complete iterator,
|
|
2313 -- and iterate over the entire sequence of items. However, those
|
|
2314 -- semantics were unintuitive and arguably error-prone (it is too easy
|
|
2315 -- to accidentally create an endless loop), and so they were changed,
|
|
2316 -- per the ARG meeting in Denver on 2011/11. However, there was no
|
|
2317 -- consensus about what positive meaning this corner case should have,
|
|
2318 -- and so it was decided to simply raise an exception. This does imply,
|
|
2319 -- however, that it is not possible to use a partial iterator to specify
|
|
2320 -- an empty sequence of items.
|
|
2321
|
|
2322 if Checks then
|
|
2323 if Start.Container = null then
|
|
2324 raise Constraint_Error with
|
|
2325 "Start position for iterator equals No_Element";
|
|
2326 end if;
|
|
2327
|
|
2328 if Start.Container /= V then
|
|
2329 raise Program_Error with
|
|
2330 "Start cursor of Iterate designates wrong vector";
|
|
2331 end if;
|
|
2332
|
|
2333 if Start.Index > V.Last then
|
|
2334 raise Constraint_Error with
|
|
2335 "Start position for iterator equals No_Element";
|
|
2336 end if;
|
|
2337 end if;
|
|
2338
|
|
2339 -- The value of its Index component influences the behavior of the First
|
|
2340 -- and Last selector functions of the iterator object. When the Index
|
|
2341 -- component is not No_Index (as is the case here), it means that this
|
|
2342 -- is a partial iteration, over a subset of the complete sequence of
|
|
2343 -- items. The iterator object was constructed with a start expression,
|
|
2344 -- indicating the position from which the iteration begins. Note that
|
|
2345 -- the start position has the same value irrespective of whether this
|
|
2346 -- is a forward or reverse iteration.
|
|
2347
|
|
2348 return It : constant Iterator :=
|
|
2349 (Limited_Controlled with
|
|
2350 Container => V,
|
|
2351 Index => Start.Index)
|
|
2352 do
|
|
2353 Busy (Container.TC'Unrestricted_Access.all);
|
|
2354 end return;
|
|
2355 end Iterate;
|
|
2356
|
|
2357 ----------
|
|
2358 -- Last --
|
|
2359 ----------
|
|
2360
|
|
2361 function Last (Container : Vector) return Cursor is
|
|
2362 begin
|
|
2363 if Is_Empty (Container) then
|
|
2364 return No_Element;
|
|
2365 end if;
|
|
2366
|
|
2367 return (Container'Unrestricted_Access, Container.Last);
|
|
2368 end Last;
|
|
2369
|
|
2370 function Last (Object : Iterator) return Cursor is
|
|
2371 begin
|
|
2372 -- The value of the iterator object's Index component influences the
|
|
2373 -- behavior of the Last (and First) selector function.
|
|
2374
|
|
2375 -- When the Index component is No_Index, this means the iterator
|
|
2376 -- object was constructed without a start expression, in which case the
|
|
2377 -- (reverse) iteration starts from the (logical) beginning of the entire
|
|
2378 -- sequence (corresponding to Container.Last, for a reverse iterator).
|
|
2379
|
|
2380 -- Otherwise, this is iteration over a partial sequence of items.
|
|
2381 -- When the Index component is not No_Index, the iterator object was
|
|
2382 -- constructed with a start expression, that specifies the position
|
|
2383 -- from which the (reverse) partial iteration begins.
|
|
2384
|
|
2385 if Object.Index = No_Index then
|
|
2386 return Last (Object.Container.all);
|
|
2387 else
|
|
2388 return Cursor'(Object.Container, Object.Index);
|
|
2389 end if;
|
|
2390 end Last;
|
|
2391
|
|
2392 ------------------
|
|
2393 -- Last_Element --
|
|
2394 ------------------
|
|
2395
|
|
2396 function Last_Element (Container : Vector) return Element_Type is
|
|
2397 begin
|
|
2398 if Checks and then Container.Last = No_Index then
|
|
2399 raise Constraint_Error with "Container is empty";
|
|
2400 end if;
|
|
2401
|
|
2402 declare
|
|
2403 EA : constant Element_Access :=
|
|
2404 Container.Elements.EA (Container.Last);
|
|
2405 begin
|
|
2406 if Checks and then EA = null then
|
|
2407 raise Constraint_Error with "last element is empty";
|
|
2408 else
|
|
2409 return EA.all;
|
|
2410 end if;
|
|
2411 end;
|
|
2412 end Last_Element;
|
|
2413
|
|
2414 ----------------
|
|
2415 -- Last_Index --
|
|
2416 ----------------
|
|
2417
|
|
2418 function Last_Index (Container : Vector) return Extended_Index is
|
|
2419 begin
|
|
2420 return Container.Last;
|
|
2421 end Last_Index;
|
|
2422
|
|
2423 ------------
|
|
2424 -- Length --
|
|
2425 ------------
|
|
2426
|
|
2427 function Length (Container : Vector) return Count_Type is
|
|
2428 L : constant Index_Type'Base := Container.Last;
|
|
2429 F : constant Index_Type := Index_Type'First;
|
|
2430
|
|
2431 begin
|
|
2432 -- The base range of the index type (Index_Type'Base) might not include
|
|
2433 -- all values for length (Count_Type). Contrariwise, the index type
|
|
2434 -- might include values outside the range of length. Hence we use
|
|
2435 -- whatever type is wider for intermediate values when calculating
|
|
2436 -- length. Note that no matter what the index type is, the maximum
|
|
2437 -- length to which a vector is allowed to grow is always the minimum
|
|
2438 -- of Count_Type'Last and (IT'Last - IT'First + 1).
|
|
2439
|
|
2440 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
|
|
2441 -- to have a base range of -128 .. 127, but the corresponding vector
|
|
2442 -- would have lengths in the range 0 .. 255. In this case we would need
|
|
2443 -- to use Count_Type'Base for intermediate values.
|
|
2444
|
|
2445 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
|
|
2446 -- vector would have a maximum length of 10, but the index values lie
|
|
2447 -- outside the range of Count_Type (which is only 32 bits). In this
|
|
2448 -- case we would need to use Index_Type'Base for intermediate values.
|
|
2449
|
|
2450 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
|
|
2451 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
|
|
2452 else
|
|
2453 return Count_Type (L - F + 1);
|
|
2454 end if;
|
|
2455 end Length;
|
|
2456
|
|
2457 ----------
|
|
2458 -- Move --
|
|
2459 ----------
|
|
2460
|
|
2461 procedure Move
|
|
2462 (Target : in out Vector;
|
|
2463 Source : in out Vector)
|
|
2464 is
|
|
2465 begin
|
|
2466 if Target'Address = Source'Address then
|
|
2467 return;
|
|
2468 end if;
|
|
2469
|
|
2470 TC_Check (Source.TC);
|
|
2471
|
|
2472 Clear (Target); -- Checks busy-bit
|
|
2473
|
|
2474 declare
|
|
2475 Target_Elements : constant Elements_Access := Target.Elements;
|
|
2476 begin
|
|
2477 Target.Elements := Source.Elements;
|
|
2478 Source.Elements := Target_Elements;
|
|
2479 end;
|
|
2480
|
|
2481 Target.Last := Source.Last;
|
|
2482 Source.Last := No_Index;
|
|
2483 end Move;
|
|
2484
|
|
2485 ----------
|
|
2486 -- Next --
|
|
2487 ----------
|
|
2488
|
|
2489 function Next (Position : Cursor) return Cursor is
|
|
2490 begin
|
|
2491 if Position.Container = null then
|
|
2492 return No_Element;
|
|
2493 elsif Position.Index < Position.Container.Last then
|
|
2494 return (Position.Container, Position.Index + 1);
|
|
2495 else
|
|
2496 return No_Element;
|
|
2497 end if;
|
|
2498 end Next;
|
|
2499
|
|
2500 function Next (Object : Iterator; Position : Cursor) return Cursor is
|
|
2501 begin
|
|
2502 if Position.Container = null then
|
|
2503 return No_Element;
|
|
2504 elsif Checks and then Position.Container /= Object.Container then
|
|
2505 raise Program_Error with
|
|
2506 "Position cursor of Next designates wrong vector";
|
|
2507 else
|
|
2508 return Next (Position);
|
|
2509 end if;
|
|
2510 end Next;
|
|
2511
|
|
2512 procedure Next (Position : in out Cursor) is
|
|
2513 begin
|
|
2514 if Position.Container = null then
|
|
2515 return;
|
|
2516 elsif Position.Index < Position.Container.Last then
|
|
2517 Position.Index := Position.Index + 1;
|
|
2518 else
|
|
2519 Position := No_Element;
|
|
2520 end if;
|
|
2521 end Next;
|
|
2522
|
|
2523 -------------
|
|
2524 -- Prepend --
|
|
2525 -------------
|
|
2526
|
|
2527 procedure Prepend (Container : in out Vector; New_Item : Vector) is
|
|
2528 begin
|
|
2529 Insert (Container, Index_Type'First, New_Item);
|
|
2530 end Prepend;
|
|
2531
|
|
2532 procedure Prepend
|
|
2533 (Container : in out Vector;
|
|
2534 New_Item : Element_Type;
|
|
2535 Count : Count_Type := 1)
|
|
2536 is
|
|
2537 begin
|
|
2538 Insert (Container, Index_Type'First, New_Item, Count);
|
|
2539 end Prepend;
|
|
2540
|
|
2541 --------------
|
|
2542 -- Previous --
|
|
2543 --------------
|
|
2544
|
|
2545 function Previous (Position : Cursor) return Cursor is
|
|
2546 begin
|
|
2547 if Position.Container = null then
|
|
2548 return No_Element;
|
|
2549 elsif Position.Index > Index_Type'First then
|
|
2550 return (Position.Container, Position.Index - 1);
|
|
2551 else
|
|
2552 return No_Element;
|
|
2553 end if;
|
|
2554 end Previous;
|
|
2555
|
|
2556 function Previous (Object : Iterator; Position : Cursor) return Cursor is
|
|
2557 begin
|
|
2558 if Position.Container = null then
|
|
2559 return No_Element;
|
|
2560 elsif Checks and then Position.Container /= Object.Container then
|
|
2561 raise Program_Error with
|
|
2562 "Position cursor of Previous designates wrong vector";
|
|
2563 else
|
|
2564 return Previous (Position);
|
|
2565 end if;
|
|
2566 end Previous;
|
|
2567
|
|
2568 procedure Previous (Position : in out Cursor) is
|
|
2569 begin
|
|
2570 if Position.Container = null then
|
|
2571 return;
|
|
2572 elsif Position.Index > Index_Type'First then
|
|
2573 Position.Index := Position.Index - 1;
|
|
2574 else
|
|
2575 Position := No_Element;
|
|
2576 end if;
|
|
2577 end Previous;
|
|
2578
|
|
2579 ----------------------
|
|
2580 -- Pseudo_Reference --
|
|
2581 ----------------------
|
|
2582
|
|
2583 function Pseudo_Reference
|
|
2584 (Container : aliased Vector'Class) return Reference_Control_Type
|
|
2585 is
|
|
2586 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
|
|
2587 begin
|
|
2588 return R : constant Reference_Control_Type := (Controlled with TC) do
|
145
|
2589 Busy (TC.all);
|
111
|
2590 end return;
|
|
2591 end Pseudo_Reference;
|
|
2592
|
|
2593 -------------------
|
|
2594 -- Query_Element --
|
|
2595 -------------------
|
|
2596
|
|
2597 procedure Query_Element
|
|
2598 (Container : Vector;
|
|
2599 Index : Index_Type;
|
|
2600 Process : not null access procedure (Element : Element_Type))
|
|
2601 is
|
|
2602 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
2603 V : Vector renames Container'Unrestricted_Access.all;
|
|
2604
|
|
2605 begin
|
|
2606 if Checks and then Index > Container.Last then
|
|
2607 raise Constraint_Error with "Index is out of range";
|
|
2608 end if;
|
|
2609
|
|
2610 if Checks and then V.Elements.EA (Index) = null then
|
|
2611 raise Constraint_Error with "element is null";
|
|
2612 end if;
|
|
2613
|
|
2614 Process (V.Elements.EA (Index).all);
|
|
2615 end Query_Element;
|
|
2616
|
|
2617 procedure Query_Element
|
|
2618 (Position : Cursor;
|
|
2619 Process : not null access procedure (Element : Element_Type))
|
|
2620 is
|
|
2621 begin
|
|
2622 if Checks and then Position.Container = null then
|
|
2623 raise Constraint_Error with "Position cursor has no element";
|
|
2624 else
|
|
2625 Query_Element (Position.Container.all, Position.Index, Process);
|
|
2626 end if;
|
|
2627 end Query_Element;
|
|
2628
|
|
2629 ----------
|
|
2630 -- Read --
|
|
2631 ----------
|
|
2632
|
|
2633 procedure Read
|
|
2634 (Stream : not null access Root_Stream_Type'Class;
|
|
2635 Container : out Vector)
|
|
2636 is
|
|
2637 Length : Count_Type'Base;
|
|
2638 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
|
|
2639 B : Boolean;
|
|
2640
|
|
2641 begin
|
|
2642 Clear (Container);
|
|
2643
|
|
2644 Count_Type'Base'Read (Stream, Length);
|
|
2645
|
|
2646 if Length > Capacity (Container) then
|
|
2647 Reserve_Capacity (Container, Capacity => Length);
|
|
2648 end if;
|
|
2649
|
|
2650 for J in Count_Type range 1 .. Length loop
|
|
2651 Last := Last + 1;
|
|
2652
|
|
2653 Boolean'Read (Stream, B);
|
|
2654
|
|
2655 if B then
|
|
2656 Container.Elements.EA (Last) :=
|
|
2657 new Element_Type'(Element_Type'Input (Stream));
|
|
2658 end if;
|
|
2659
|
|
2660 Container.Last := Last;
|
|
2661 end loop;
|
|
2662 end Read;
|
|
2663
|
|
2664 procedure Read
|
|
2665 (Stream : not null access Root_Stream_Type'Class;
|
|
2666 Position : out Cursor)
|
|
2667 is
|
|
2668 begin
|
|
2669 raise Program_Error with "attempt to stream vector cursor";
|
|
2670 end Read;
|
|
2671
|
|
2672 procedure Read
|
|
2673 (Stream : not null access Root_Stream_Type'Class;
|
|
2674 Item : out Reference_Type)
|
|
2675 is
|
|
2676 begin
|
|
2677 raise Program_Error with "attempt to stream reference";
|
|
2678 end Read;
|
|
2679
|
|
2680 procedure Read
|
|
2681 (Stream : not null access Root_Stream_Type'Class;
|
|
2682 Item : out Constant_Reference_Type)
|
|
2683 is
|
|
2684 begin
|
|
2685 raise Program_Error with "attempt to stream reference";
|
|
2686 end Read;
|
|
2687
|
|
2688 ---------------
|
|
2689 -- Reference --
|
|
2690 ---------------
|
|
2691
|
|
2692 function Reference
|
|
2693 (Container : aliased in out Vector;
|
|
2694 Position : Cursor) return Reference_Type
|
|
2695 is
|
|
2696 begin
|
|
2697 if Checks then
|
|
2698 if Position.Container = null then
|
|
2699 raise Constraint_Error with "Position cursor has no element";
|
|
2700 end if;
|
|
2701
|
|
2702 if Position.Container /= Container'Unrestricted_Access then
|
|
2703 raise Program_Error with "Position cursor denotes wrong container";
|
|
2704 end if;
|
|
2705
|
|
2706 if Position.Index > Position.Container.Last then
|
|
2707 raise Constraint_Error with "Position cursor is out of range";
|
|
2708 end if;
|
|
2709 end if;
|
|
2710
|
|
2711 declare
|
|
2712 TC : constant Tamper_Counts_Access :=
|
|
2713 Container.TC'Unrestricted_Access;
|
|
2714 begin
|
|
2715 -- The following will raise Constraint_Error if Element is null
|
|
2716
|
|
2717 return R : constant Reference_Type :=
|
|
2718 (Element => Container.Elements.EA (Position.Index),
|
|
2719 Control => (Controlled with TC))
|
|
2720 do
|
145
|
2721 Busy (TC.all);
|
111
|
2722 end return;
|
|
2723 end;
|
|
2724 end Reference;
|
|
2725
|
|
2726 function Reference
|
|
2727 (Container : aliased in out Vector;
|
|
2728 Index : Index_Type) return Reference_Type
|
|
2729 is
|
|
2730 begin
|
|
2731 if Checks and then Index > Container.Last then
|
|
2732 raise Constraint_Error with "Index is out of range";
|
|
2733 end if;
|
|
2734
|
|
2735 declare
|
|
2736 TC : constant Tamper_Counts_Access :=
|
|
2737 Container.TC'Unrestricted_Access;
|
|
2738 begin
|
|
2739 -- The following will raise Constraint_Error if Element is null
|
|
2740
|
|
2741 return R : constant Reference_Type :=
|
|
2742 (Element => Container.Elements.EA (Index),
|
|
2743 Control => (Controlled with TC))
|
|
2744 do
|
145
|
2745 Busy (TC.all);
|
111
|
2746 end return;
|
|
2747 end;
|
|
2748 end Reference;
|
|
2749
|
|
2750 ---------------------
|
|
2751 -- Replace_Element --
|
|
2752 ---------------------
|
|
2753
|
|
2754 procedure Replace_Element
|
|
2755 (Container : in out Vector;
|
|
2756 Index : Index_Type;
|
|
2757 New_Item : Element_Type)
|
|
2758 is
|
|
2759 begin
|
|
2760 if Checks and then Index > Container.Last then
|
|
2761 raise Constraint_Error with "Index is out of range";
|
|
2762 end if;
|
|
2763
|
|
2764 TE_Check (Container.TC);
|
|
2765
|
|
2766 declare
|
|
2767 X : Element_Access := Container.Elements.EA (Index);
|
|
2768
|
|
2769 -- The element allocator may need an accessibility check in the case
|
|
2770 -- where the actual type is class-wide or has access discriminants
|
|
2771 -- (see RM 4.8(10.1) and AI12-0035).
|
|
2772
|
|
2773 pragma Unsuppress (Accessibility_Check);
|
|
2774
|
|
2775 begin
|
|
2776 Container.Elements.EA (Index) := new Element_Type'(New_Item);
|
|
2777 Free (X);
|
|
2778 end;
|
|
2779 end Replace_Element;
|
|
2780
|
|
2781 procedure Replace_Element
|
|
2782 (Container : in out Vector;
|
|
2783 Position : Cursor;
|
|
2784 New_Item : Element_Type)
|
|
2785 is
|
|
2786 begin
|
|
2787 if Checks then
|
|
2788 if Position.Container = null then
|
|
2789 raise Constraint_Error with "Position cursor has no element";
|
|
2790 end if;
|
|
2791
|
|
2792 if Position.Container /= Container'Unrestricted_Access then
|
|
2793 raise Program_Error with "Position cursor denotes wrong container";
|
|
2794 end if;
|
|
2795
|
|
2796 if Position.Index > Container.Last then
|
|
2797 raise Constraint_Error with "Position cursor is out of range";
|
|
2798 end if;
|
|
2799 end if;
|
|
2800
|
|
2801 TE_Check (Container.TC);
|
|
2802
|
|
2803 declare
|
|
2804 X : Element_Access := Container.Elements.EA (Position.Index);
|
|
2805
|
|
2806 -- The element allocator may need an accessibility check in the case
|
|
2807 -- where the actual type is class-wide or has access discriminants
|
|
2808 -- (see RM 4.8(10.1) and AI12-0035).
|
|
2809
|
|
2810 pragma Unsuppress (Accessibility_Check);
|
|
2811
|
|
2812 begin
|
|
2813 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
|
|
2814 Free (X);
|
|
2815 end;
|
|
2816 end Replace_Element;
|
|
2817
|
|
2818 ----------------------
|
|
2819 -- Reserve_Capacity --
|
|
2820 ----------------------
|
|
2821
|
|
2822 procedure Reserve_Capacity
|
|
2823 (Container : in out Vector;
|
|
2824 Capacity : Count_Type)
|
|
2825 is
|
|
2826 N : constant Count_Type := Length (Container);
|
|
2827
|
|
2828 Index : Count_Type'Base;
|
|
2829 Last : Index_Type'Base;
|
|
2830
|
|
2831 begin
|
|
2832 -- Reserve_Capacity can be used to either expand the storage available
|
|
2833 -- for elements (this would be its typical use, in anticipation of
|
|
2834 -- future insertion), or to trim back storage. In the latter case,
|
|
2835 -- storage can only be trimmed back to the limit of the container
|
|
2836 -- length. Note that Reserve_Capacity neither deletes (active) elements
|
|
2837 -- nor inserts elements; it only affects container capacity, never
|
|
2838 -- container length.
|
|
2839
|
|
2840 if Capacity = 0 then
|
|
2841
|
|
2842 -- This is a request to trim back storage, to the minimum amount
|
|
2843 -- possible given the current state of the container.
|
|
2844
|
|
2845 if N = 0 then
|
|
2846
|
|
2847 -- The container is empty, so in this unique case we can
|
|
2848 -- deallocate the entire internal array. Note that an empty
|
|
2849 -- container can never be busy, so there's no need to check the
|
|
2850 -- tampering bits.
|
|
2851
|
|
2852 declare
|
|
2853 X : Elements_Access := Container.Elements;
|
|
2854
|
|
2855 begin
|
|
2856 -- First we remove the internal array from the container, to
|
|
2857 -- handle the case when the deallocation raises an exception
|
|
2858 -- (although that's unlikely, since this is simply an array of
|
|
2859 -- access values, all of which are null).
|
|
2860
|
|
2861 Container.Elements := null;
|
|
2862
|
|
2863 -- Container invariants have been restored, so it is now safe
|
|
2864 -- to attempt to deallocate the internal array.
|
|
2865
|
|
2866 Free (X);
|
|
2867 end;
|
|
2868
|
|
2869 elsif N < Container.Elements.EA'Length then
|
|
2870
|
|
2871 -- The container is not empty, and the current length is less than
|
|
2872 -- the current capacity, so there's storage available to trim. In
|
|
2873 -- this case, we allocate a new internal array having a length
|
|
2874 -- that exactly matches the number of items in the
|
|
2875 -- container. (Reserve_Capacity does not delete active elements,
|
|
2876 -- so this is the best we can do with respect to minimizing
|
|
2877 -- storage).
|
|
2878
|
|
2879 TC_Check (Container.TC);
|
|
2880
|
|
2881 declare
|
|
2882 subtype Array_Index_Subtype is Index_Type'Base range
|
|
2883 Index_Type'First .. Container.Last;
|
|
2884
|
|
2885 Src : Elements_Array renames
|
|
2886 Container.Elements.EA (Array_Index_Subtype);
|
|
2887
|
|
2888 X : Elements_Access := Container.Elements;
|
|
2889
|
|
2890 begin
|
|
2891 -- Although we have isolated the old internal array that we're
|
|
2892 -- going to deallocate, we don't deallocate it until we have
|
|
2893 -- successfully allocated a new one. If there is an exception
|
|
2894 -- during allocation (because there is not enough storage), we
|
|
2895 -- let it propagate without causing any side-effect.
|
|
2896
|
|
2897 Container.Elements := new Elements_Type'(Container.Last, Src);
|
|
2898
|
|
2899 -- We have successfully allocated a new internal array (with a
|
|
2900 -- smaller length than the old one, and containing a copy of
|
|
2901 -- just the active elements in the container), so we can
|
|
2902 -- deallocate the old array.
|
|
2903
|
|
2904 Free (X);
|
|
2905 end;
|
|
2906 end if;
|
|
2907
|
|
2908 return;
|
|
2909 end if;
|
|
2910
|
|
2911 -- Reserve_Capacity can be used to expand the storage available for
|
|
2912 -- elements, but we do not let the capacity grow beyond the number of
|
|
2913 -- values in Index_Type'Range. (Were it otherwise, there would be no way
|
|
2914 -- to refer to the elements with index values greater than
|
|
2915 -- Index_Type'Last, so that storage would be wasted.) Here we compute
|
|
2916 -- the Last index value of the new internal array, in a way that avoids
|
|
2917 -- any possibility of overflow.
|
|
2918
|
|
2919 if Index_Type'Base'Last >= Count_Type_Last then
|
|
2920
|
|
2921 -- We perform a two-part test. First we determine whether the
|
|
2922 -- computed Last value lies in the base range of the type, and then
|
|
2923 -- determine whether it lies in the range of the index (sub)type.
|
|
2924
|
|
2925 -- Last must satisfy this relation:
|
|
2926 -- First + Length - 1 <= Last
|
|
2927 -- We regroup terms:
|
|
2928 -- First - 1 <= Last - Length
|
|
2929 -- Which can rewrite as:
|
|
2930 -- No_Index <= Last - Length
|
|
2931
|
|
2932 if Checks and then
|
|
2933 Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index
|
|
2934 then
|
|
2935 raise Constraint_Error with "Capacity is out of range";
|
|
2936 end if;
|
|
2937
|
|
2938 -- We now know that the computed value of Last is within the base
|
|
2939 -- range of the type, so it is safe to compute its value:
|
|
2940
|
|
2941 Last := No_Index + Index_Type'Base (Capacity);
|
|
2942
|
|
2943 -- Finally we test whether the value is within the range of the
|
|
2944 -- generic actual index subtype:
|
|
2945
|
|
2946 if Checks and then Last > Index_Type'Last then
|
|
2947 raise Constraint_Error with "Capacity is out of range";
|
|
2948 end if;
|
|
2949
|
|
2950 elsif Index_Type'First <= 0 then
|
|
2951
|
|
2952 -- Here we can compute Last directly, in the normal way. We know that
|
|
2953 -- No_Index is less than 0, so there is no danger of overflow when
|
|
2954 -- adding the (positive) value of Capacity.
|
|
2955
|
|
2956 Index := Count_Type'Base (No_Index) + Capacity; -- Last
|
|
2957
|
|
2958 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
|
|
2959 raise Constraint_Error with "Capacity is out of range";
|
|
2960 end if;
|
|
2961
|
|
2962 -- We know that the computed value (having type Count_Type) of Last
|
|
2963 -- is within the range of the generic actual index subtype, so it is
|
|
2964 -- safe to convert to Index_Type:
|
|
2965
|
|
2966 Last := Index_Type'Base (Index);
|
|
2967
|
|
2968 else
|
|
2969 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
|
|
2970 -- must test the length indirectly (by working backwards from the
|
|
2971 -- largest possible value of Last), in order to prevent overflow.
|
|
2972
|
|
2973 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
|
|
2974
|
|
2975 if Checks and then Index < Count_Type'Base (No_Index) then
|
|
2976 raise Constraint_Error with "Capacity is out of range";
|
|
2977 end if;
|
|
2978
|
|
2979 -- We have determined that the value of Capacity would not create a
|
|
2980 -- Last index value outside of the range of Index_Type, so we can now
|
|
2981 -- safely compute its value.
|
|
2982
|
|
2983 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
|
|
2984 end if;
|
|
2985
|
|
2986 -- The requested capacity is non-zero, but we don't know yet whether
|
|
2987 -- this is a request for expansion or contraction of storage.
|
|
2988
|
|
2989 if Container.Elements = null then
|
|
2990
|
|
2991 -- The container is empty (it doesn't even have an internal array),
|
|
2992 -- so this represents a request to allocate storage having the given
|
|
2993 -- capacity.
|
|
2994
|
|
2995 Container.Elements := new Elements_Type (Last);
|
|
2996 return;
|
|
2997 end if;
|
|
2998
|
|
2999 if Capacity <= N then
|
|
3000
|
|
3001 -- This is a request to trim back storage, but only to the limit of
|
|
3002 -- what's already in the container. (Reserve_Capacity never deletes
|
|
3003 -- active elements, it only reclaims excess storage.)
|
|
3004
|
|
3005 if N < Container.Elements.EA'Length then
|
|
3006
|
|
3007 -- The container is not empty (because the requested capacity is
|
|
3008 -- positive, and less than or equal to the container length), and
|
|
3009 -- the current length is less than the current capacity, so there
|
|
3010 -- is storage available to trim. In this case, we allocate a new
|
|
3011 -- internal array having a length that exactly matches the number
|
|
3012 -- of items in the container.
|
|
3013
|
|
3014 TC_Check (Container.TC);
|
|
3015
|
|
3016 declare
|
|
3017 subtype Array_Index_Subtype is Index_Type'Base range
|
|
3018 Index_Type'First .. Container.Last;
|
|
3019
|
|
3020 Src : Elements_Array renames
|
|
3021 Container.Elements.EA (Array_Index_Subtype);
|
|
3022
|
|
3023 X : Elements_Access := Container.Elements;
|
|
3024
|
|
3025 begin
|
|
3026 -- Although we have isolated the old internal array that we're
|
|
3027 -- going to deallocate, we don't deallocate it until we have
|
|
3028 -- successfully allocated a new one. If there is an exception
|
|
3029 -- during allocation (because there is not enough storage), we
|
|
3030 -- let it propagate without causing any side-effect.
|
|
3031
|
|
3032 Container.Elements := new Elements_Type'(Container.Last, Src);
|
|
3033
|
|
3034 -- We have successfully allocated a new internal array (with a
|
|
3035 -- smaller length than the old one, and containing a copy of
|
|
3036 -- just the active elements in the container), so it is now
|
|
3037 -- safe to deallocate the old array.
|
|
3038
|
|
3039 Free (X);
|
|
3040 end;
|
|
3041 end if;
|
|
3042
|
|
3043 return;
|
|
3044 end if;
|
|
3045
|
|
3046 -- The requested capacity is larger than the container length (the
|
|
3047 -- number of active elements). Whether this represents a request for
|
|
3048 -- expansion or contraction of the current capacity depends on what the
|
|
3049 -- current capacity is.
|
|
3050
|
|
3051 if Capacity = Container.Elements.EA'Length then
|
|
3052
|
|
3053 -- The requested capacity matches the existing capacity, so there's
|
|
3054 -- nothing to do here. We treat this case as a no-op, and simply
|
|
3055 -- return without checking the busy bit.
|
|
3056
|
|
3057 return;
|
|
3058 end if;
|
|
3059
|
|
3060 -- There is a change in the capacity of a non-empty container, so a new
|
|
3061 -- internal array will be allocated. (The length of the new internal
|
|
3062 -- array could be less or greater than the old internal array. We know
|
|
3063 -- only that the length of the new internal array is greater than the
|
|
3064 -- number of active elements in the container.) We must check whether
|
|
3065 -- the container is busy before doing anything else.
|
|
3066
|
|
3067 TC_Check (Container.TC);
|
|
3068
|
|
3069 -- We now allocate a new internal array, having a length different from
|
|
3070 -- its current value.
|
|
3071
|
|
3072 declare
|
|
3073 X : Elements_Access := Container.Elements;
|
|
3074
|
|
3075 subtype Index_Subtype is Index_Type'Base range
|
|
3076 Index_Type'First .. Container.Last;
|
|
3077
|
|
3078 begin
|
|
3079 -- We now allocate a new internal array, having a length different
|
|
3080 -- from its current value.
|
|
3081
|
|
3082 Container.Elements := new Elements_Type (Last);
|
|
3083
|
|
3084 -- We have successfully allocated the new internal array, so now we
|
|
3085 -- move the existing elements from the existing the old internal
|
|
3086 -- array onto the new one. Note that we're just copying access
|
|
3087 -- values, to this should not raise any exceptions.
|
|
3088
|
|
3089 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
|
|
3090
|
|
3091 -- We have moved the elements from the old internal array, so now we
|
|
3092 -- can deallocate it.
|
|
3093
|
|
3094 Free (X);
|
|
3095 end;
|
|
3096 end Reserve_Capacity;
|
|
3097
|
|
3098 ----------------------
|
|
3099 -- Reverse_Elements --
|
|
3100 ----------------------
|
|
3101
|
|
3102 procedure Reverse_Elements (Container : in out Vector) is
|
|
3103 begin
|
|
3104 if Container.Length <= 1 then
|
|
3105 return;
|
|
3106 end if;
|
|
3107
|
|
3108 -- The exception behavior for the vector container must match that for
|
|
3109 -- the list container, so we check for cursor tampering here (which will
|
|
3110 -- catch more things) instead of for element tampering (which will catch
|
|
3111 -- fewer things). It's true that the elements of this vector container
|
|
3112 -- could be safely moved around while (say) an iteration is taking place
|
|
3113 -- (iteration only increments the busy counter), and so technically all
|
|
3114 -- we would need here is a test for element tampering (indicated by the
|
|
3115 -- lock counter), that's simply an artifact of our array-based
|
|
3116 -- implementation. Logically Reverse_Elements requires a check for
|
|
3117 -- cursor tampering.
|
|
3118
|
|
3119 TC_Check (Container.TC);
|
|
3120
|
|
3121 declare
|
|
3122 I : Index_Type;
|
|
3123 J : Index_Type;
|
|
3124 E : Elements_Array renames Container.Elements.EA;
|
|
3125
|
|
3126 begin
|
|
3127 I := Index_Type'First;
|
|
3128 J := Container.Last;
|
|
3129 while I < J loop
|
|
3130 declare
|
|
3131 EI : constant Element_Access := E (I);
|
|
3132
|
|
3133 begin
|
|
3134 E (I) := E (J);
|
|
3135 E (J) := EI;
|
|
3136 end;
|
|
3137
|
|
3138 I := I + 1;
|
|
3139 J := J - 1;
|
|
3140 end loop;
|
|
3141 end;
|
|
3142 end Reverse_Elements;
|
|
3143
|
|
3144 ------------------
|
|
3145 -- Reverse_Find --
|
|
3146 ------------------
|
|
3147
|
|
3148 function Reverse_Find
|
|
3149 (Container : Vector;
|
|
3150 Item : Element_Type;
|
|
3151 Position : Cursor := No_Element) return Cursor
|
|
3152 is
|
|
3153 Last : Index_Type'Base;
|
|
3154
|
|
3155 begin
|
|
3156 if Checks and then Position.Container /= null
|
|
3157 and then Position.Container /= Container'Unrestricted_Access
|
|
3158 then
|
|
3159 raise Program_Error with "Position cursor denotes wrong container";
|
|
3160 end if;
|
|
3161
|
|
3162 Last :=
|
|
3163 (if Position.Container = null or else Position.Index > Container.Last
|
|
3164 then Container.Last
|
|
3165 else Position.Index);
|
|
3166
|
|
3167 -- Per AI05-0022, the container implementation is required to detect
|
|
3168 -- element tampering by a generic actual subprogram.
|
|
3169
|
|
3170 declare
|
|
3171 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
3172 begin
|
|
3173 for Indx in reverse Index_Type'First .. Last loop
|
|
3174 if Container.Elements.EA (Indx) /= null
|
|
3175 and then Container.Elements.EA (Indx).all = Item
|
|
3176 then
|
|
3177 return Cursor'(Container'Unrestricted_Access, Indx);
|
|
3178 end if;
|
|
3179 end loop;
|
|
3180
|
|
3181 return No_Element;
|
|
3182 end;
|
|
3183 end Reverse_Find;
|
|
3184
|
|
3185 ------------------------
|
|
3186 -- Reverse_Find_Index --
|
|
3187 ------------------------
|
|
3188
|
|
3189 function Reverse_Find_Index
|
|
3190 (Container : Vector;
|
|
3191 Item : Element_Type;
|
|
3192 Index : Index_Type := Index_Type'Last) return Extended_Index
|
|
3193 is
|
|
3194 -- Per AI05-0022, the container implementation is required to detect
|
|
3195 -- element tampering by a generic actual subprogram.
|
|
3196
|
|
3197 Lock : With_Lock (Container.TC'Unrestricted_Access);
|
|
3198
|
|
3199 Last : constant Index_Type'Base :=
|
|
3200 Index_Type'Min (Container.Last, Index);
|
|
3201
|
|
3202 begin
|
|
3203 for Indx in reverse Index_Type'First .. Last loop
|
|
3204 if Container.Elements.EA (Indx) /= null
|
|
3205 and then Container.Elements.EA (Indx).all = Item
|
|
3206 then
|
|
3207 return Indx;
|
|
3208 end if;
|
|
3209 end loop;
|
|
3210
|
|
3211 return No_Index;
|
|
3212 end Reverse_Find_Index;
|
|
3213
|
|
3214 ---------------------
|
|
3215 -- Reverse_Iterate --
|
|
3216 ---------------------
|
|
3217
|
|
3218 procedure Reverse_Iterate
|
|
3219 (Container : Vector;
|
|
3220 Process : not null access procedure (Position : Cursor))
|
|
3221 is
|
|
3222 Busy : With_Busy (Container.TC'Unrestricted_Access);
|
|
3223 begin
|
|
3224 for Indx in reverse Index_Type'First .. Container.Last loop
|
|
3225 Process (Cursor'(Container'Unrestricted_Access, Indx));
|
|
3226 end loop;
|
|
3227 end Reverse_Iterate;
|
|
3228
|
|
3229 ----------------
|
|
3230 -- Set_Length --
|
|
3231 ----------------
|
|
3232
|
|
3233 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
|
|
3234 Count : constant Count_Type'Base := Container.Length - Length;
|
|
3235
|
|
3236 begin
|
|
3237 -- Set_Length allows the user to set the length explicitly, instead of
|
|
3238 -- implicitly as a side-effect of deletion or insertion. If the
|
|
3239 -- requested length is less than the current length, this is equivalent
|
|
3240 -- to deleting items from the back end of the vector. If the requested
|
|
3241 -- length is greater than the current length, then this is equivalent to
|
|
3242 -- inserting "space" (nonce items) at the end.
|
|
3243
|
|
3244 if Count >= 0 then
|
|
3245 Container.Delete_Last (Count);
|
|
3246
|
|
3247 elsif Checks and then Container.Last >= Index_Type'Last then
|
|
3248 raise Constraint_Error with "vector is already at its maximum length";
|
|
3249
|
|
3250 else
|
|
3251 Container.Insert_Space (Container.Last + 1, -Count);
|
|
3252 end if;
|
|
3253 end Set_Length;
|
|
3254
|
|
3255 ----------
|
|
3256 -- Swap --
|
|
3257 ----------
|
|
3258
|
|
3259 procedure Swap (Container : in out Vector; I, J : Index_Type) is
|
|
3260 begin
|
|
3261 if Checks then
|
|
3262 if I > Container.Last then
|
|
3263 raise Constraint_Error with "I index is out of range";
|
|
3264 end if;
|
|
3265
|
|
3266 if J > Container.Last then
|
|
3267 raise Constraint_Error with "J index is out of range";
|
|
3268 end if;
|
|
3269 end if;
|
|
3270
|
|
3271 if I = J then
|
|
3272 return;
|
|
3273 end if;
|
|
3274
|
|
3275 TE_Check (Container.TC);
|
|
3276
|
|
3277 declare
|
|
3278 EI : Element_Access renames Container.Elements.EA (I);
|
|
3279 EJ : Element_Access renames Container.Elements.EA (J);
|
|
3280
|
|
3281 EI_Copy : constant Element_Access := EI;
|
|
3282
|
|
3283 begin
|
|
3284 EI := EJ;
|
|
3285 EJ := EI_Copy;
|
|
3286 end;
|
|
3287 end Swap;
|
|
3288
|
|
3289 procedure Swap
|
|
3290 (Container : in out Vector;
|
|
3291 I, J : Cursor)
|
|
3292 is
|
|
3293 begin
|
|
3294 if Checks then
|
|
3295 if I.Container = null then
|
|
3296 raise Constraint_Error with "I cursor has no element";
|
|
3297 end if;
|
|
3298
|
|
3299 if J.Container = null then
|
|
3300 raise Constraint_Error with "J cursor has no element";
|
|
3301 end if;
|
|
3302
|
|
3303 if I.Container /= Container'Unrestricted_Access then
|
|
3304 raise Program_Error with "I cursor denotes wrong container";
|
|
3305 end if;
|
|
3306
|
|
3307 if J.Container /= Container'Unrestricted_Access then
|
|
3308 raise Program_Error with "J cursor denotes wrong container";
|
|
3309 end if;
|
|
3310 end if;
|
|
3311
|
|
3312 Swap (Container, I.Index, J.Index);
|
|
3313 end Swap;
|
|
3314
|
|
3315 ---------------
|
|
3316 -- To_Cursor --
|
|
3317 ---------------
|
|
3318
|
|
3319 function To_Cursor
|
|
3320 (Container : Vector;
|
|
3321 Index : Extended_Index) return Cursor
|
|
3322 is
|
|
3323 begin
|
|
3324 if Index not in Index_Type'First .. Container.Last then
|
|
3325 return No_Element;
|
|
3326 end if;
|
|
3327
|
|
3328 return Cursor'(Container'Unrestricted_Access, Index);
|
|
3329 end To_Cursor;
|
|
3330
|
|
3331 --------------
|
|
3332 -- To_Index --
|
|
3333 --------------
|
|
3334
|
|
3335 function To_Index (Position : Cursor) return Extended_Index is
|
|
3336 begin
|
|
3337 if Position.Container = null then
|
|
3338 return No_Index;
|
|
3339 elsif Position.Index <= Position.Container.Last then
|
|
3340 return Position.Index;
|
|
3341 else
|
|
3342 return No_Index;
|
|
3343 end if;
|
|
3344 end To_Index;
|
|
3345
|
|
3346 ---------------
|
|
3347 -- To_Vector --
|
|
3348 ---------------
|
|
3349
|
|
3350 function To_Vector (Length : Count_Type) return Vector is
|
|
3351 Index : Count_Type'Base;
|
|
3352 Last : Index_Type'Base;
|
|
3353 Elements : Elements_Access;
|
|
3354
|
|
3355 begin
|
|
3356 if Length = 0 then
|
|
3357 return Empty_Vector;
|
|
3358 end if;
|
|
3359
|
|
3360 -- We create a vector object with a capacity that matches the specified
|
|
3361 -- Length, but we do not allow the vector capacity (the length of the
|
|
3362 -- internal array) to exceed the number of values in Index_Type'Range
|
|
3363 -- (otherwise, there would be no way to refer to those components via an
|
|
3364 -- index). We must therefore check whether the specified Length would
|
|
3365 -- create a Last index value greater than Index_Type'Last.
|
|
3366
|
|
3367 if Index_Type'Base'Last >= Count_Type_Last then
|
|
3368
|
|
3369 -- We perform a two-part test. First we determine whether the
|
|
3370 -- computed Last value lies in the base range of the type, and then
|
|
3371 -- determine whether it lies in the range of the index (sub)type.
|
|
3372
|
|
3373 -- Last must satisfy this relation:
|
|
3374 -- First + Length - 1 <= Last
|
|
3375 -- We regroup terms:
|
|
3376 -- First - 1 <= Last - Length
|
|
3377 -- Which can rewrite as:
|
|
3378 -- No_Index <= Last - Length
|
|
3379
|
|
3380 if Checks and then
|
|
3381 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
|
|
3382 then
|
|
3383 raise Constraint_Error with "Length is out of range";
|
|
3384 end if;
|
|
3385
|
|
3386 -- We now know that the computed value of Last is within the base
|
|
3387 -- range of the type, so it is safe to compute its value:
|
|
3388
|
|
3389 Last := No_Index + Index_Type'Base (Length);
|
|
3390
|
|
3391 -- Finally we test whether the value is within the range of the
|
|
3392 -- generic actual index subtype:
|
|
3393
|
|
3394 if Checks and then Last > Index_Type'Last then
|
|
3395 raise Constraint_Error with "Length is out of range";
|
|
3396 end if;
|
|
3397
|
|
3398 elsif Index_Type'First <= 0 then
|
|
3399
|
|
3400 -- Here we can compute Last directly, in the normal way. We know that
|
|
3401 -- No_Index is less than 0, so there is no danger of overflow when
|
|
3402 -- adding the (positive) value of Length.
|
|
3403
|
|
3404 Index := Count_Type'Base (No_Index) + Length; -- Last
|
|
3405
|
|
3406 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
|
|
3407 raise Constraint_Error with "Length is out of range";
|
|
3408 end if;
|
|
3409
|
|
3410 -- We know that the computed value (having type Count_Type) of Last
|
|
3411 -- is within the range of the generic actual index subtype, so it is
|
|
3412 -- safe to convert to Index_Type:
|
|
3413
|
|
3414 Last := Index_Type'Base (Index);
|
|
3415
|
|
3416 else
|
|
3417 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
|
|
3418 -- must test the length indirectly (by working backwards from the
|
|
3419 -- largest possible value of Last), in order to prevent overflow.
|
|
3420
|
|
3421 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
|
|
3422
|
|
3423 if Checks and then Index < Count_Type'Base (No_Index) then
|
|
3424 raise Constraint_Error with "Length is out of range";
|
|
3425 end if;
|
|
3426
|
|
3427 -- We have determined that the value of Length would not create a
|
|
3428 -- Last index value outside of the range of Index_Type, so we can now
|
|
3429 -- safely compute its value.
|
|
3430
|
|
3431 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
|
|
3432 end if;
|
|
3433
|
|
3434 Elements := new Elements_Type (Last);
|
|
3435
|
|
3436 return Vector'(Controlled with Elements, Last, TC => <>);
|
|
3437 end To_Vector;
|
|
3438
|
|
3439 function To_Vector
|
|
3440 (New_Item : Element_Type;
|
|
3441 Length : Count_Type) return Vector
|
|
3442 is
|
|
3443 Index : Count_Type'Base;
|
|
3444 Last : Index_Type'Base;
|
|
3445 Elements : Elements_Access;
|
|
3446
|
|
3447 begin
|
|
3448 if Length = 0 then
|
|
3449 return Empty_Vector;
|
|
3450 end if;
|
|
3451
|
|
3452 -- We create a vector object with a capacity that matches the specified
|
|
3453 -- Length, but we do not allow the vector capacity (the length of the
|
|
3454 -- internal array) to exceed the number of values in Index_Type'Range
|
|
3455 -- (otherwise, there would be no way to refer to those components via an
|
|
3456 -- index). We must therefore check whether the specified Length would
|
|
3457 -- create a Last index value greater than Index_Type'Last.
|
|
3458
|
|
3459 if Index_Type'Base'Last >= Count_Type_Last then
|
|
3460
|
|
3461 -- We perform a two-part test. First we determine whether the
|
|
3462 -- computed Last value lies in the base range of the type, and then
|
|
3463 -- determine whether it lies in the range of the index (sub)type.
|
|
3464
|
|
3465 -- Last must satisfy this relation:
|
|
3466 -- First + Length - 1 <= Last
|
|
3467 -- We regroup terms:
|
|
3468 -- First - 1 <= Last - Length
|
|
3469 -- Which can rewrite as:
|
|
3470 -- No_Index <= Last - Length
|
|
3471
|
|
3472 if Checks and then
|
|
3473 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
|
|
3474 then
|
|
3475 raise Constraint_Error with "Length is out of range";
|
|
3476 end if;
|
|
3477
|
|
3478 -- We now know that the computed value of Last is within the base
|
|
3479 -- range of the type, so it is safe to compute its value:
|
|
3480
|
|
3481 Last := No_Index + Index_Type'Base (Length);
|
|
3482
|
|
3483 -- Finally we test whether the value is within the range of the
|
|
3484 -- generic actual index subtype:
|
|
3485
|
|
3486 if Checks and then Last > Index_Type'Last then
|
|
3487 raise Constraint_Error with "Length is out of range";
|
|
3488 end if;
|
|
3489
|
|
3490 elsif Index_Type'First <= 0 then
|
|
3491
|
|
3492 -- Here we can compute Last directly, in the normal way. We know that
|
|
3493 -- No_Index is less than 0, so there is no danger of overflow when
|
|
3494 -- adding the (positive) value of Length.
|
|
3495
|
|
3496 Index := Count_Type'Base (No_Index) + Length; -- Last
|
|
3497
|
|
3498 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
|
|
3499 raise Constraint_Error with "Length is out of range";
|
|
3500 end if;
|
|
3501
|
|
3502 -- We know that the computed value (having type Count_Type) of Last
|
|
3503 -- is within the range of the generic actual index subtype, so it is
|
|
3504 -- safe to convert to Index_Type:
|
|
3505
|
|
3506 Last := Index_Type'Base (Index);
|
|
3507
|
|
3508 else
|
|
3509 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
|
|
3510 -- must test the length indirectly (by working backwards from the
|
|
3511 -- largest possible value of Last), in order to prevent overflow.
|
|
3512
|
|
3513 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
|
|
3514
|
|
3515 if Checks and then Index < Count_Type'Base (No_Index) then
|
|
3516 raise Constraint_Error with "Length is out of range";
|
|
3517 end if;
|
|
3518
|
|
3519 -- We have determined that the value of Length would not create a
|
|
3520 -- Last index value outside of the range of Index_Type, so we can now
|
|
3521 -- safely compute its value.
|
|
3522
|
|
3523 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
|
|
3524 end if;
|
|
3525
|
|
3526 Elements := new Elements_Type (Last);
|
|
3527
|
|
3528 -- We use Last as the index of the loop used to populate the internal
|
|
3529 -- array with items. In general, we prefer to initialize the loop index
|
|
3530 -- immediately prior to entering the loop. However, Last is also used in
|
|
3531 -- the exception handler (to reclaim elements that have been allocated,
|
|
3532 -- before propagating the exception), and the initialization of Last
|
|
3533 -- after entering the block containing the handler confuses some static
|
|
3534 -- analysis tools, with respect to whether Last has been properly
|
|
3535 -- initialized when the handler executes. So here we initialize our loop
|
|
3536 -- variable earlier than we prefer, before entering the block, so there
|
|
3537 -- is no ambiguity.
|
|
3538
|
|
3539 Last := Index_Type'First;
|
|
3540
|
|
3541 declare
|
|
3542 -- The element allocator may need an accessibility check in the case
|
|
3543 -- where the actual type is class-wide or has access discriminants
|
|
3544 -- (see RM 4.8(10.1) and AI12-0035).
|
|
3545
|
|
3546 pragma Unsuppress (Accessibility_Check);
|
|
3547
|
|
3548 begin
|
|
3549 loop
|
|
3550 Elements.EA (Last) := new Element_Type'(New_Item);
|
|
3551 exit when Last = Elements.Last;
|
|
3552 Last := Last + 1;
|
|
3553 end loop;
|
|
3554
|
|
3555 exception
|
|
3556 when others =>
|
|
3557 for J in Index_Type'First .. Last - 1 loop
|
|
3558 Free (Elements.EA (J));
|
|
3559 end loop;
|
|
3560
|
|
3561 Free (Elements);
|
|
3562 raise;
|
|
3563 end;
|
|
3564
|
|
3565 return (Controlled with Elements, Last, TC => <>);
|
|
3566 end To_Vector;
|
|
3567
|
|
3568 --------------------
|
|
3569 -- Update_Element --
|
|
3570 --------------------
|
|
3571
|
|
3572 procedure Update_Element
|
|
3573 (Container : in out Vector;
|
|
3574 Index : Index_Type;
|
|
3575 Process : not null access procedure (Element : in out Element_Type))
|
|
3576 is
|
|
3577 Lock : With_Lock (Container.TC'Unchecked_Access);
|
|
3578 begin
|
|
3579 if Checks and then Index > Container.Last then
|
|
3580 raise Constraint_Error with "Index is out of range";
|
|
3581 end if;
|
|
3582
|
|
3583 if Checks and then Container.Elements.EA (Index) = null then
|
|
3584 raise Constraint_Error with "element is null";
|
|
3585 end if;
|
|
3586
|
|
3587 Process (Container.Elements.EA (Index).all);
|
|
3588 end Update_Element;
|
|
3589
|
|
3590 procedure Update_Element
|
|
3591 (Container : in out Vector;
|
|
3592 Position : Cursor;
|
|
3593 Process : not null access procedure (Element : in out Element_Type))
|
|
3594 is
|
|
3595 begin
|
|
3596 if Checks then
|
|
3597 if Position.Container = null then
|
|
3598 raise Constraint_Error with "Position cursor has no element";
|
|
3599 elsif Position.Container /= Container'Unrestricted_Access then
|
|
3600 raise Program_Error with "Position cursor denotes wrong container";
|
|
3601 end if;
|
|
3602 end if;
|
|
3603
|
|
3604 Update_Element (Container, Position.Index, Process);
|
|
3605 end Update_Element;
|
|
3606
|
|
3607 -----------
|
|
3608 -- Write --
|
|
3609 -----------
|
|
3610
|
|
3611 procedure Write
|
|
3612 (Stream : not null access Root_Stream_Type'Class;
|
|
3613 Container : Vector)
|
|
3614 is
|
|
3615 N : constant Count_Type := Length (Container);
|
|
3616
|
|
3617 begin
|
|
3618 Count_Type'Base'Write (Stream, N);
|
|
3619
|
|
3620 if N = 0 then
|
|
3621 return;
|
|
3622 end if;
|
|
3623
|
|
3624 declare
|
|
3625 E : Elements_Array renames Container.Elements.EA;
|
|
3626
|
|
3627 begin
|
|
3628 for Indx in Index_Type'First .. Container.Last loop
|
|
3629 if E (Indx) = null then
|
|
3630 Boolean'Write (Stream, False);
|
|
3631 else
|
|
3632 Boolean'Write (Stream, True);
|
|
3633 Element_Type'Output (Stream, E (Indx).all);
|
|
3634 end if;
|
|
3635 end loop;
|
|
3636 end;
|
|
3637 end Write;
|
|
3638
|
|
3639 procedure Write
|
|
3640 (Stream : not null access Root_Stream_Type'Class;
|
|
3641 Position : Cursor)
|
|
3642 is
|
|
3643 begin
|
|
3644 raise Program_Error with "attempt to stream vector cursor";
|
|
3645 end Write;
|
|
3646
|
|
3647 procedure Write
|
|
3648 (Stream : not null access Root_Stream_Type'Class;
|
|
3649 Item : Reference_Type)
|
|
3650 is
|
|
3651 begin
|
|
3652 raise Program_Error with "attempt to stream reference";
|
|
3653 end Write;
|
|
3654
|
|
3655 procedure Write
|
|
3656 (Stream : not null access Root_Stream_Type'Class;
|
|
3657 Item : Constant_Reference_Type)
|
|
3658 is
|
|
3659 begin
|
|
3660 raise Program_Error with "attempt to stream reference";
|
|
3661 end Write;
|
|
3662
|
|
3663 end Ada.Containers.Indefinite_Vectors;
|