1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
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 --
9 -- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
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/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Generic_Array_Sort
;
31 with Ada
.Unchecked_Deallocation
;
33 with System
; use type System
.Address
;
35 package body Ada
.Containers
.Indefinite_Vectors
is
38 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
41 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
43 type Iterator
is new Limited_Controlled
and
44 Vector_Iterator_Interfaces
.Reversible_Iterator
with
46 Container
: Vector_Access
;
47 Index
: Index_Type
'Base;
50 overriding
procedure Finalize
(Object
: in out Iterator
);
52 overriding
function First
(Object
: Iterator
) return Cursor
;
53 overriding
function Last
(Object
: Iterator
) return Cursor
;
55 overriding
function Next
57 Position
: Cursor
) return Cursor
;
59 overriding
function Previous
61 Position
: Cursor
) return Cursor
;
67 function "&" (Left
, Right
: Vector
) return Vector
is
68 LN
: constant Count_Type
:= Length
(Left
);
69 RN
: constant Count_Type
:= Length
(Right
);
70 N
: Count_Type
'Base; -- length of result
71 J
: Count_Type
'Base; -- for computing intermediate values
72 Last
: Index_Type
'Base; -- Last index of result
75 -- We decide that the capacity of the result is the sum of the lengths
76 -- of the vector parameters. We could decide to make it larger, but we
77 -- have no basis for knowing how much larger, so we just allocate the
78 -- minimum amount of storage.
80 -- Here we handle the easy cases first, when one of the vector
81 -- parameters is empty. (We say "easy" because there's nothing to
82 -- compute, that can potentially overflow.)
90 RE
: Elements_Array
renames
91 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
93 Elements
: Elements_Access
:=
94 new Elements_Type
(Right
.Last
);
97 -- Elements of an indefinite vector are allocated, so we cannot
98 -- use simple slice assignment to give a value to our result.
99 -- Hence we must walk the array of the Right vector, and copy
100 -- each source element individually.
102 for I
in Elements
.EA
'Range loop
104 if RE
(I
) /= null then
105 Elements
.EA
(I
) := new Element_Type
'(RE (I).all);
110 for J in Index_Type'First .. I - 1 loop
111 Free (Elements.EA (J));
119 return (Controlled with Elements, Right.Last, 0, 0);
126 LE : Elements_Array renames
127 Left.Elements.EA (Index_Type'First .. Left.Last);
129 Elements : Elements_Access :=
130 new Elements_Type (Left.Last);
133 -- Elements of an indefinite vector are allocated, so we cannot
134 -- use simple slice assignment to give a value to our result.
135 -- Hence we must walk the array of the Left vector, and copy
136 -- each source element individually.
138 for I in Elements.EA'Range loop
140 if LE (I) /= null then
141 Elements.EA (I) := new Element_Type'(LE
(I
).all);
146 for J
in Index_Type
'First .. I
- 1 loop
147 Free
(Elements
.EA
(J
));
155 return (Controlled
with Elements
, Left
.Last
, 0, 0);
159 -- Neither of the vector parameters is empty, so we must compute the
160 -- length of the result vector and its last index. (This is the harder
161 -- case, because our computations must avoid overflow.)
163 -- There are two constraints we need to satisfy. The first constraint is
164 -- that a container cannot have more than Count_Type'Last elements, so
165 -- we must check the sum of the combined lengths. Note that we cannot
166 -- simply add the lengths, because of the possibility of overflow.
168 if LN
> Count_Type
'Last - RN
then
169 raise Constraint_Error
with "new length is out of range";
172 -- It is now safe compute the length of the new vector.
176 -- The second constraint is that the new Last index value cannot
177 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
178 -- Count_Type'Base as the type for intermediate values.
180 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
182 -- We perform a two-part test. First we determine whether the
183 -- computed Last value lies in the base range of the type, and then
184 -- determine whether it lies in the range of the index (sub)type.
186 -- Last must satisfy this relation:
187 -- First + Length - 1 <= Last
189 -- First - 1 <= Last - Length
190 -- Which can rewrite as:
191 -- No_Index <= Last - Length
193 if Index_Type'Base'Last
- Index_Type
'Base (N
) < No_Index
then
194 raise Constraint_Error
with "new length is out of range";
197 -- We now know that the computed value of Last is within the base
198 -- range of the type, so it is safe to compute its value:
200 Last
:= No_Index
+ Index_Type
'Base (N
);
202 -- Finally we test whether the value is within the range of the
203 -- generic actual index subtype:
205 if Last
> Index_Type
'Last then
206 raise Constraint_Error
with "new length is out of range";
209 elsif Index_Type
'First <= 0 then
211 -- Here we can compute Last directly, in the normal way. We know that
212 -- No_Index is less than 0, so there is no danger of overflow when
213 -- adding the (positive) value of length.
215 J
:= Count_Type
'Base (No_Index
) + N
; -- Last
217 if J
> Count_Type
'Base (Index_Type
'Last) then
218 raise Constraint_Error
with "new length is out of range";
221 -- We know that the computed value (having type Count_Type) of Last
222 -- is within the range of the generic actual index subtype, so it is
223 -- safe to convert to Index_Type:
225 Last
:= Index_Type
'Base (J
);
228 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
229 -- must test the length indirectly (by working backwards from the
230 -- largest possible value of Last), in order to prevent overflow.
232 J
:= Count_Type
'Base (Index_Type
'Last) - N
; -- No_Index
234 if J
< Count_Type
'Base (No_Index
) then
235 raise Constraint_Error
with "new length is out of range";
238 -- We have determined that the result length would not create a Last
239 -- index value outside of the range of Index_Type, so we can now
240 -- safely compute its value.
242 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + N
);
246 LE
: Elements_Array
renames
247 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
249 RE
: Elements_Array
renames
250 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
252 Elements
: Elements_Access
:= new Elements_Type
(Last
);
254 I
: Index_Type
'Base := No_Index
;
257 -- Elements of an indefinite vector are allocated, so we cannot use
258 -- simple slice assignment to give a value to our result. Hence we
259 -- must walk the array of each vector parameter, and copy each source
260 -- element individually.
262 for LI
in LE
'Range loop
266 if LE
(LI
) /= null then
267 Elements
.EA
(I
) := new Element_Type
'(LE (LI).all);
272 for J in Index_Type'First .. I - 1 loop
273 Free (Elements.EA (J));
281 for RI in RE'Range loop
285 if RE (RI) /= null then
286 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
291 for J
in Index_Type
'First .. I
- 1 loop
292 Free
(Elements
.EA
(J
));
300 return (Controlled
with Elements
, Last
, 0, 0);
304 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
306 -- We decide that the capacity of the result is the sum of the lengths
307 -- of the parameters. We could decide to make it larger, but we have no
308 -- basis for knowing how much larger, so we just allocate the minimum
309 -- amount of storage.
311 -- Here we handle the easy case first, when the vector parameter (Left)
314 if Left
.Is_Empty
then
316 Elements
: Elements_Access
:= new Elements_Type
(Index_Type
'First);
320 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Right);
327 return (Controlled with Elements, Index_Type'First, 0, 0);
331 -- The vector parameter is not empty, so we must compute the length of
332 -- the result vector and its last index, but in such a way that overflow
333 -- is avoided. We must satisfy two constraints: the new length cannot
334 -- exceed Count_Type'Last, and the new Last index cannot exceed
337 if Left.Length = Count_Type'Last then
338 raise Constraint_Error with "new length is out of range";
341 if Left.Last >= Index_Type'Last then
342 raise Constraint_Error with "new length is out of range";
346 Last : constant Index_Type := Left.Last + 1;
348 LE : Elements_Array renames
349 Left.Elements.EA (Index_Type'First .. Left.Last);
351 Elements : Elements_Access :=
352 new Elements_Type (Last);
355 for I in LE'Range loop
357 if LE (I) /= null then
358 Elements.EA (I) := new Element_Type'(LE
(I
).all);
363 for J
in Index_Type
'First .. I
- 1 loop
364 Free
(Elements
.EA
(J
));
373 Elements
.EA
(Last
) := new Element_Type
'(Right);
377 for J in Index_Type'First .. Last - 1 loop
378 Free (Elements.EA (J));
385 return (Controlled with Elements, Last, 0, 0);
389 function "&" (Left : Element_Type; Right : Vector) return Vector is
391 -- We decide that the capacity of the result is the sum of the lengths
392 -- of the parameters. We could decide to make it larger, but we have no
393 -- basis for knowing how much larger, so we just allocate the minimum
394 -- amount of storage.
396 -- Here we handle the easy case first, when the vector parameter (Right)
399 if Right.Is_Empty then
401 Elements : Elements_Access := new Elements_Type (Index_Type'First);
405 Elements.EA (Index_Type'First) := new Element_Type'(Left
);
412 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
416 -- The vector parameter is not empty, so we must compute the length of
417 -- the result vector and its last index, but in such a way that overflow
418 -- is avoided. We must satisfy two constraints: the new length cannot
419 -- exceed Count_Type'Last, and the new Last index cannot exceed
422 if Right
.Length
= Count_Type
'Last then
423 raise Constraint_Error
with "new length is out of range";
426 if Right
.Last
>= Index_Type
'Last then
427 raise Constraint_Error
with "new length is out of range";
431 Last
: constant Index_Type
:= Right
.Last
+ 1;
433 RE
: Elements_Array
renames
434 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
436 Elements
: Elements_Access
:=
437 new Elements_Type
(Last
);
439 I
: Index_Type
'Base := Index_Type
'First;
443 Elements
.EA
(I
) := new Element_Type
'(Left);
450 for RI in RE'Range loop
454 if RE (RI) /= null then
455 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
460 for J
in Index_Type
'First .. I
- 1 loop
461 Free
(Elements
.EA
(J
));
469 return (Controlled
with Elements
, Last
, 0, 0);
473 function "&" (Left
, Right
: Element_Type
) return Vector
is
475 -- We decide that the capacity of the result is the sum of the lengths
476 -- of the parameters. We could decide to make it larger, but we have no
477 -- basis for knowing how much larger, so we just allocate the minimum
478 -- amount of storage.
480 -- We must compute the length of the result vector and its last index,
481 -- but in such a way that overflow is avoided. We must satisfy two
482 -- constraints: the new length cannot exceed Count_Type'Last (here, we
483 -- know that that condition is satisfied), and the new Last index cannot
484 -- exceed Index_Type'Last.
486 if Index_Type
'First >= Index_Type
'Last then
487 raise Constraint_Error
with "new length is out of range";
491 Last
: constant Index_Type
:= Index_Type
'First + 1;
492 Elements
: Elements_Access
:= new Elements_Type
(Last
);
496 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Left);
504 Elements.EA (Last) := new Element_Type'(Right
);
507 Free
(Elements
.EA
(Index_Type
'First));
512 return (Controlled
with Elements
, Last
, 0, 0);
520 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
522 if Left
'Address = Right
'Address then
526 if Left
.Last
/= Right
.Last
then
530 for J
in Index_Type
'First .. Left
.Last
loop
531 if Left
.Elements
.EA
(J
) = null then
532 if Right
.Elements
.EA
(J
) /= null then
536 elsif Right
.Elements
.EA
(J
) = null then
539 elsif Left
.Elements
.EA
(J
).all /= Right
.Elements
.EA
(J
).all then
551 procedure Adjust
(Container
: in out Vector
) is
553 if Container
.Last
= No_Index
then
554 Container
.Elements
:= null;
559 L
: constant Index_Type
:= Container
.Last
;
560 E
: Elements_Array
renames
561 Container
.Elements
.EA
(Index_Type
'First .. L
);
564 Container
.Elements
:= null;
565 Container
.Last
:= No_Index
;
569 Container
.Elements
:= new Elements_Type
(L
);
571 for I
in E
'Range loop
572 if E
(I
) /= null then
573 Container
.Elements
.EA
(I
) := new Element_Type
'(E (I).all);
581 procedure Adjust (Control : in out Reference_Control_Type) is
583 if Control.Container /= null then
585 C : Vector renames Control.Container.all;
586 B : Natural renames C.Busy;
587 L : Natural renames C.Lock;
599 procedure Append (Container : in out Vector; New_Item : Vector) is
601 if Is_Empty (New_Item) then
605 if Container.Last = Index_Type'Last then
606 raise Constraint_Error with "vector is already at its maximum length";
616 (Container : in out Vector;
617 New_Item : Element_Type;
618 Count : Count_Type := 1)
625 if Container.Last = Index_Type'Last then
626 raise Constraint_Error with "vector is already at its maximum length";
640 procedure Assign (Target : in out Vector; Source : Vector) is
642 if Target'Address = Source'Address then
647 Target.Append (Source);
654 function Capacity (Container : Vector) return Count_Type is
656 if Container.Elements = null then
660 return Container.Elements.EA'Length;
667 procedure Clear (Container : in out Vector) is
669 if Container.Busy > 0 then
670 raise Program_Error with
671 "attempt to tamper with cursors (vector is busy)";
674 while Container.Last >= Index_Type'First loop
676 X : Element_Access := Container.Elements.EA (Container.Last);
678 Container.Elements.EA (Container.Last) := null;
679 Container.Last := Container.Last - 1;
685 ------------------------
686 -- Constant_Reference --
687 ------------------------
689 function Constant_Reference
690 (Container : aliased Vector;
691 Position : Cursor) return Constant_Reference_Type
696 if Position.Container = null then
697 raise Constraint_Error with "Position cursor has no element";
700 if Position.Container /= Container'Unrestricted_Access then
701 raise Program_Error with "Position cursor denotes wrong container";
704 if Position.Index > Position.Container.Last then
705 raise Constraint_Error with "Position cursor is out of range";
708 E := Container.Elements.EA (Position.Index);
711 raise Constraint_Error with "element at Position is empty";
715 C : Vector renames Container'Unrestricted_Access.all;
716 B : Natural renames C.Busy;
717 L : Natural renames C.Lock;
719 return R : constant Constant_Reference_Type :=
720 (Element => E.all'Access,
722 (Controlled with Container'Unrestricted_Access))
728 end Constant_Reference;
730 function Constant_Reference
731 (Container : aliased Vector;
732 Index : Index_Type) return Constant_Reference_Type
737 if Index > Container.Last then
738 raise Constraint_Error with "Index is out of range";
741 E := Container.Elements.EA (Index);
744 raise Constraint_Error with "element at Index is empty";
748 C : Vector renames Container'Unrestricted_Access.all;
749 B : Natural renames C.Busy;
750 L : Natural renames C.Lock;
752 return R : constant Constant_Reference_Type :=
753 (Element => E.all'Access,
755 (Controlled with Container'Unrestricted_Access))
761 end Constant_Reference;
769 Item : Element_Type) return Boolean
772 return Find_Index (Container, Item) /= No_Index;
781 Capacity : Count_Type := 0) return Vector
789 elsif Capacity >= Source.Length then
794 with "Requested capacity is less than Source length";
797 return Target : Vector do
798 Target.Reserve_Capacity (C);
799 Target.Assign (Source);
808 (Container : in out Vector;
809 Index : Extended_Index;
810 Count : Count_Type := 1)
812 Old_Last : constant Index_Type'Base := Container.Last;
813 New_Last : Index_Type'Base;
814 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
815 J : Index_Type'Base; -- first index of items that slide down
818 -- Delete removes items from the vector, the number of which is the
819 -- minimum of the specified Count and the items (if any) that exist from
820 -- Index to Container.Last. There are no constraints on the specified
821 -- value of Count (it can be larger than what's available at this
822 -- position in the vector, for example), but there are constraints on
823 -- the allowed values of the Index.
825 -- As a precondition on the generic actual Index_Type, the base type
826 -- must include Index_Type'Pred (Index_Type'First); this is the value
827 -- that Container.Last assumes when the vector is empty. However, we do
828 -- not allow that as the value for Index when specifying which items
829 -- should be deleted, so we must manually check. (That the user is
830 -- allowed to specify the value at all here is a consequence of the
831 -- declaration of the Extended_Index subtype, which includes the values
832 -- in the base range that immediately precede and immediately follow the
833 -- values in the Index_Type.)
835 if Index < Index_Type'First then
836 raise Constraint_Error with "Index is out of range (too small)";
839 -- We do allow a value greater than Container.Last to be specified as
840 -- the Index, but only if it's immediately greater. This allows the
841 -- corner case of deleting no items from the back end of the vector to
842 -- be treated as a no-op. (It is assumed that specifying an index value
843 -- greater than Last + 1 indicates some deeper flaw in the caller's
844 -- algorithm, so that case is treated as a proper error.)
846 if Index > Old_Last then
847 if Index > Old_Last + 1 then
848 raise Constraint_Error with "Index is out of range (too large)";
854 -- Here and elsewhere we treat deleting 0 items from the container as a
855 -- no-op, even when the container is busy, so we simply return.
861 -- The internal elements array isn't guaranteed to exist unless we have
862 -- elements, so we handle that case here in order to avoid having to
863 -- check it later. (Note that an empty vector can never be busy, so
864 -- there's no semantic harm in returning early.)
866 if Container.Is_Empty then
870 -- The tampering bits exist to prevent an item from being deleted (or
871 -- otherwise harmfully manipulated) while it is being visited. Query,
872 -- Update, and Iterate increment the busy count on entry, and decrement
873 -- the count on exit. Delete checks the count to determine whether it is
874 -- being called while the associated callback procedure is executing.
876 if Container.Busy > 0 then
877 raise Program_Error with
878 "attempt to tamper with cursors (vector is busy)";
881 -- We first calculate what's available for deletion starting at
882 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
883 -- Count_Type'Base as the type for intermediate values. (See function
884 -- Length for more information.)
886 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
887 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
890 Count2 := Count_Type'Base (Old_Last - Index + 1);
893 -- If the number of elements requested (Count) for deletion is equal to
894 -- (or greater than) the number of elements available (Count2) for
895 -- deletion beginning at Index, then everything from Index to
896 -- Container.Last is deleted (this is equivalent to Delete_Last).
898 if Count >= Count2 then
899 -- Elements in an indefinite vector are allocated, so we must iterate
900 -- over the loop and deallocate elements one-at-a-time. We work from
901 -- back to front, deleting the last element during each pass, in
902 -- order to gracefully handle deallocation failures.
905 EA : Elements_Array renames Container.Elements.EA;
908 while Container.Last >= Index loop
910 K : constant Index_Type := Container.Last;
911 X : Element_Access := EA (K);
914 -- We first isolate the element we're deleting, removing it
915 -- from the vector before we attempt to deallocate it, in
916 -- case the deallocation fails.
919 Container.Last := K - 1;
921 -- Container invariants have been restored, so it is now
922 -- safe to attempt to deallocate the element.
932 -- There are some elements that aren't being deleted (the requested
933 -- count was less than the available count), so we must slide them down
934 -- to Index. We first calculate the index values of the respective array
935 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
936 -- type for intermediate calculations. For the elements that slide down,
937 -- index value New_Last is the last index value of their new home, and
938 -- index value J is the first index of their old home.
940 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
941 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
942 J
:= Index
+ Index_Type
'Base (Count
);
945 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
946 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
949 -- The internal elements array isn't guaranteed to exist unless we have
950 -- elements, but we have that guarantee here because we know we have
951 -- elements to slide. The array index values for each slice have
952 -- already been determined, so what remains to be done is to first
953 -- deallocate the elements that are being deleted, and then slide down
954 -- to Index the elements that aren't being deleted.
957 EA
: Elements_Array
renames Container
.Elements
.EA
;
960 -- Before we can slide down the elements that aren't being deleted,
961 -- we need to deallocate the elements that are being deleted.
963 for K
in Index
.. J
- 1 loop
965 X
: Element_Access
:= EA
(K
);
968 -- First we remove the element we're about to deallocate from
969 -- the vector, in case the deallocation fails, in order to
970 -- preserve representation invariants.
974 -- The element has been removed from the vector, so it is now
975 -- safe to attempt to deallocate it.
981 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
982 Container
.Last
:= New_Last
;
987 (Container
: in out Vector
;
988 Position
: in out Cursor
;
989 Count
: Count_Type
:= 1)
991 pragma Warnings
(Off
, Position
);
994 if Position
.Container
= null then
995 raise Constraint_Error
with "Position cursor has no element";
998 if Position
.Container
/= Container
'Unrestricted_Access then
999 raise Program_Error
with "Position cursor denotes wrong container";
1002 if Position
.Index
> Container
.Last
then
1003 raise Program_Error
with "Position index is out of range";
1006 Delete
(Container
, Position
.Index
, Count
);
1008 Position
:= No_Element
;
1015 procedure Delete_First
1016 (Container
: in out Vector
;
1017 Count
: Count_Type
:= 1)
1024 if Count
>= Length
(Container
) then
1029 Delete
(Container
, Index_Type
'First, Count
);
1036 procedure Delete_Last
1037 (Container
: in out Vector
;
1038 Count
: Count_Type
:= 1)
1041 -- It is not permitted to delete items while the container is busy (for
1042 -- example, we're in the middle of a passive iteration). However, we
1043 -- always treat deleting 0 items as a no-op, even when we're busy, so we
1044 -- simply return without checking.
1050 -- We cannot simply subsume the empty case into the loop below (the loop
1051 -- would iterate 0 times), because we rename the internal array object
1052 -- (which is allocated), but an empty vector isn't guaranteed to have
1053 -- actually allocated an array. (Note that an empty vector can never be
1054 -- busy, so there's no semantic harm in returning early here.)
1056 if Container
.Is_Empty
then
1060 -- The tampering bits exist to prevent an item from being deleted (or
1061 -- otherwise harmfully manipulated) while it is being visited. Query,
1062 -- Update, and Iterate increment the busy count on entry, and decrement
1063 -- the count on exit. Delete_Last checks the count to determine whether
1064 -- it is being called while the associated callback procedure is
1067 if Container
.Busy
> 0 then
1068 raise Program_Error
with
1069 "attempt to tamper with cursors (vector is busy)";
1072 -- Elements in an indefinite vector are allocated, so we must iterate
1073 -- over the loop and deallocate elements one-at-a-time. We work from
1074 -- back to front, deleting the last element during each pass, in order
1075 -- to gracefully handle deallocation failures.
1078 E
: Elements_Array
renames Container
.Elements
.EA
;
1081 for Indx
in 1 .. Count_Type
'Min (Count
, Container
.Length
) loop
1083 J
: constant Index_Type
:= Container
.Last
;
1084 X
: Element_Access
:= E
(J
);
1087 -- Note that we first isolate the element we're deleting,
1088 -- removing it from the vector, before we actually deallocate
1089 -- it, in order to preserve representation invariants even if
1090 -- the deallocation fails.
1093 Container
.Last
:= J
- 1;
1095 -- Container invariants have been restored, so it is now safe
1096 -- to deallocate the element.
1109 (Container
: Vector
;
1110 Index
: Index_Type
) return Element_Type
1113 if Index
> Container
.Last
then
1114 raise Constraint_Error
with "Index is out of range";
1118 EA
: constant Element_Access
:= Container
.Elements
.EA
(Index
);
1122 raise Constraint_Error
with "element is empty";
1129 function Element
(Position
: Cursor
) return Element_Type
is
1131 if Position
.Container
= null then
1132 raise Constraint_Error
with "Position cursor has no element";
1135 if Position
.Index
> Position
.Container
.Last
then
1136 raise Constraint_Error
with "Position cursor is out of range";
1140 EA
: constant Element_Access
:=
1141 Position
.Container
.Elements
.EA
(Position
.Index
);
1145 raise Constraint_Error
with "element is empty";
1156 procedure Finalize
(Container
: in out Vector
) is
1158 Clear
(Container
); -- Checks busy-bit
1161 X
: Elements_Access
:= Container
.Elements
;
1163 Container
.Elements
:= null;
1168 procedure Finalize
(Object
: in out Iterator
) is
1169 B
: Natural renames Object
.Container
.Busy
;
1174 procedure Finalize
(Control
: in out Reference_Control_Type
) is
1176 if Control
.Container
/= null then
1178 C
: Vector
renames Control
.Container
.all;
1179 B
: Natural renames C
.Busy
;
1180 L
: Natural renames C
.Lock
;
1186 Control
.Container
:= null;
1195 (Container
: Vector
;
1196 Item
: Element_Type
;
1197 Position
: Cursor
:= No_Element
) return Cursor
1200 if Position
.Container
/= null then
1201 if Position
.Container
/= Container
'Unrestricted_Access then
1202 raise Program_Error
with "Position cursor denotes wrong container";
1205 if Position
.Index
> Container
.Last
then
1206 raise Program_Error
with "Position index is out of range";
1210 for J
in Position
.Index
.. Container
.Last
loop
1211 if Container
.Elements
.EA
(J
) /= null
1212 and then Container
.Elements
.EA
(J
).all = Item
1214 return (Container
'Unrestricted_Access, J
);
1226 (Container
: Vector
;
1227 Item
: Element_Type
;
1228 Index
: Index_Type
:= Index_Type
'First) return Extended_Index
1231 for Indx
in Index
.. Container
.Last
loop
1232 if Container
.Elements
.EA
(Indx
) /= null
1233 and then Container
.Elements
.EA
(Indx
).all = Item
1246 function First
(Container
: Vector
) return Cursor
is
1248 if Is_Empty
(Container
) then
1252 return (Container
'Unrestricted_Access, Index_Type
'First);
1255 function First
(Object
: Iterator
) return Cursor
is
1257 -- The value of the iterator object's Index component influences the
1258 -- behavior of the First (and Last) selector function.
1260 -- When the Index component is No_Index, this means the iterator
1261 -- object was constructed without a start expression, in which case the
1262 -- (forward) iteration starts from the (logical) beginning of the entire
1263 -- sequence of items (corresponding to Container.First, for a forward
1266 -- Otherwise, this is iteration over a partial sequence of items.
1267 -- When the Index component isn't No_Index, the iterator object was
1268 -- constructed with a start expression, that specifies the position
1269 -- from which the (forward) partial iteration begins.
1271 if Object
.Index
= No_Index
then
1272 return First
(Object
.Container
.all);
1274 return Cursor
'(Object.Container, Object.Index);
1282 function First_Element (Container : Vector) return Element_Type is
1284 if Container.Last = No_Index then
1285 raise Constraint_Error with "Container is empty";
1289 EA : constant Element_Access :=
1290 Container.Elements.EA (Index_Type'First);
1294 raise Constraint_Error with "first element is empty";
1305 function First_Index (Container : Vector) return Index_Type is
1306 pragma Unreferenced (Container);
1308 return Index_Type'First;
1311 ---------------------
1312 -- Generic_Sorting --
1313 ---------------------
1315 package body Generic_Sorting is
1317 -----------------------
1318 -- Local Subprograms --
1319 -----------------------
1321 function Is_Less (L, R : Element_Access) return Boolean;
1322 pragma Inline (Is_Less);
1328 function Is_Less (L, R : Element_Access) return Boolean is
1335 return L.all < R.all;
1343 function Is_Sorted (Container : Vector) return Boolean is
1345 if Container.Last <= Index_Type'First then
1350 E : Elements_Array renames Container.Elements.EA;
1352 for I in Index_Type'First .. Container.Last - 1 loop
1353 if Is_Less (E (I + 1), E (I)) then
1366 procedure Merge (Target, Source : in out Vector) is
1367 I, J : Index_Type'Base;
1371 -- The semantics of Merge changed slightly per AI05-0021. It was
1372 -- originally the case that if Target and Source denoted the same
1373 -- container object, then the GNAT implementation of Merge did
1374 -- nothing. However, it was argued that RM05 did not precisely
1375 -- specify the semantics for this corner case. The decision of the
1376 -- ARG was that if Target and Source denote the same non-empty
1377 -- container object, then Program_Error is raised.
1379 if Source.Last < Index_Type'First then -- Source is empty
1383 if Target'Address = Source'Address then
1384 raise Program_Error with
1385 "Target and Source denote same non-empty container";
1388 if Target.Last < Index_Type'First then -- Target is empty
1389 Move (Target => Target, Source => Source);
1393 if Source.Busy > 0 then
1394 raise Program_Error with
1395 "attempt to tamper with cursors (vector is busy)";
1398 I := Target.Last; -- original value (before Set_Length)
1399 Target.Set_Length (Length (Target) + Length (Source));
1401 J := Target.Last; -- new value (after Set_Length)
1402 while Source.Last >= Index_Type'First loop
1404 (Source.Last <= Index_Type'First
1405 or else not (Is_Less
1406 (Source.Elements.EA (Source.Last),
1407 Source.Elements.EA (Source.Last - 1))));
1409 if I < Index_Type'First then
1411 Src : Elements_Array renames
1412 Source.Elements.EA (Index_Type'First .. Source.Last);
1415 Target.Elements.EA (Index_Type'First .. J) := Src;
1416 Src := (others => null);
1419 Source.Last := No_Index;
1424 (I <= Index_Type'First
1425 or else not (Is_Less
1426 (Target.Elements.EA (I),
1427 Target.Elements.EA (I - 1))));
1430 Src : Element_Access renames Source.Elements.EA (Source.Last);
1431 Tgt : Element_Access renames Target.Elements.EA (I);
1434 if Is_Less (Src, Tgt) then
1435 Target.Elements.EA (J) := Tgt;
1440 Target.Elements.EA (J) := Src;
1442 Source.Last := Source.Last - 1;
1454 procedure Sort (Container : in out Vector) is
1455 procedure Sort is new Generic_Array_Sort
1456 (Index_Type => Index_Type,
1457 Element_Type => Element_Access,
1458 Array_Type => Elements_Array,
1461 -- Start of processing for Sort
1464 if Container.Last <= Index_Type'First then
1468 -- The exception behavior for the vector container must match that
1469 -- for the list container, so we check for cursor tampering here
1470 -- (which will catch more things) instead of for element tampering
1471 -- (which will catch fewer things). It's true that the elements of
1472 -- this vector container could be safely moved around while (say) an
1473 -- iteration is taking place (iteration only increments the busy
1474 -- counter), and so technically all we would need here is a test for
1475 -- element tampering (indicated by the lock counter), that's simply
1476 -- an artifact of our array-based implementation. Logically Sort
1477 -- requires a check for cursor tampering.
1479 if Container.Busy > 0 then
1480 raise Program_Error with
1481 "attempt to tamper with cursors (vector is busy)";
1484 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1487 end Generic_Sorting;
1493 function Has_Element (Position : Cursor) return Boolean is
1495 if Position.Container = null then
1499 return Position.Index <= Position.Container.Last;
1507 (Container : in out Vector;
1508 Before : Extended_Index;
1509 New_Item : Element_Type;
1510 Count : Count_Type := 1)
1512 Old_Length : constant Count_Type := Container.Length;
1514 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1515 New_Length : Count_Type'Base; -- sum of current length and Count
1516 New_Last : Index_Type'Base; -- last index of vector after insertion
1518 Index : Index_Type'Base; -- scratch for intermediate values
1519 J : Count_Type'Base; -- scratch
1521 New_Capacity : Count_Type'Base; -- length of new, expanded array
1522 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1523 Dst : Elements_Access; -- new, expanded internal array
1526 -- As a precondition on the generic actual Index_Type, the base type
1527 -- must include Index_Type'Pred (Index_Type'First); this is the value
1528 -- that Container.Last assumes when the vector is empty. However, we do
1529 -- not allow that as the value for Index when specifying where the new
1530 -- items should be inserted, so we must manually check. (That the user
1531 -- is allowed to specify the value at all here is a consequence of the
1532 -- declaration of the Extended_Index subtype, which includes the values
1533 -- in the base range that immediately precede and immediately follow the
1534 -- values in the Index_Type.)
1536 if Before < Index_Type'First then
1537 raise Constraint_Error with
1538 "Before index is out of range (too small)";
1541 -- We do allow a value greater than Container.Last to be specified as
1542 -- the Index, but only if it's immediately greater. This allows for the
1543 -- case of appending items to the back end of the vector. (It is assumed
1544 -- that specifying an index value greater than Last + 1 indicates some
1545 -- deeper flaw in the caller's algorithm, so that case is treated as a
1548 if Before > Container.Last
1549 and then Before > Container.Last + 1
1551 raise Constraint_Error with
1552 "Before index is out of range (too large)";
1555 -- We treat inserting 0 items into the container as a no-op, even when
1556 -- the container is busy, so we simply return.
1562 -- There are two constraints we need to satisfy. The first constraint is
1563 -- that a container cannot have more than Count_Type'Last elements, so
1564 -- we must check the sum of the current length and the insertion count.
1565 -- Note that we cannot simply add these values, because of the
1566 -- possibility of overflow.
1568 if Old_Length > Count_Type'Last - Count then
1569 raise Constraint_Error with "Count is out of range";
1572 -- It is now safe compute the length of the new vector, without fear of
1575 New_Length := Old_Length + Count;
1577 -- The second constraint is that the new Last index value cannot exceed
1578 -- Index_Type'Last. In each branch below, we calculate the maximum
1579 -- length (computed from the range of values in Index_Type), and then
1580 -- compare the new length to the maximum length. If the new length is
1581 -- acceptable, then we compute the new last index from that.
1583 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1585 -- We have to handle the case when there might be more values in the
1586 -- range of Index_Type than in the range of Count_Type.
1588 if Index_Type
'First <= 0 then
1590 -- We know that No_Index (the same as Index_Type'First - 1) is
1591 -- less than 0, so it is safe to compute the following sum without
1592 -- fear of overflow.
1594 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
1596 if Index
<= Index_Type
'Last then
1598 -- We have determined that range of Index_Type has at least as
1599 -- many values as in Count_Type, so Count_Type'Last is the
1600 -- maximum number of items that are allowed.
1602 Max_Length
:= Count_Type
'Last;
1605 -- The range of Index_Type has fewer values than in Count_Type,
1606 -- so the maximum number of items is computed from the range of
1609 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1613 -- No_Index is equal or greater than 0, so we can safely compute
1614 -- the difference without fear of overflow (which we would have to
1615 -- worry about if No_Index were less than 0, but that case is
1618 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1621 elsif Index_Type
'First <= 0 then
1623 -- We know that No_Index (the same as Index_Type'First - 1) is less
1624 -- than 0, so it is safe to compute the following sum without fear of
1627 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
1629 if J
<= Count_Type
'Base (Index_Type
'Last) then
1631 -- We have determined that range of Index_Type has at least as
1632 -- many values as in Count_Type, so Count_Type'Last is the maximum
1633 -- number of items that are allowed.
1635 Max_Length
:= Count_Type
'Last;
1638 -- The range of Index_Type has fewer values than Count_Type does,
1639 -- so the maximum number of items is computed from the range of
1643 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1647 -- No_Index is equal or greater than 0, so we can safely compute the
1648 -- difference without fear of overflow (which we would have to worry
1649 -- about if No_Index were less than 0, but that case is handled
1653 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1656 -- We have just computed the maximum length (number of items). We must
1657 -- now compare the requested length to the maximum length, as we do not
1658 -- allow a vector expand beyond the maximum (because that would create
1659 -- an internal array with a last index value greater than
1660 -- Index_Type'Last, with no way to index those elements).
1662 if New_Length
> Max_Length
then
1663 raise Constraint_Error
with "Count is out of range";
1666 -- New_Last is the last index value of the items in the container after
1667 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1668 -- compute its value from the New_Length.
1670 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1671 New_Last := No_Index + Index_Type'Base (New_Length);
1674 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1677 if Container.Elements = null then
1678 pragma Assert (Container.Last = No_Index);
1680 -- This is the simplest case, with which we must always begin: we're
1681 -- inserting items into an empty vector that hasn't allocated an
1682 -- internal array yet. Note that we don't need to check the busy bit
1683 -- here, because an empty container cannot be busy.
1685 -- In an indefinite vector, elements are allocated individually, and
1686 -- stored as access values on the internal array (the length of which
1687 -- represents the vector "capacity"), which is separately allocated.
1689 Container.Elements := new Elements_Type (New_Last);
1691 -- The element backbone has been successfully allocated, so now we
1692 -- allocate the elements.
1694 for Idx in Container.Elements.EA'Range loop
1696 -- In order to preserve container invariants, we always attempt
1697 -- the element allocation first, before setting the Last index
1698 -- value, in case the allocation fails (either because there is no
1699 -- storage available, or because element initialization fails).
1702 -- The element allocator may need an accessibility check in the
1703 -- case actual type is class-wide or has access discriminants
1704 -- (see RM 4.8(10.1) and AI12-0035).
1706 pragma Unsuppress (Accessibility_Check);
1709 Container.Elements.EA (Idx) := new Element_Type'(New_Item
);
1712 -- The allocation of the element succeeded, so it is now safe to
1713 -- update the Last index, restoring container invariants.
1715 Container
.Last
:= Idx
;
1721 -- The tampering bits exist to prevent an item from being harmfully
1722 -- manipulated while it is being visited. Query, Update, and Iterate
1723 -- increment the busy count on entry, and decrement the count on
1724 -- exit. Insert checks the count to determine whether it is being called
1725 -- while the associated callback procedure is executing.
1727 if Container
.Busy
> 0 then
1728 raise Program_Error
with
1729 "attempt to tamper with cursors (vector is busy)";
1732 if New_Length
<= Container
.Elements
.EA
'Length then
1734 -- In this case, we're inserting elements into a vector that has
1735 -- already allocated an internal array, and the existing array has
1736 -- enough unused storage for the new items.
1739 E
: Elements_Array
renames Container
.Elements
.EA
;
1740 K
: Index_Type
'Base;
1743 if Before
> Container
.Last
then
1745 -- The new items are being appended to the vector, so no
1746 -- sliding of existing elements is required.
1748 for Idx
in Before
.. New_Last
loop
1750 -- In order to preserve container invariants, we always
1751 -- attempt the element allocation first, before setting the
1752 -- Last index value, in case the allocation fails (either
1753 -- because there is no storage available, or because element
1754 -- initialization fails).
1757 -- The element allocator may need an accessibility check
1758 -- in case the actual type is class-wide or has access
1759 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1761 pragma Unsuppress
(Accessibility_Check
);
1764 E
(Idx
) := new Element_Type
'(New_Item);
1767 -- The allocation of the element succeeded, so it is now
1768 -- safe to update the Last index, restoring container
1771 Container.Last := Idx;
1775 -- The new items are being inserted before some existing
1776 -- elements, so we must slide the existing elements up to their
1777 -- new home. We use the wider of Index_Type'Base and
1778 -- Count_Type'Base as the type for intermediate index values.
1780 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1781 Index
:= Before
+ Index_Type
'Base (Count
);
1783 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
1786 -- The new items are being inserted in the middle of the array,
1787 -- in the range [Before, Index). Copy the existing elements to
1788 -- the end of the array, to make room for the new items.
1790 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
1791 Container
.Last
:= New_Last
;
1793 -- We have copied the existing items up to the end of the
1794 -- array, to make room for the new items in the middle of
1795 -- the array. Now we actually allocate the new items.
1797 -- Note: initialize K outside loop to make it clear that
1798 -- K always has a value if the exception handler triggers.
1803 -- The element allocator may need an accessibility check in
1804 -- the case the actual type is class-wide or has access
1805 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1807 pragma Unsuppress
(Accessibility_Check
);
1810 while K
< Index
loop
1811 E
(K
) := new Element_Type
'(New_Item);
1818 -- Values in the range [Before, K) were successfully
1819 -- allocated, but values in the range [K, Index) are
1820 -- stale (these array positions contain copies of the
1821 -- old items, that did not get assigned a new item,
1822 -- because the allocation failed). We must finish what
1823 -- we started by clearing out all of the stale values,
1824 -- leaving a "hole" in the middle of the array.
1826 E (K .. Index - 1) := (others => null);
1835 -- In this case, we're inserting elements into a vector that has already
1836 -- allocated an internal array, but the existing array does not have
1837 -- enough storage, so we must allocate a new, longer array. In order to
1838 -- guarantee that the amortized insertion cost is O(1), we always
1839 -- allocate an array whose length is some power-of-two factor of the
1840 -- current array length. (The new array cannot have a length less than
1841 -- the New_Length of the container, but its last index value cannot be
1842 -- greater than Index_Type'Last.)
1844 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1845 while New_Capacity < New_Length loop
1846 if New_Capacity > Count_Type'Last / 2 then
1847 New_Capacity := Count_Type'Last;
1851 New_Capacity := 2 * New_Capacity;
1854 if New_Capacity > Max_Length then
1856 -- We have reached the limit of capacity, so no further expansion
1857 -- will occur. (This is not a problem, as there is never a need to
1858 -- have more capacity than the maximum container length.)
1860 New_Capacity := Max_Length;
1863 -- We have computed the length of the new internal array (and this is
1864 -- what "vector capacity" means), so use that to compute its last index.
1866 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1867 Dst_Last
:= No_Index
+ Index_Type
'Base (New_Capacity
);
1871 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Capacity
);
1874 -- Now we allocate the new, longer internal array. If the allocation
1875 -- fails, we have not changed any container state, so no side-effect
1876 -- will occur as a result of propagating the exception.
1878 Dst
:= new Elements_Type
(Dst_Last
);
1880 -- We have our new internal array. All that needs to be done now is to
1881 -- copy the existing items (if any) from the old array (the "source"
1882 -- array) to the new array (the "destination" array), and then
1883 -- deallocate the old array.
1886 Src
: Elements_Access
:= Container
.Elements
;
1889 Dst
.EA
(Index_Type
'First .. Before
- 1) :=
1890 Src
.EA
(Index_Type
'First .. Before
- 1);
1892 if Before
> Container
.Last
then
1894 -- The new items are being appended to the vector, so no
1895 -- sliding of existing elements is required.
1897 -- We have copied the elements from to the old, source array to
1898 -- the new, destination array, so we can now deallocate the old
1901 Container
.Elements
:= Dst
;
1904 -- Now we append the new items.
1906 for Idx
in Before
.. New_Last
loop
1908 -- In order to preserve container invariants, we always
1909 -- attempt the element allocation first, before setting the
1910 -- Last index value, in case the allocation fails (either
1911 -- because there is no storage available, or because element
1912 -- initialization fails).
1915 -- The element allocator may need an accessibility check in
1916 -- the case the actual type is class-wide or has access
1917 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1919 pragma Unsuppress
(Accessibility_Check
);
1922 Dst
.EA
(Idx
) := new Element_Type
'(New_Item);
1925 -- The allocation of the element succeeded, so it is now safe
1926 -- to update the Last index, restoring container invariants.
1928 Container.Last := Idx;
1932 -- The new items are being inserted before some existing elements,
1933 -- so we must slide the existing elements up to their new home.
1935 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1936 Index
:= Before
+ Index_Type
'Base (Count
);
1939 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
1942 Dst
.EA
(Index
.. New_Last
) := Src
.EA
(Before
.. Container
.Last
);
1944 -- We have copied the elements from to the old, source array to
1945 -- the new, destination array, so we can now deallocate the old
1948 Container
.Elements
:= Dst
;
1949 Container
.Last
:= New_Last
;
1952 -- The new array has a range in the middle containing null access
1953 -- values. We now fill in that partition of the array with the new
1956 for Idx
in Before
.. Index
- 1 loop
1958 -- Note that container invariants have already been satisfied
1959 -- (in particular, the Last index value of the vector has
1960 -- already been updated), so if this allocation fails we simply
1961 -- let it propagate.
1964 -- The element allocator may need an accessibility check in
1965 -- the case the actual type is class-wide or has access
1966 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1968 pragma Unsuppress
(Accessibility_Check
);
1971 Dst
.EA
(Idx
) := new Element_Type
'(New_Item);
1979 (Container : in out Vector;
1980 Before : Extended_Index;
1983 N : constant Count_Type := Length (New_Item);
1984 J : Index_Type'Base;
1987 -- Use Insert_Space to create the "hole" (the destination slice) into
1988 -- which we copy the source items.
1990 Insert_Space (Container, Before, Count => N);
1994 -- There's nothing else to do here (vetting of parameters was
1995 -- performed already in Insert_Space), so we simply return.
2000 if Container'Address /= New_Item'Address then
2002 -- This is the simple case. New_Item denotes an object different
2003 -- from Container, so there's nothing special we need to do to copy
2004 -- the source items to their destination, because all of the source
2005 -- items are contiguous.
2008 subtype Src_Index_Subtype is Index_Type'Base range
2009 Index_Type'First .. New_Item.Last;
2011 Src : Elements_Array renames
2012 New_Item.Elements.EA (Src_Index_Subtype);
2014 Dst : Elements_Array renames Container.Elements.EA;
2016 Dst_Index : Index_Type'Base;
2019 Dst_Index := Before - 1;
2020 for Src_Index in Src'Range loop
2021 Dst_Index := Dst_Index + 1;
2023 if Src (Src_Index) /= null then
2024 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
2032 -- New_Item denotes the same object as Container, so an insertion has
2033 -- potentially split the source items. The first source slice is
2034 -- [Index_Type'First, Before), and the second source slice is
2035 -- [J, Container.Last], where index value J is the first index of the
2036 -- second slice. (J gets computed below, but only after we have
2037 -- determined that the second source slice is non-empty.) The
2038 -- destination slice is always the range [Before, J). We perform the
2039 -- copy in two steps, using each of the two slices of the source items.
2042 L
: constant Index_Type
'Base := Before
- 1;
2044 subtype Src_Index_Subtype
is Index_Type
'Base range
2045 Index_Type
'First .. L
;
2047 Src
: Elements_Array
renames
2048 Container
.Elements
.EA
(Src_Index_Subtype
);
2050 Dst
: Elements_Array
renames Container
.Elements
.EA
;
2052 Dst_Index
: Index_Type
'Base;
2055 -- We first copy the source items that precede the space we
2056 -- inserted. (If Before equals Index_Type'First, then this first
2057 -- source slice will be empty, which is harmless.)
2059 Dst_Index
:= Before
- 1;
2060 for Src_Index
in Src
'Range loop
2061 Dst_Index
:= Dst_Index
+ 1;
2063 if Src
(Src_Index
) /= null then
2064 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
2068 if Src'Length = N then
2070 -- The new items were effectively appended to the container, so we
2071 -- have already copied all of the items that need to be copied.
2072 -- We return early here, even though the source slice below is
2073 -- empty (so the assignment would be harmless), because we want to
2074 -- avoid computing J, which will overflow if J is greater than
2075 -- Index_Type'Base'Last
.
2081 -- Index value J is the first index of the second source slice. (It is
2082 -- also 1 greater than the last index of the destination slice.) Note:
2083 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
2084 -- to avoid overflow. Prevent that by returning early above, immediately
2085 -- after copying the first slice of the source, and determining that
2086 -- this second slice of the source is empty.
2088 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2089 J := Before + Index_Type'Base (N);
2092 J := Index_Type'Base (Count_Type'Base (Before) + N);
2096 subtype Src_Index_Subtype is Index_Type'Base range
2097 J .. Container.Last;
2099 Src : Elements_Array renames
2100 Container.Elements.EA (Src_Index_Subtype);
2102 Dst : Elements_Array renames Container.Elements.EA;
2104 Dst_Index : Index_Type'Base;
2107 -- We next copy the source items that follow the space we inserted.
2108 -- Index value Dst_Index is the first index of that portion of the
2109 -- destination that receives this slice of the source. (For the
2110 -- reasons given above, this slice is guaranteed to be non-empty.)
2112 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2113 Dst_Index
:= J
- Index_Type
'Base (Src
'Length);
2116 Dst_Index
:= Index_Type
'Base (Count_Type
'Base (J
) - Src
'Length);
2119 for Src_Index
in Src
'Range loop
2120 if Src
(Src_Index
) /= null then
2121 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
2124 Dst_Index := Dst_Index + 1;
2130 (Container : in out Vector;
2134 Index : Index_Type'Base;
2137 if Before.Container /= null
2138 and then Before.Container /= Container'Unrestricted_Access
2140 raise Program_Error with "Before cursor denotes wrong container";
2143 if Is_Empty (New_Item) then
2147 if Before.Container = null
2148 or else Before.Index > Container.Last
2150 if Container.Last = Index_Type'Last then
2151 raise Constraint_Error with
2152 "vector is already at its maximum length";
2155 Index := Container.Last + 1;
2158 Index := Before.Index;
2161 Insert (Container, Index, New_Item);
2165 (Container : in out Vector;
2168 Position : out Cursor)
2170 Index : Index_Type'Base;
2173 if Before.Container /= null
2174 and then Before.Container /=
2175 Vector_Access'(Container
'Unrestricted_Access)
2177 raise Program_Error
with "Before cursor denotes wrong container";
2180 if Is_Empty
(New_Item
) then
2181 if Before
.Container
= null
2182 or else Before
.Index
> Container
.Last
2184 Position
:= No_Element
;
2186 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2192 if Before
.Container
= null
2193 or else Before
.Index
> Container
.Last
2195 if Container
.Last
= Index_Type
'Last then
2196 raise Constraint_Error
with
2197 "vector is already at its maximum length";
2200 Index
:= Container
.Last
+ 1;
2203 Index
:= Before
.Index
;
2206 Insert
(Container
, Index
, New_Item
);
2208 Position
:= Cursor
'(Container'Unrestricted_Access, Index);
2212 (Container : in out Vector;
2214 New_Item : Element_Type;
2215 Count : Count_Type := 1)
2217 Index : Index_Type'Base;
2220 if Before.Container /= null
2221 and then Before.Container /= Container'Unrestricted_Access
2223 raise Program_Error with "Before cursor denotes wrong container";
2230 if Before.Container = null
2231 or else Before.Index > Container.Last
2233 if Container.Last = Index_Type'Last then
2234 raise Constraint_Error with
2235 "vector is already at its maximum length";
2238 Index := Container.Last + 1;
2241 Index := Before.Index;
2244 Insert (Container, Index, New_Item, Count);
2248 (Container : in out Vector;
2250 New_Item : Element_Type;
2251 Position : out Cursor;
2252 Count : Count_Type := 1)
2254 Index : Index_Type'Base;
2257 if Before.Container /= null
2258 and then Before.Container /= Container'Unrestricted_Access
2260 raise Program_Error with "Before cursor denotes wrong container";
2264 if Before.Container = null
2265 or else Before.Index > Container.Last
2267 Position := No_Element;
2269 Position := (Container'Unrestricted_Access, Before.Index);
2275 if Before.Container = null
2276 or else Before.Index > Container.Last
2278 if Container.Last = Index_Type'Last then
2279 raise Constraint_Error with
2280 "vector is already at its maximum length";
2283 Index := Container.Last + 1;
2286 Index := Before.Index;
2289 Insert (Container, Index, New_Item, Count);
2291 Position := (Container'Unrestricted_Access, Index);
2298 procedure Insert_Space
2299 (Container : in out Vector;
2300 Before : Extended_Index;
2301 Count : Count_Type := 1)
2303 Old_Length : constant Count_Type := Container.Length;
2305 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2306 New_Length : Count_Type'Base; -- sum of current length and Count
2307 New_Last : Index_Type'Base; -- last index of vector after insertion
2309 Index : Index_Type'Base; -- scratch for intermediate values
2310 J : Count_Type'Base; -- scratch
2312 New_Capacity : Count_Type'Base; -- length of new, expanded array
2313 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2314 Dst : Elements_Access; -- new, expanded internal array
2317 -- As a precondition on the generic actual Index_Type, the base type
2318 -- must include Index_Type'Pred (Index_Type'First); this is the value
2319 -- that Container.Last assumes when the vector is empty. However, we do
2320 -- not allow that as the value for Index when specifying where the new
2321 -- items should be inserted, so we must manually check. (That the user
2322 -- is allowed to specify the value at all here is a consequence of the
2323 -- declaration of the Extended_Index subtype, which includes the values
2324 -- in the base range that immediately precede and immediately follow the
2325 -- values in the Index_Type.)
2327 if Before < Index_Type'First then
2328 raise Constraint_Error with
2329 "Before index is out of range (too small)";
2332 -- We do allow a value greater than Container.Last to be specified as
2333 -- the Index, but only if it's immediately greater. This allows for the
2334 -- case of appending items to the back end of the vector. (It is assumed
2335 -- that specifying an index value greater than Last + 1 indicates some
2336 -- deeper flaw in the caller's algorithm, so that case is treated as a
2339 if Before > Container.Last
2340 and then Before > Container.Last + 1
2342 raise Constraint_Error with
2343 "Before index is out of range (too large)";
2346 -- We treat inserting 0 items into the container as a no-op, even when
2347 -- the container is busy, so we simply return.
2353 -- There are two constraints we need to satisfy. The first constraint is
2354 -- that a container cannot have more than Count_Type'Last elements, so
2355 -- we must check the sum of the current length and the insertion
2356 -- count. Note that we cannot simply add these values, because of the
2357 -- possibility of overflow.
2359 if Old_Length > Count_Type'Last - Count then
2360 raise Constraint_Error with "Count is out of range";
2363 -- It is now safe compute the length of the new vector, without fear of
2366 New_Length := Old_Length + Count;
2368 -- The second constraint is that the new Last index value cannot exceed
2369 -- Index_Type'Last. In each branch below, we calculate the maximum
2370 -- length (computed from the range of values in Index_Type), and then
2371 -- compare the new length to the maximum length. If the new length is
2372 -- acceptable, then we compute the new last index from that.
2374 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2375 -- We have to handle the case when there might be more values in the
2376 -- range of Index_Type than in the range of Count_Type.
2378 if Index_Type
'First <= 0 then
2380 -- We know that No_Index (the same as Index_Type'First - 1) is
2381 -- less than 0, so it is safe to compute the following sum without
2382 -- fear of overflow.
2384 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
2386 if Index
<= Index_Type
'Last then
2388 -- We have determined that range of Index_Type has at least as
2389 -- many values as in Count_Type, so Count_Type'Last is the
2390 -- maximum number of items that are allowed.
2392 Max_Length
:= Count_Type
'Last;
2395 -- The range of Index_Type has fewer values than in Count_Type,
2396 -- so the maximum number of items is computed from the range of
2399 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2403 -- No_Index is equal or greater than 0, so we can safely compute
2404 -- the difference without fear of overflow (which we would have to
2405 -- worry about if No_Index were less than 0, but that case is
2408 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2411 elsif Index_Type
'First <= 0 then
2413 -- We know that No_Index (the same as Index_Type'First - 1) is less
2414 -- than 0, so it is safe to compute the following sum without fear of
2417 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
2419 if J
<= Count_Type
'Base (Index_Type
'Last) then
2421 -- We have determined that range of Index_Type has at least as
2422 -- many values as in Count_Type, so Count_Type'Last is the maximum
2423 -- number of items that are allowed.
2425 Max_Length
:= Count_Type
'Last;
2428 -- The range of Index_Type has fewer values than Count_Type does,
2429 -- so the maximum number of items is computed from the range of
2433 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2437 -- No_Index is equal or greater than 0, so we can safely compute the
2438 -- difference without fear of overflow (which we would have to worry
2439 -- about if No_Index were less than 0, but that case is handled
2443 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2446 -- We have just computed the maximum length (number of items). We must
2447 -- now compare the requested length to the maximum length, as we do not
2448 -- allow a vector expand beyond the maximum (because that would create
2449 -- an internal array with a last index value greater than
2450 -- Index_Type'Last, with no way to index those elements).
2452 if New_Length
> Max_Length
then
2453 raise Constraint_Error
with "Count is out of range";
2456 -- New_Last is the last index value of the items in the container after
2457 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2458 -- compute its value from the New_Length.
2460 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2461 New_Last := No_Index + Index_Type'Base (New_Length);
2464 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2467 if Container.Elements = null then
2468 pragma Assert (Container.Last = No_Index);
2470 -- This is the simplest case, with which we must always begin: we're
2471 -- inserting items into an empty vector that hasn't allocated an
2472 -- internal array yet. Note that we don't need to check the busy bit
2473 -- here, because an empty container cannot be busy.
2475 -- In an indefinite vector, elements are allocated individually, and
2476 -- stored as access values on the internal array (the length of which
2477 -- represents the vector "capacity"), which is separately allocated.
2478 -- We have no elements here (because we're inserting "space"), so all
2479 -- we need to do is allocate the backbone.
2481 Container.Elements := new Elements_Type (New_Last);
2482 Container.Last := New_Last;
2487 -- The tampering bits exist to prevent an item from being harmfully
2488 -- manipulated while it is being visited. Query, Update, and Iterate
2489 -- increment the busy count on entry, and decrement the count on exit.
2490 -- Insert checks the count to determine whether it is being called while
2491 -- the associated callback procedure is executing.
2493 if Container.Busy > 0 then
2494 raise Program_Error with
2495 "attempt to tamper with cursors (vector is busy)";
2498 if New_Length <= Container.Elements.EA'Length then
2499 -- In this case, we're inserting elements into a vector that has
2500 -- already allocated an internal array, and the existing array has
2501 -- enough unused storage for the new items.
2504 E : Elements_Array renames Container.Elements.EA;
2507 if Before <= Container.Last then
2509 -- The new space is being inserted before some existing
2510 -- elements, so we must slide the existing elements up to their
2511 -- new home. We use the wider of Index_Type'Base and
2512 -- Count_Type'Base as the type for intermediate index values.
2514 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2515 Index
:= Before
+ Index_Type
'Base (Count
);
2518 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2521 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
2522 E
(Before
.. Index
- 1) := (others => null);
2526 Container
.Last
:= New_Last
;
2530 -- In this case, we're inserting elements into a vector that has already
2531 -- allocated an internal array, but the existing array does not have
2532 -- enough storage, so we must allocate a new, longer array. In order to
2533 -- guarantee that the amortized insertion cost is O(1), we always
2534 -- allocate an array whose length is some power-of-two factor of the
2535 -- current array length. (The new array cannot have a length less than
2536 -- the New_Length of the container, but its last index value cannot be
2537 -- greater than Index_Type'Last.)
2539 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
2540 while New_Capacity
< New_Length
loop
2541 if New_Capacity
> Count_Type
'Last / 2 then
2542 New_Capacity
:= Count_Type
'Last;
2546 New_Capacity
:= 2 * New_Capacity
;
2549 if New_Capacity
> Max_Length
then
2551 -- We have reached the limit of capacity, so no further expansion
2552 -- will occur. (This is not a problem, as there is never a need to
2553 -- have more capacity than the maximum container length.)
2555 New_Capacity
:= Max_Length
;
2558 -- We have computed the length of the new internal array (and this is
2559 -- what "vector capacity" means), so use that to compute its last index.
2561 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2562 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2566 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2569 -- Now we allocate the new, longer internal array. If the allocation
2570 -- fails, we have not changed any container state, so no side-effect
2571 -- will occur as a result of propagating the exception.
2573 Dst := new Elements_Type (Dst_Last);
2575 -- We have our new internal array. All that needs to be done now is to
2576 -- copy the existing items (if any) from the old array (the "source"
2577 -- array) to the new array (the "destination" array), and then
2578 -- deallocate the old array.
2581 Src : Elements_Access := Container.Elements;
2584 Dst.EA (Index_Type'First .. Before - 1) :=
2585 Src.EA (Index_Type'First .. Before - 1);
2587 if Before <= Container.Last then
2589 -- The new items are being inserted before some existing elements,
2590 -- so we must slide the existing elements up to their new home.
2592 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2593 Index
:= Before
+ Index_Type
'Base (Count
);
2596 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2599 Dst
.EA
(Index
.. New_Last
) := Src
.EA
(Before
.. Container
.Last
);
2602 -- We have copied the elements from to the old, source array to the
2603 -- new, destination array, so we can now restore invariants, and
2604 -- deallocate the old array.
2606 Container
.Elements
:= Dst
;
2607 Container
.Last
:= New_Last
;
2612 procedure Insert_Space
2613 (Container
: in out Vector
;
2615 Position
: out Cursor
;
2616 Count
: Count_Type
:= 1)
2618 Index
: Index_Type
'Base;
2621 if Before
.Container
/= null
2622 and then Before
.Container
/= Container
'Unrestricted_Access
2624 raise Program_Error
with "Before cursor denotes wrong container";
2628 if Before
.Container
= null
2629 or else Before
.Index
> Container
.Last
2631 Position
:= No_Element
;
2633 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2639 if Before
.Container
= null
2640 or else Before
.Index
> Container
.Last
2642 if Container
.Last
= Index_Type
'Last then
2643 raise Constraint_Error
with
2644 "vector is already at its maximum length";
2647 Index
:= Container
.Last
+ 1;
2650 Index
:= Before
.Index
;
2653 Insert_Space
(Container
, Index
, Count
);
2655 Position
:= Cursor
'(Container'Unrestricted_Access, Index);
2662 function Is_Empty (Container : Vector) return Boolean is
2664 return Container.Last < Index_Type'First;
2672 (Container : Vector;
2673 Process : not null access procedure (Position : Cursor))
2675 B : Natural renames Container'Unrestricted_Access.all.Busy;
2681 for Indx in Index_Type'First .. Container.Last loop
2682 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
2693 function Iterate
(Container
: Vector
)
2694 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
2696 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
2697 B
: Natural renames V
.Busy
;
2700 -- The value of its Index component influences the behavior of the First
2701 -- and Last selector functions of the iterator object. When the Index
2702 -- component is No_Index (as is the case here), this means the iterator
2703 -- object was constructed without a start expression. This is a complete
2704 -- iterator, meaning that the iteration starts from the (logical)
2705 -- beginning of the sequence of items.
2707 -- Note: For a forward iterator, Container.First is the beginning, and
2708 -- for a reverse iterator, Container.Last is the beginning.
2710 return It
: constant Iterator
:=
2711 (Limited_Controlled
with
2720 (Container
: Vector
;
2722 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
2724 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
2725 B
: Natural renames V
.Busy
;
2728 -- It was formerly the case that when Start = No_Element, the partial
2729 -- iterator was defined to behave the same as for a complete iterator,
2730 -- and iterate over the entire sequence of items. However, those
2731 -- semantics were unintuitive and arguably error-prone (it is too easy
2732 -- to accidentally create an endless loop), and so they were changed,
2733 -- per the ARG meeting in Denver on 2011/11. However, there was no
2734 -- consensus about what positive meaning this corner case should have,
2735 -- and so it was decided to simply raise an exception. This does imply,
2736 -- however, that it is not possible to use a partial iterator to specify
2737 -- an empty sequence of items.
2739 if Start
.Container
= null then
2740 raise Constraint_Error
with
2741 "Start position for iterator equals No_Element";
2744 if Start
.Container
/= V
then
2745 raise Program_Error
with
2746 "Start cursor of Iterate designates wrong vector";
2749 if Start
.Index
> V
.Last
then
2750 raise Constraint_Error
with
2751 "Start position for iterator equals No_Element";
2754 -- The value of its Index component influences the behavior of the First
2755 -- and Last selector functions of the iterator object. When the Index
2756 -- component is not No_Index (as is the case here), it means that this
2757 -- is a partial iteration, over a subset of the complete sequence of
2758 -- items. The iterator object was constructed with a start expression,
2759 -- indicating the position from which the iteration begins. Note that
2760 -- the start position has the same value irrespective of whether this
2761 -- is a forward or reverse iteration.
2763 return It
: constant Iterator
:=
2764 (Limited_Controlled
with
2766 Index
=> Start
.Index
)
2776 function Last
(Container
: Vector
) return Cursor
is
2778 if Is_Empty
(Container
) then
2782 return (Container
'Unrestricted_Access, Container
.Last
);
2785 function Last
(Object
: Iterator
) return Cursor
is
2787 -- The value of the iterator object's Index component influences the
2788 -- behavior of the Last (and First) selector function.
2790 -- When the Index component is No_Index, this means the iterator
2791 -- object was constructed without a start expression, in which case the
2792 -- (reverse) iteration starts from the (logical) beginning of the entire
2793 -- sequence (corresponding to Container.Last, for a reverse iterator).
2795 -- Otherwise, this is iteration over a partial sequence of items.
2796 -- When the Index component is not No_Index, the iterator object was
2797 -- constructed with a start expression, that specifies the position
2798 -- from which the (reverse) partial iteration begins.
2800 if Object
.Index
= No_Index
then
2801 return Last
(Object
.Container
.all);
2803 return Cursor
'(Object.Container, Object.Index);
2811 function Last_Element (Container : Vector) return Element_Type is
2813 if Container.Last = No_Index then
2814 raise Constraint_Error with "Container is empty";
2818 EA : constant Element_Access :=
2819 Container.Elements.EA (Container.Last);
2823 raise Constraint_Error with "last element is empty";
2834 function Last_Index (Container : Vector) return Extended_Index is
2836 return Container.Last;
2843 function Length (Container : Vector) return Count_Type is
2844 L : constant Index_Type'Base := Container.Last;
2845 F : constant Index_Type := Index_Type'First;
2848 -- The base range of the index type (Index_Type'Base) might not include
2849 -- all values for length (Count_Type). Contrariwise, the index type
2850 -- might include values outside the range of length. Hence we use
2851 -- whatever type is wider for intermediate values when calculating
2852 -- length. Note that no matter what the index type is, the maximum
2853 -- length to which a vector is allowed to grow is always the minimum
2854 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2856 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2857 -- to have a base range of -128 .. 127, but the corresponding vector
2858 -- would have lengths in the range 0 .. 255. In this case we would need
2859 -- to use Count_Type'Base for intermediate values.
2861 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2862 -- vector would have a maximum length of 10, but the index values lie
2863 -- outside the range of Count_Type (which is only 32 bits). In this
2864 -- case we would need to use Index_Type'Base for intermediate values.
2866 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
2867 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2869 return Count_Type (L - F + 1);
2878 (Target : in out Vector;
2879 Source : in out Vector)
2882 if Target'Address = Source'Address then
2886 if Source.Busy > 0 then
2887 raise Program_Error with
2888 "attempt to tamper with cursors (Source is busy)";
2891 Clear (Target); -- Checks busy-bit
2894 Target_Elements : constant Elements_Access := Target.Elements;
2896 Target.Elements := Source.Elements;
2897 Source.Elements := Target_Elements;
2900 Target.Last := Source.Last;
2901 Source.Last := No_Index;
2908 function Next (Position : Cursor) return Cursor is
2910 if Position.Container = null then
2914 if Position.Index < Position.Container.Last then
2915 return (Position.Container, Position.Index + 1);
2921 function Next (Object : Iterator; Position : Cursor) return Cursor is
2923 if Position.Container = null then
2927 if Position.Container /= Object.Container then
2928 raise Program_Error with
2929 "Position cursor of Next designates wrong vector";
2932 return Next (Position);
2935 procedure Next (Position : in out Cursor) is
2937 if Position.Container = null then
2941 if Position.Index < Position.Container.Last then
2942 Position.Index := Position.Index + 1;
2944 Position := No_Element;
2952 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2954 Insert (Container, Index_Type'First, New_Item);
2958 (Container : in out Vector;
2959 New_Item : Element_Type;
2960 Count : Count_Type := 1)
2973 procedure Previous (Position : in out Cursor) is
2975 if Position.Container = null then
2979 if Position.Index > Index_Type'First then
2980 Position.Index := Position.Index - 1;
2982 Position := No_Element;
2986 function Previous (Position : Cursor) return Cursor is
2988 if Position.Container = null then
2992 if Position.Index > Index_Type'First then
2993 return (Position.Container, Position.Index - 1);
2999 function Previous (Object : Iterator; Position : Cursor) return Cursor is
3001 if Position.Container = null then
3005 if Position.Container /= Object.Container then
3006 raise Program_Error with
3007 "Position cursor of Previous designates wrong vector";
3010 return Previous (Position);
3017 procedure Query_Element
3018 (Container : Vector;
3020 Process : not null access procedure (Element : Element_Type))
3022 V : Vector renames Container'Unrestricted_Access.all;
3023 B : Natural renames V.Busy;
3024 L : Natural renames V.Lock;
3027 if Index > Container.Last then
3028 raise Constraint_Error with "Index is out of range";
3031 if V.Elements.EA (Index) = null then
3032 raise Constraint_Error with "element is null";
3039 Process (V.Elements.EA (Index).all);
3051 procedure Query_Element
3053 Process : not null access procedure (Element : Element_Type))
3056 if Position.Container = null then
3057 raise Constraint_Error with "Position cursor has no element";
3060 Query_Element (Position.Container.all, Position.Index, Process);
3068 (Stream : not null access Root_Stream_Type'Class;
3069 Container : out Vector)
3071 Length : Count_Type'Base;
3072 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
3079 Count_Type'Base'Read
(Stream
, Length
);
3081 if Length
> Capacity
(Container
) then
3082 Reserve_Capacity
(Container
, Capacity
=> Length
);
3085 for J
in Count_Type
range 1 .. Length
loop
3088 Boolean'Read (Stream
, B
);
3091 Container
.Elements
.EA
(Last
) :=
3092 new Element_Type
'(Element_Type'Input (Stream));
3095 Container.Last := Last;
3100 (Stream : not null access Root_Stream_Type'Class;
3101 Position : out Cursor)
3104 raise Program_Error with "attempt to stream vector cursor";
3108 (Stream : not null access Root_Stream_Type'Class;
3109 Item : out Reference_Type)
3112 raise Program_Error with "attempt to stream reference";
3116 (Stream : not null access Root_Stream_Type'Class;
3117 Item : out Constant_Reference_Type)
3120 raise Program_Error with "attempt to stream reference";
3128 (Container : aliased in out Vector;
3129 Position : Cursor) return Reference_Type
3134 if Position.Container = null then
3135 raise Constraint_Error with "Position cursor has no element";
3138 if Position.Container /= Container'Unrestricted_Access then
3139 raise Program_Error with "Position cursor denotes wrong container";
3142 if Position.Index > Position.Container.Last then
3143 raise Constraint_Error with "Position cursor is out of range";
3146 E := Container.Elements.EA (Position.Index);
3149 raise Constraint_Error with "element at Position is empty";
3153 C : Vector renames Container'Unrestricted_Access.all;
3154 B : Natural renames C.Busy;
3155 L : Natural renames C.Lock;
3157 return R : constant Reference_Type :=
3158 (Element => E.all'Access,
3159 Control => (Controlled with Position.Container))
3168 (Container : aliased in out Vector;
3169 Index : Index_Type) return Reference_Type
3174 if Index > Container.Last then
3175 raise Constraint_Error with "Index is out of range";
3178 E := Container.Elements.EA (Index);
3181 raise Constraint_Error with "element at Index is empty";
3185 C : Vector renames Container'Unrestricted_Access.all;
3186 B : Natural renames C.Busy;
3187 L : Natural renames C.Lock;
3189 return R : constant Reference_Type :=
3190 (Element => E.all'Access,
3192 (Controlled with Container'Unrestricted_Access))
3200 ---------------------
3201 -- Replace_Element --
3202 ---------------------
3204 procedure Replace_Element
3205 (Container : in out Vector;
3207 New_Item : Element_Type)
3210 if Index > Container.Last then
3211 raise Constraint_Error with "Index is out of range";
3214 if Container.Lock > 0 then
3215 raise Program_Error with
3216 "attempt to tamper with elements (vector is locked)";
3220 X : Element_Access := Container.Elements.EA (Index);
3222 -- The element allocator may need an accessibility check in the case
3223 -- where the actual type is class-wide or has access discriminants
3224 -- (see RM 4.8(10.1) and AI12-0035).
3226 pragma Unsuppress (Accessibility_Check);
3229 Container.Elements.EA (Index) := new Element_Type'(New_Item
);
3232 end Replace_Element
;
3234 procedure Replace_Element
3235 (Container
: in out Vector
;
3237 New_Item
: Element_Type
)
3240 if Position
.Container
= null then
3241 raise Constraint_Error
with "Position cursor has no element";
3244 if Position
.Container
/= Container
'Unrestricted_Access then
3245 raise Program_Error
with "Position cursor denotes wrong container";
3248 if Position
.Index
> Container
.Last
then
3249 raise Constraint_Error
with "Position cursor is out of range";
3252 if Container
.Lock
> 0 then
3253 raise Program_Error
with
3254 "attempt to tamper with elements (vector is locked)";
3258 X
: Element_Access
:= Container
.Elements
.EA
(Position
.Index
);
3260 -- The element allocator may need an accessibility check in the case
3261 -- where the actual type is class-wide or has access discriminants
3262 -- (see RM 4.8(10.1) and AI12-0035).
3264 pragma Unsuppress
(Accessibility_Check
);
3267 Container
.Elements
.EA
(Position
.Index
) := new Element_Type
'(New_Item);
3270 end Replace_Element;
3272 ----------------------
3273 -- Reserve_Capacity --
3274 ----------------------
3276 procedure Reserve_Capacity
3277 (Container : in out Vector;
3278 Capacity : Count_Type)
3280 N : constant Count_Type := Length (Container);
3282 Index : Count_Type'Base;
3283 Last : Index_Type'Base;
3286 -- Reserve_Capacity can be used to either expand the storage available
3287 -- for elements (this would be its typical use, in anticipation of
3288 -- future insertion), or to trim back storage. In the latter case,
3289 -- storage can only be trimmed back to the limit of the container
3290 -- length. Note that Reserve_Capacity neither deletes (active) elements
3291 -- nor inserts elements; it only affects container capacity, never
3292 -- container length.
3294 if Capacity = 0 then
3296 -- This is a request to trim back storage, to the minimum amount
3297 -- possible given the current state of the container.
3301 -- The container is empty, so in this unique case we can
3302 -- deallocate the entire internal array. Note that an empty
3303 -- container can never be busy, so there's no need to check the
3307 X : Elements_Access := Container.Elements;
3310 -- First we remove the internal array from the container, to
3311 -- handle the case when the deallocation raises an exception
3312 -- (although that's unlikely, since this is simply an array of
3313 -- access values, all of which are null).
3315 Container.Elements := null;
3317 -- Container invariants have been restored, so it is now safe
3318 -- to attempt to deallocate the internal array.
3323 elsif N < Container.Elements.EA'Length then
3325 -- The container is not empty, and the current length is less than
3326 -- the current capacity, so there's storage available to trim. In
3327 -- this case, we allocate a new internal array having a length
3328 -- that exactly matches the number of items in the
3329 -- container. (Reserve_Capacity does not delete active elements,
3330 -- so this is the best we can do with respect to minimizing
3333 if Container.Busy > 0 then
3334 raise Program_Error with
3335 "attempt to tamper with cursors (vector is busy)";
3339 subtype Array_Index_Subtype is Index_Type'Base range
3340 Index_Type'First .. Container.Last;
3342 Src : Elements_Array renames
3343 Container.Elements.EA (Array_Index_Subtype);
3345 X : Elements_Access := Container.Elements;
3348 -- Although we have isolated the old internal array that we're
3349 -- going to deallocate, we don't deallocate it until we have
3350 -- successfully allocated a new one. If there is an exception
3351 -- during allocation (because there is not enough storage), we
3352 -- let it propagate without causing any side-effect.
3354 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
3356 -- We have successfully allocated a new internal array (with a
3357 -- smaller length than the old one, and containing a copy of
3358 -- just the active elements in the container), so we can
3359 -- deallocate the old array.
3368 -- Reserve_Capacity can be used to expand the storage available for
3369 -- elements, but we do not let the capacity grow beyond the number of
3370 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3371 -- to refer to the elements with index values greater than
3372 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3373 -- the Last index value of the new internal array, in a way that avoids
3374 -- any possibility of overflow.
3376 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3378 -- We perform a two-part test. First we determine whether the
3379 -- computed Last value lies in the base range of the type, and then
3380 -- determine whether it lies in the range of the index (sub)type.
3382 -- Last must satisfy this relation:
3383 -- First + Length - 1 <= Last
3384 -- We regroup terms:
3385 -- First - 1 <= Last - Length
3386 -- Which can rewrite as:
3387 -- No_Index <= Last - Length
3389 if Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
then
3390 raise Constraint_Error
with "Capacity is out of range";
3393 -- We now know that the computed value of Last is within the base
3394 -- range of the type, so it is safe to compute its value:
3396 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
3398 -- Finally we test whether the value is within the range of the
3399 -- generic actual index subtype:
3401 if Last
> Index_Type
'Last then
3402 raise Constraint_Error
with "Capacity is out of range";
3405 elsif Index_Type
'First <= 0 then
3407 -- Here we can compute Last directly, in the normal way. We know that
3408 -- No_Index is less than 0, so there is no danger of overflow when
3409 -- adding the (positive) value of Capacity.
3411 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
3413 if Index
> Count_Type
'Base (Index_Type
'Last) then
3414 raise Constraint_Error
with "Capacity is out of range";
3417 -- We know that the computed value (having type Count_Type) of Last
3418 -- is within the range of the generic actual index subtype, so it is
3419 -- safe to convert to Index_Type:
3421 Last
:= Index_Type
'Base (Index
);
3424 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3425 -- must test the length indirectly (by working backwards from the
3426 -- largest possible value of Last), in order to prevent overflow.
3428 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
3430 if Index
< Count_Type
'Base (No_Index
) then
3431 raise Constraint_Error
with "Capacity is out of range";
3434 -- We have determined that the value of Capacity would not create a
3435 -- Last index value outside of the range of Index_Type, so we can now
3436 -- safely compute its value.
3438 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
3441 -- The requested capacity is non-zero, but we don't know yet whether
3442 -- this is a request for expansion or contraction of storage.
3444 if Container
.Elements
= null then
3446 -- The container is empty (it doesn't even have an internal array),
3447 -- so this represents a request to allocate storage having the given
3450 Container
.Elements
:= new Elements_Type
(Last
);
3454 if Capacity
<= N
then
3456 -- This is a request to trim back storage, but only to the limit of
3457 -- what's already in the container. (Reserve_Capacity never deletes
3458 -- active elements, it only reclaims excess storage.)
3460 if N
< Container
.Elements
.EA
'Length then
3462 -- The container is not empty (because the requested capacity is
3463 -- positive, and less than or equal to the container length), and
3464 -- the current length is less than the current capacity, so there
3465 -- is storage available to trim. In this case, we allocate a new
3466 -- internal array having a length that exactly matches the number
3467 -- of items in the container.
3469 if Container
.Busy
> 0 then
3470 raise Program_Error
with
3471 "attempt to tamper with cursors (vector is busy)";
3475 subtype Array_Index_Subtype
is Index_Type
'Base range
3476 Index_Type
'First .. Container
.Last
;
3478 Src
: Elements_Array
renames
3479 Container
.Elements
.EA
(Array_Index_Subtype
);
3481 X
: Elements_Access
:= Container
.Elements
;
3484 -- Although we have isolated the old internal array that we're
3485 -- going to deallocate, we don't deallocate it until we have
3486 -- successfully allocated a new one. If there is an exception
3487 -- during allocation (because there is not enough storage), we
3488 -- let it propagate without causing any side-effect.
3490 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
3492 -- We have successfully allocated a new internal array (with a
3493 -- smaller length than the old one, and containing a copy of
3494 -- just the active elements in the container), so it is now
3495 -- safe to deallocate the old array.
3504 -- The requested capacity is larger than the container length (the
3505 -- number of active elements). Whether this represents a request for
3506 -- expansion or contraction of the current capacity depends on what the
3507 -- current capacity is.
3509 if Capacity = Container.Elements.EA'Length then
3511 -- The requested capacity matches the existing capacity, so there's
3512 -- nothing to do here. We treat this case as a no-op, and simply
3513 -- return without checking the busy bit.
3518 -- There is a change in the capacity of a non-empty container, so a new
3519 -- internal array will be allocated. (The length of the new internal
3520 -- array could be less or greater than the old internal array. We know
3521 -- only that the length of the new internal array is greater than the
3522 -- number of active elements in the container.) We must check whether
3523 -- the container is busy before doing anything else.
3525 if Container.Busy > 0 then
3526 raise Program_Error with
3527 "attempt to tamper with cursors (vector is busy)";
3530 -- We now allocate a new internal array, having a length different from
3531 -- its current value.
3534 X : Elements_Access := Container.Elements;
3536 subtype Index_Subtype is Index_Type'Base range
3537 Index_Type'First .. Container.Last;
3540 -- We now allocate a new internal array, having a length different
3541 -- from its current value.
3543 Container.Elements := new Elements_Type (Last);
3545 -- We have successfully allocated the new internal array, so now we
3546 -- move the existing elements from the existing the old internal
3547 -- array onto the new one. Note that we're just copying access
3548 -- values, to this should not raise any exceptions.
3550 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3552 -- We have moved the elements from the old internal array, so now we
3553 -- can deallocate it.
3557 end Reserve_Capacity;
3559 ----------------------
3560 -- Reverse_Elements --
3561 ----------------------
3563 procedure Reverse_Elements (Container : in out Vector) is
3565 if Container.Length <= 1 then
3569 -- The exception behavior for the vector container must match that for
3570 -- the list container, so we check for cursor tampering here (which will
3571 -- catch more things) instead of for element tampering (which will catch
3572 -- fewer things). It's true that the elements of this vector container
3573 -- could be safely moved around while (say) an iteration is taking place
3574 -- (iteration only increments the busy counter), and so technically all
3575 -- we would need here is a test for element tampering (indicated by the
3576 -- lock counter), that's simply an artifact of our array-based
3577 -- implementation. Logically Reverse_Elements requires a check for
3578 -- cursor tampering.
3580 if Container.Busy > 0 then
3581 raise Program_Error with
3582 "attempt to tamper with cursors (vector is busy)";
3588 E : Elements_Array renames Container.Elements.EA;
3591 I := Index_Type'First;
3592 J := Container.Last;
3595 EI : constant Element_Access := E (I);
3606 end Reverse_Elements;
3612 function Reverse_Find
3613 (Container : Vector;
3614 Item : Element_Type;
3615 Position : Cursor := No_Element) return Cursor
3617 Last : Index_Type'Base;
3620 if Position.Container /= null
3621 and then Position.Container /= Container'Unrestricted_Access
3623 raise Program_Error with "Position cursor denotes wrong container";
3626 if Position.Container = null
3627 or else Position.Index > Container.Last
3629 Last := Container.Last;
3631 Last := Position.Index;
3634 for Indx in reverse Index_Type'First .. Last loop
3635 if Container.Elements.EA (Indx) /= null
3636 and then Container.Elements.EA (Indx).all = Item
3638 return (Container'Unrestricted_Access, Indx);
3645 ------------------------
3646 -- Reverse_Find_Index --
3647 ------------------------
3649 function Reverse_Find_Index
3650 (Container : Vector;
3651 Item : Element_Type;
3652 Index : Index_Type := Index_Type'Last) return Extended_Index
3654 Last : constant Index_Type'Base :=
3655 (if Index > Container.Last then Container.Last else Index);
3657 for Indx in reverse Index_Type'First .. Last loop
3658 if Container.Elements.EA (Indx) /= null
3659 and then Container.Elements.EA (Indx).all = Item
3666 end Reverse_Find_Index;
3668 ---------------------
3669 -- Reverse_Iterate --
3670 ---------------------
3672 procedure Reverse_Iterate
3673 (Container : Vector;
3674 Process : not null access procedure (Position : Cursor))
3676 V : Vector renames Container'Unrestricted_Access.all;
3677 B : Natural renames V.Busy;
3683 for Indx in reverse Index_Type'First .. Container.Last loop
3684 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
3693 end Reverse_Iterate
;
3699 procedure Set_Length
3700 (Container
: in out Vector
;
3701 Length
: Count_Type
)
3703 Count
: constant Count_Type
'Base := Container
.Length
- Length
;
3706 -- Set_Length allows the user to set the length explicitly, instead of
3707 -- implicitly as a side-effect of deletion or insertion. If the
3708 -- requested length is less than the current length, this is equivalent
3709 -- to deleting items from the back end of the vector. If the requested
3710 -- length is greater than the current length, then this is equivalent to
3711 -- inserting "space" (nonce items) at the end.
3714 Container
.Delete_Last
(Count
);
3716 elsif Container
.Last
>= Index_Type
'Last then
3717 raise Constraint_Error
with "vector is already at its maximum length";
3720 Container
.Insert_Space
(Container
.Last
+ 1, -Count
);
3729 (Container
: in out Vector
;
3733 if I
> Container
.Last
then
3734 raise Constraint_Error
with "I index is out of range";
3737 if J
> Container
.Last
then
3738 raise Constraint_Error
with "J index is out of range";
3745 if Container
.Lock
> 0 then
3746 raise Program_Error
with
3747 "attempt to tamper with elements (vector is locked)";
3751 EI
: Element_Access
renames Container
.Elements
.EA
(I
);
3752 EJ
: Element_Access
renames Container
.Elements
.EA
(J
);
3754 EI_Copy
: constant Element_Access
:= EI
;
3763 (Container
: in out Vector
;
3767 if I
.Container
= null then
3768 raise Constraint_Error
with "I cursor has no element";
3771 if J
.Container
= null then
3772 raise Constraint_Error
with "J cursor has no element";
3775 if I
.Container
/= Container
'Unrestricted_Access then
3776 raise Program_Error
with "I cursor denotes wrong container";
3779 if J
.Container
/= Container
'Unrestricted_Access then
3780 raise Program_Error
with "J cursor denotes wrong container";
3783 Swap
(Container
, I
.Index
, J
.Index
);
3791 (Container
: Vector
;
3792 Index
: Extended_Index
) return Cursor
3795 if Index
not in Index_Type
'First .. Container
.Last
then
3799 return Cursor
'(Container'Unrestricted_Access, Index);
3806 function To_Index (Position : Cursor) return Extended_Index is
3808 if Position.Container = null then
3812 if Position.Index <= Position.Container.Last then
3813 return Position.Index;
3823 function To_Vector (Length : Count_Type) return Vector is
3824 Index : Count_Type'Base;
3825 Last : Index_Type'Base;
3826 Elements : Elements_Access;
3830 return Empty_Vector;
3833 -- We create a vector object with a capacity that matches the specified
3834 -- Length, but we do not allow the vector capacity (the length of the
3835 -- internal array) to exceed the number of values in Index_Type'Range
3836 -- (otherwise, there would be no way to refer to those components via an
3837 -- index). We must therefore check whether the specified Length would
3838 -- create a Last index value greater than Index_Type'Last.
3840 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
3842 -- We perform a two-part test. First we determine whether the
3843 -- computed Last value lies in the base range of the type, and then
3844 -- determine whether it lies in the range of the index (sub)type.
3846 -- Last must satisfy this relation:
3847 -- First + Length - 1 <= Last
3848 -- We regroup terms:
3849 -- First - 1 <= Last - Length
3850 -- Which can rewrite as:
3851 -- No_Index <= Last - Length
3853 if Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index then
3854 raise Constraint_Error with "Length is out of range";
3857 -- We now know that the computed value of Last is within the base
3858 -- range of the type, so it is safe to compute its value:
3860 Last := No_Index + Index_Type'Base (Length);
3862 -- Finally we test whether the value is within the range of the
3863 -- generic actual index subtype:
3865 if Last > Index_Type'Last then
3866 raise Constraint_Error with "Length is out of range";
3869 elsif Index_Type'First <= 0 then
3871 -- Here we can compute Last directly, in the normal way. We know that
3872 -- No_Index is less than 0, so there is no danger of overflow when
3873 -- adding the (positive) value of Length.
3875 Index := Count_Type'Base (No_Index) + Length; -- Last
3877 if Index > Count_Type'Base (Index_Type'Last) then
3878 raise Constraint_Error with "Length is out of range";
3881 -- We know that the computed value (having type Count_Type) of Last
3882 -- is within the range of the generic actual index subtype, so it is
3883 -- safe to convert to Index_Type:
3885 Last := Index_Type'Base (Index);
3888 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3889 -- must test the length indirectly (by working backwards from the
3890 -- largest possible value of Last), in order to prevent overflow.
3892 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3894 if Index < Count_Type'Base (No_Index) then
3895 raise Constraint_Error with "Length is out of range";
3898 -- We have determined that the value of Length would not create a
3899 -- Last index value outside of the range of Index_Type, so we can now
3900 -- safely compute its value.
3902 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3905 Elements := new Elements_Type (Last);
3907 return Vector'(Controlled
with Elements
, Last
, 0, 0);
3911 (New_Item
: Element_Type
;
3912 Length
: Count_Type
) return Vector
3914 Index
: Count_Type
'Base;
3915 Last
: Index_Type
'Base;
3916 Elements
: Elements_Access
;
3920 return Empty_Vector
;
3923 -- We create a vector object with a capacity that matches the specified
3924 -- Length, but we do not allow the vector capacity (the length of the
3925 -- internal array) to exceed the number of values in Index_Type'Range
3926 -- (otherwise, there would be no way to refer to those components via an
3927 -- index). We must therefore check whether the specified Length would
3928 -- create a Last index value greater than Index_Type'Last.
3930 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3932 -- We perform a two-part test. First we determine whether the
3933 -- computed Last value lies in the base range of the type, and then
3934 -- determine whether it lies in the range of the index (sub)type.
3936 -- Last must satisfy this relation:
3937 -- First + Length - 1 <= Last
3938 -- We regroup terms:
3939 -- First - 1 <= Last - Length
3940 -- Which can rewrite as:
3941 -- No_Index <= Last - Length
3943 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
3944 raise Constraint_Error
with "Length is out of range";
3947 -- We now know that the computed value of Last is within the base
3948 -- range of the type, so it is safe to compute its value:
3950 Last
:= No_Index
+ Index_Type
'Base (Length
);
3952 -- Finally we test whether the value is within the range of the
3953 -- generic actual index subtype:
3955 if Last
> Index_Type
'Last then
3956 raise Constraint_Error
with "Length is out of range";
3959 elsif Index_Type
'First <= 0 then
3961 -- Here we can compute Last directly, in the normal way. We know that
3962 -- No_Index is less than 0, so there is no danger of overflow when
3963 -- adding the (positive) value of Length.
3965 Index
:= Count_Type
'Base (No_Index
) + Length
; -- Last
3967 if Index
> Count_Type
'Base (Index_Type
'Last) then
3968 raise Constraint_Error
with "Length is out of range";
3971 -- We know that the computed value (having type Count_Type) of Last
3972 -- is within the range of the generic actual index subtype, so it is
3973 -- safe to convert to Index_Type:
3975 Last
:= Index_Type
'Base (Index
);
3978 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3979 -- must test the length indirectly (by working backwards from the
3980 -- largest possible value of Last), in order to prevent overflow.
3982 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
3984 if Index
< Count_Type
'Base (No_Index
) then
3985 raise Constraint_Error
with "Length is out of range";
3988 -- We have determined that the value of Length would not create a
3989 -- Last index value outside of the range of Index_Type, so we can now
3990 -- safely compute its value.
3992 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
3995 Elements
:= new Elements_Type
(Last
);
3997 -- We use Last as the index of the loop used to populate the internal
3998 -- array with items. In general, we prefer to initialize the loop index
3999 -- immediately prior to entering the loop. However, Last is also used in
4000 -- the exception handler (to reclaim elements that have been allocated,
4001 -- before propagating the exception), and the initialization of Last
4002 -- after entering the block containing the handler confuses some static
4003 -- analysis tools, with respect to whether Last has been properly
4004 -- initialized when the handler executes. So here we initialize our loop
4005 -- variable earlier than we prefer, before entering the block, so there
4008 Last
:= Index_Type
'First;
4011 -- The element allocator may need an accessibility check in the case
4012 -- where the actual type is class-wide or has access discriminants
4013 -- (see RM 4.8(10.1) and AI12-0035).
4015 pragma Unsuppress
(Accessibility_Check
);
4019 Elements
.EA
(Last
) := new Element_Type
'(New_Item);
4020 exit when Last = Elements.Last;
4026 for J in Index_Type'First .. Last - 1 loop
4027 Free (Elements.EA (J));
4034 return (Controlled with Elements, Last, 0, 0);
4037 --------------------
4038 -- Update_Element --
4039 --------------------
4041 procedure Update_Element
4042 (Container : in out Vector;
4044 Process : not null access procedure (Element : in out Element_Type))
4046 B : Natural renames Container.Busy;
4047 L : Natural renames Container.Lock;
4050 if Index > Container.Last then
4051 raise Constraint_Error with "Index is out of range";
4054 if Container.Elements.EA (Index) = null then
4055 raise Constraint_Error with "element is null";
4062 Process (Container.Elements.EA (Index).all);
4074 procedure Update_Element
4075 (Container : in out Vector;
4077 Process : not null access procedure (Element : in out Element_Type))
4080 if Position.Container = null then
4081 raise Constraint_Error with "Position cursor has no element";
4084 if Position.Container /= Container'Unrestricted_Access then
4085 raise Program_Error with "Position cursor denotes wrong container";
4088 Update_Element (Container, Position.Index, Process);
4096 (Stream : not null access Root_Stream_Type'Class;
4099 N : constant Count_Type := Length (Container);
4102 Count_Type'Base'Write
(Stream
, N
);
4109 E
: Elements_Array
renames Container
.Elements
.EA
;
4112 for Indx
in Index_Type
'First .. Container
.Last
loop
4113 if E
(Indx
) = null then
4114 Boolean'Write (Stream
, False);
4116 Boolean'Write (Stream
, True);
4117 Element_Type
'Output (Stream
, E
(Indx
).all);
4124 (Stream
: not null access Root_Stream_Type
'Class;
4128 raise Program_Error
with "attempt to stream vector cursor";
4132 (Stream
: not null access Root_Stream_Type
'Class;
4133 Item
: Reference_Type
)
4136 raise Program_Error
with "attempt to stream reference";
4140 (Stream
: not null access Root_Stream_Type
'Class;
4141 Item
: Constant_Reference_Type
)
4144 raise Program_Error
with "attempt to stream reference";
4147 end Ada
.Containers
.Indefinite_Vectors
;