File : a-coinve.adb
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 -- --
9 -- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
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
327 Lock (TC.all);
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
351 Lock (TC.all);
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
2589 Lock (TC.all);
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
2721 Lock (TC.all);
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
2745 Lock (TC.all);
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;