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-2013, 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
);
47 function "&" (Left
, Right
: Vector
) return Vector
is
48 LN
: constant Count_Type
:= Length
(Left
);
49 RN
: constant Count_Type
:= Length
(Right
);
50 N
: Count_Type
'Base; -- length of result
51 J
: Count_Type
'Base; -- for computing intermediate values
52 Last
: Index_Type
'Base; -- Last index of result
55 -- We decide that the capacity of the result is the sum of the lengths
56 -- of the vector parameters. We could decide to make it larger, but we
57 -- have no basis for knowing how much larger, so we just allocate the
58 -- minimum amount of storage.
60 -- Here we handle the easy cases first, when one of the vector
61 -- parameters is empty. (We say "easy" because there's nothing to
62 -- compute, that can potentially overflow.)
70 RE
: Elements_Array
renames
71 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
73 Elements
: Elements_Access
:= new Elements_Type
(Right
.Last
);
76 -- Elements of an indefinite vector are allocated, so we cannot
77 -- use simple slice assignment to give a value to our result.
78 -- Hence we must walk the array of the Right vector, and copy
79 -- each source element individually.
81 for I
in Elements
.EA
'Range loop
83 if RE
(I
) /= null then
84 Elements
.EA
(I
) := new Element_Type
'(RE (I).all);
89 for J in Index_Type'First .. I - 1 loop
90 Free (Elements.EA (J));
98 return (Controlled with Elements, Right.Last, 0, 0);
104 LE : Elements_Array renames
105 Left.Elements.EA (Index_Type'First .. Left.Last);
107 Elements : Elements_Access := new Elements_Type (Left.Last);
110 -- Elements of an indefinite vector are allocated, so we cannot
111 -- use simple slice assignment to give a value to our result.
112 -- Hence we must walk the array of the Left vector, and copy
113 -- each source element individually.
115 for I in Elements.EA'Range loop
117 if LE (I) /= null then
118 Elements.EA (I) := new Element_Type'(LE
(I
).all);
123 for J
in Index_Type
'First .. I
- 1 loop
124 Free
(Elements
.EA
(J
));
132 return (Controlled
with Elements
, Left
.Last
, 0, 0);
136 -- Neither of the vector parameters is empty, so we must compute the
137 -- length of the result vector and its last index. (This is the harder
138 -- case, because our computations must avoid overflow.)
140 -- There are two constraints we need to satisfy. The first constraint is
141 -- that a container cannot have more than Count_Type'Last elements, so
142 -- we must check the sum of the combined lengths. Note that we cannot
143 -- simply add the lengths, because of the possibility of overflow.
145 if LN
> Count_Type
'Last - RN
then
146 raise Constraint_Error
with "new length is out of range";
149 -- It is now safe compute the length of the new vector.
153 -- The second constraint is that the new Last index value cannot
154 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
155 -- Count_Type'Base as the type for intermediate values.
157 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
159 -- We perform a two-part test. First we determine whether the
160 -- computed Last value lies in the base range of the type, and then
161 -- determine whether it lies in the range of the index (sub)type.
163 -- Last must satisfy this relation:
164 -- First + Length - 1 <= Last
166 -- First - 1 <= Last - Length
167 -- Which can rewrite as:
168 -- No_Index <= Last - Length
170 if Index_Type'Base'Last
- Index_Type
'Base (N
) < No_Index
then
171 raise Constraint_Error
with "new length is out of range";
174 -- We now know that the computed value of Last is within the base
175 -- range of the type, so it is safe to compute its value:
177 Last
:= No_Index
+ Index_Type
'Base (N
);
179 -- Finally we test whether the value is within the range of the
180 -- generic actual index subtype:
182 if Last
> Index_Type
'Last then
183 raise Constraint_Error
with "new length is out of range";
186 elsif Index_Type
'First <= 0 then
188 -- Here we can compute Last directly, in the normal way. We know that
189 -- No_Index is less than 0, so there is no danger of overflow when
190 -- adding the (positive) value of length.
192 J
:= Count_Type
'Base (No_Index
) + N
; -- Last
194 if J
> Count_Type
'Base (Index_Type
'Last) then
195 raise Constraint_Error
with "new length is out of range";
198 -- We know that the computed value (having type Count_Type) of Last
199 -- is within the range of the generic actual index subtype, so it is
200 -- safe to convert to Index_Type:
202 Last
:= Index_Type
'Base (J
);
205 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
206 -- must test the length indirectly (by working backwards from the
207 -- largest possible value of Last), in order to prevent overflow.
209 J
:= Count_Type
'Base (Index_Type
'Last) - N
; -- No_Index
211 if J
< Count_Type
'Base (No_Index
) then
212 raise Constraint_Error
with "new length is out of range";
215 -- We have determined that the result length would not create a Last
216 -- index value outside of the range of Index_Type, so we can now
217 -- safely compute its value.
219 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + N
);
223 LE
: Elements_Array
renames
224 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
225 RE
: Elements_Array
renames
226 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
228 Elements
: Elements_Access
:= new Elements_Type
(Last
);
230 I
: Index_Type
'Base := No_Index
;
233 -- Elements of an indefinite vector are allocated, so we cannot use
234 -- simple slice assignment to give a value to our result. Hence we
235 -- must walk the array of each vector parameter, and copy each source
236 -- element individually.
238 for LI
in LE
'Range loop
242 if LE
(LI
) /= null then
243 Elements
.EA
(I
) := new Element_Type
'(LE (LI).all);
248 for J in Index_Type'First .. I - 1 loop
249 Free (Elements.EA (J));
257 for RI in RE'Range loop
261 if RE (RI) /= null then
262 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
267 for J
in Index_Type
'First .. I
- 1 loop
268 Free
(Elements
.EA
(J
));
276 return (Controlled
with Elements
, Last
, 0, 0);
280 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
282 -- We decide that the capacity of the result is the sum of the lengths
283 -- of the parameters. We could decide to make it larger, but we have no
284 -- basis for knowing how much larger, so we just allocate the minimum
285 -- amount of storage.
287 -- Here we handle the easy case first, when the vector parameter (Left)
290 if Left
.Is_Empty
then
292 Elements
: Elements_Access
:= new Elements_Type
(Index_Type
'First);
296 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Right);
303 return (Controlled with Elements, Index_Type'First, 0, 0);
307 -- The vector parameter is not empty, so we must compute the length of
308 -- the result vector and its last index, but in such a way that overflow
309 -- is avoided. We must satisfy two constraints: the new length cannot
310 -- exceed Count_Type'Last, and the new Last index cannot exceed
313 if Left.Length = Count_Type'Last then
314 raise Constraint_Error with "new length is out of range";
317 if Left.Last >= Index_Type'Last then
318 raise Constraint_Error with "new length is out of range";
322 Last : constant Index_Type := Left.Last + 1;
324 LE : Elements_Array renames
325 Left.Elements.EA (Index_Type'First .. Left.Last);
327 Elements : Elements_Access := new Elements_Type (Last);
330 for I in LE'Range loop
332 if LE (I) /= null then
333 Elements.EA (I) := new Element_Type'(LE
(I
).all);
338 for J
in Index_Type
'First .. I
- 1 loop
339 Free
(Elements
.EA
(J
));
348 Elements
.EA
(Last
) := new Element_Type
'(Right);
352 for J in Index_Type'First .. Last - 1 loop
353 Free (Elements.EA (J));
360 return (Controlled with Elements, Last, 0, 0);
364 function "&" (Left : Element_Type; Right : Vector) return Vector is
366 -- We decide that the capacity of the result is the sum of the lengths
367 -- of the parameters. We could decide to make it larger, but we have no
368 -- basis for knowing how much larger, so we just allocate the minimum
369 -- amount of storage.
371 -- Here we handle the easy case first, when the vector parameter (Right)
374 if Right.Is_Empty then
376 Elements : Elements_Access := new Elements_Type (Index_Type'First);
380 Elements.EA (Index_Type'First) := new Element_Type'(Left
);
387 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
391 -- The vector parameter is not empty, so we must compute the length of
392 -- the result vector and its last index, but in such a way that overflow
393 -- is avoided. We must satisfy two constraints: the new length cannot
394 -- exceed Count_Type'Last, and the new Last index cannot exceed
397 if Right
.Length
= Count_Type
'Last then
398 raise Constraint_Error
with "new length is out of range";
401 if Right
.Last
>= Index_Type
'Last then
402 raise Constraint_Error
with "new length is out of range";
406 Last
: constant Index_Type
:= Right
.Last
+ 1;
408 RE
: Elements_Array
renames
409 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
411 Elements
: Elements_Access
:= new Elements_Type
(Last
);
413 I
: Index_Type
'Base := Index_Type
'First;
417 Elements
.EA
(I
) := new Element_Type
'(Left);
424 for RI in RE'Range loop
428 if RE (RI) /= null then
429 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
434 for J
in Index_Type
'First .. I
- 1 loop
435 Free
(Elements
.EA
(J
));
443 return (Controlled
with Elements
, Last
, 0, 0);
447 function "&" (Left
, Right
: Element_Type
) return Vector
is
449 -- We decide that the capacity of the result is the sum of the lengths
450 -- of the parameters. We could decide to make it larger, but we have no
451 -- basis for knowing how much larger, so we just allocate the minimum
452 -- amount of storage.
454 -- We must compute the length of the result vector and its last index,
455 -- but in such a way that overflow is avoided. We must satisfy two
456 -- constraints: the new length cannot exceed Count_Type'Last (here, we
457 -- know that that condition is satisfied), and the new Last index cannot
458 -- exceed Index_Type'Last.
460 if Index_Type
'First >= Index_Type
'Last then
461 raise Constraint_Error
with "new length is out of range";
465 Last
: constant Index_Type
:= Index_Type
'First + 1;
466 Elements
: Elements_Access
:= new Elements_Type
(Last
);
470 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Left);
478 Elements.EA (Last) := new Element_Type'(Right
);
481 Free
(Elements
.EA
(Index_Type
'First));
486 return (Controlled
with Elements
, Last
, 0, 0);
494 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
495 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
496 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
498 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
499 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
504 if Left
'Address = Right
'Address then
508 if Left
.Last
/= Right
.Last
then
512 -- Per AI05-0022, the container implementation is required to detect
513 -- element tampering by a generic actual subprogram.
522 for J
in Index_Type
'First .. Left
.Last
loop
523 if Left
.Elements
.EA
(J
) = null then
524 if Right
.Elements
.EA
(J
) /= null then
529 elsif Right
.Elements
.EA
(J
) = null then
533 elsif Left
.Elements
.EA
(J
).all /= Right
.Elements
.EA
(J
).all then
561 procedure Adjust
(Container
: in out Vector
) is
563 if Container
.Last
= No_Index
then
564 Container
.Elements
:= null;
569 L
: constant Index_Type
:= Container
.Last
;
570 E
: Elements_Array
renames
571 Container
.Elements
.EA
(Index_Type
'First .. L
);
574 Container
.Elements
:= null;
575 Container
.Last
:= No_Index
;
579 Container
.Elements
:= new Elements_Type
(L
);
581 for J
in E
'Range loop
582 if E
(J
) /= null then
583 Container
.Elements
.EA
(J
) := new Element_Type
'(E (J).all);
591 procedure Adjust (Control : in out Reference_Control_Type) is
593 if Control.Container /= null then
595 C : Vector renames Control.Container.all;
596 B : Natural renames C.Busy;
597 L : Natural renames C.Lock;
609 procedure Append (Container : in out Vector; New_Item : Vector) is
611 if Is_Empty (New_Item) then
613 elsif Container.Last = Index_Type'Last then
614 raise Constraint_Error with "vector is already at its maximum length";
616 Insert (Container, Container.Last + 1, New_Item);
621 (Container : in out Vector;
622 New_Item : Element_Type;
623 Count : Count_Type := 1)
628 elsif Container.Last = Index_Type'Last then
629 raise Constraint_Error with "vector is already at its maximum length";
631 Insert (Container, Container.Last + 1, New_Item, Count);
639 procedure Assign (Target : in out Vector; Source : Vector) is
641 if Target'Address = Source'Address then
645 Target.Append (Source);
653 function Capacity (Container : Vector) return Count_Type is
655 if Container.Elements = null then
658 return Container.Elements.EA'Length;
666 procedure Clear (Container : in out Vector) is
668 if Container.Busy > 0 then
669 raise Program_Error with
670 "attempt to tamper with cursors (vector is busy)";
673 while Container.Last >= Index_Type'First loop
675 X : Element_Access := Container.Elements.EA (Container.Last);
677 Container.Elements.EA (Container.Last) := null;
678 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,
721 Control => (Controlled with Container'Unrestricted_Access))
727 end Constant_Reference;
729 function Constant_Reference
730 (Container : aliased Vector;
731 Index : Index_Type) return Constant_Reference_Type
736 if Index > Container.Last then
737 raise Constraint_Error with "Index is out of range";
740 E := Container.Elements.EA (Index);
743 raise Constraint_Error with "element at Index is empty";
747 C : Vector renames Container'Unrestricted_Access.all;
748 B : Natural renames C.Busy;
749 L : Natural renames C.Lock;
751 return R : constant Constant_Reference_Type :=
752 (Element => E.all'Access,
753 Control => (Controlled with Container'Unrestricted_Access))
759 end Constant_Reference;
767 Item : Element_Type) return Boolean
770 return Find_Index (Container, Item) /= No_Index;
779 Capacity : Count_Type := 0) return Vector
787 elsif Capacity >= Source.Length then
792 with "Requested capacity is less than Source length";
795 return Target : Vector do
796 Target.Reserve_Capacity (C);
797 Target.Assign (Source);
806 (Container : in out Vector;
807 Index : Extended_Index;
808 Count : Count_Type := 1)
810 Old_Last : constant Index_Type'Base := Container.Last;
811 New_Last : Index_Type'Base;
812 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
813 J : Index_Type'Base; -- first index of items that slide down
816 -- Delete removes items from the vector, the number of which is the
817 -- minimum of the specified Count and the items (if any) that exist from
818 -- Index to Container.Last. There are no constraints on the specified
819 -- value of Count (it can be larger than what's available at this
820 -- position in the vector, for example), but there are constraints on
821 -- the allowed values of the Index.
823 -- As a precondition on the generic actual Index_Type, the base type
824 -- must include Index_Type'Pred (Index_Type'First); this is the value
825 -- that Container.Last assumes when the vector is empty. However, we do
826 -- not allow that as the value for Index when specifying which items
827 -- should be deleted, so we must manually check. (That the user is
828 -- allowed to specify the value at all here is a consequence of the
829 -- declaration of the Extended_Index subtype, which includes the values
830 -- in the base range that immediately precede and immediately follow the
831 -- values in the Index_Type.)
833 if Index < Index_Type'First then
834 raise Constraint_Error with "Index is out of range (too small)";
837 -- We do allow a value greater than Container.Last to be specified as
838 -- the Index, but only if it's immediately greater. This allows the
839 -- corner case of deleting no items from the back end of the vector to
840 -- be treated as a no-op. (It is assumed that specifying an index value
841 -- greater than Last + 1 indicates some deeper flaw in the caller's
842 -- algorithm, so that case is treated as a proper error.)
844 if Index > Old_Last then
845 if Index > Old_Last + 1 then
846 raise Constraint_Error with "Index is out of range (too large)";
852 -- Here and elsewhere we treat deleting 0 items from the container as a
853 -- no-op, even when the container is busy, so we simply return.
859 -- The internal elements array isn't guaranteed to exist unless we have
860 -- elements, so we handle that case here in order to avoid having to
861 -- check it later. (Note that an empty vector can never be busy, so
862 -- there's no semantic harm in returning early.)
864 if Container.Is_Empty then
868 -- The tampering bits exist to prevent an item from being deleted (or
869 -- otherwise harmfully manipulated) while it is being visited. Query,
870 -- Update, and Iterate increment the busy count on entry, and decrement
871 -- the count on exit. Delete checks the count to determine whether it is
872 -- being called while the associated callback procedure is executing.
874 if Container.Busy > 0 then
875 raise Program_Error with
876 "attempt to tamper with cursors (vector is busy)";
879 -- We first calculate what's available for deletion starting at
880 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
881 -- Count_Type'Base as the type for intermediate values. (See function
882 -- Length for more information.)
884 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
885 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
888 Count2 := Count_Type'Base (Old_Last - Index + 1);
891 -- If the number of elements requested (Count) for deletion is equal to
892 -- (or greater than) the number of elements available (Count2) for
893 -- deletion beginning at Index, then everything from Index to
894 -- Container.Last is deleted (this is equivalent to Delete_Last).
896 if Count >= Count2 then
897 -- Elements in an indefinite vector are allocated, so we must iterate
898 -- over the loop and deallocate elements one-at-a-time. We work from
899 -- back to front, deleting the last element during each pass, in
900 -- order to gracefully handle deallocation failures.
903 EA : Elements_Array renames Container.Elements.EA;
906 while Container.Last >= Index loop
908 K : constant Index_Type := Container.Last;
909 X : Element_Access := EA (K);
912 -- We first isolate the element we're deleting, removing it
913 -- from the vector before we attempt to deallocate it, in
914 -- case the deallocation fails.
917 Container.Last := K - 1;
919 -- Container invariants have been restored, so it is now
920 -- safe to attempt to deallocate the element.
930 -- There are some elements that aren't being deleted (the requested
931 -- count was less than the available count), so we must slide them down
932 -- to Index. We first calculate the index values of the respective array
933 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
934 -- type for intermediate calculations. For the elements that slide down,
935 -- index value New_Last is the last index value of their new home, and
936 -- index value J is the first index of their old home.
938 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
939 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
940 J
:= Index
+ Index_Type
'Base (Count
);
942 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
943 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
946 -- The internal elements array isn't guaranteed to exist unless we have
947 -- elements, but we have that guarantee here because we know we have
948 -- elements to slide. The array index values for each slice have
949 -- already been determined, so what remains to be done is to first
950 -- deallocate the elements that are being deleted, and then slide down
951 -- to Index the elements that aren't being deleted.
954 EA
: Elements_Array
renames Container
.Elements
.EA
;
957 -- Before we can slide down the elements that aren't being deleted,
958 -- we need to deallocate the elements that are being deleted.
960 for K
in Index
.. J
- 1 loop
962 X
: Element_Access
:= EA
(K
);
965 -- First we remove the element we're about to deallocate from
966 -- the vector, in case the deallocation fails, in order to
967 -- preserve representation invariants.
971 -- The element has been removed from the vector, so it is now
972 -- safe to attempt to deallocate it.
978 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
979 Container
.Last
:= New_Last
;
984 (Container
: in out Vector
;
985 Position
: in out Cursor
;
986 Count
: Count_Type
:= 1)
988 pragma Warnings
(Off
, Position
);
991 if Position
.Container
= null then
992 raise Constraint_Error
with "Position cursor has no element";
994 elsif Position
.Container
/= Container
'Unrestricted_Access then
995 raise Program_Error
with "Position cursor denotes wrong container";
997 elsif Position
.Index
> Container
.Last
then
998 raise Program_Error
with "Position index is out of range";
1001 Delete
(Container
, Position
.Index
, Count
);
1002 Position
:= No_Element
;
1010 procedure Delete_First
1011 (Container
: in out Vector
;
1012 Count
: Count_Type
:= 1)
1018 elsif Count
>= Length
(Container
) then
1023 Delete
(Container
, Index_Type
'First, Count
);
1031 procedure Delete_Last
1032 (Container
: in out Vector
;
1033 Count
: Count_Type
:= 1)
1036 -- It is not permitted to delete items while the container is busy (for
1037 -- example, we're in the middle of a passive iteration). However, we
1038 -- always treat deleting 0 items as a no-op, even when we're busy, so we
1039 -- simply return without checking.
1045 -- We cannot simply subsume the empty case into the loop below (the loop
1046 -- would iterate 0 times), because we rename the internal array object
1047 -- (which is allocated), but an empty vector isn't guaranteed to have
1048 -- actually allocated an array. (Note that an empty vector can never be
1049 -- busy, so there's no semantic harm in returning early here.)
1051 if Container
.Is_Empty
then
1055 -- The tampering bits exist to prevent an item from being deleted (or
1056 -- otherwise harmfully manipulated) while it is being visited. Query,
1057 -- Update, and Iterate increment the busy count on entry, and decrement
1058 -- the count on exit. Delete_Last checks the count to determine whether
1059 -- it is being called while the associated callback procedure is
1062 if Container
.Busy
> 0 then
1063 raise Program_Error
with
1064 "attempt to tamper with cursors (vector is busy)";
1067 -- Elements in an indefinite vector are allocated, so we must iterate
1068 -- over the loop and deallocate elements one-at-a-time. We work from
1069 -- back to front, deleting the last element during each pass, in order
1070 -- to gracefully handle deallocation failures.
1073 E
: Elements_Array
renames Container
.Elements
.EA
;
1076 for Indx
in 1 .. Count_Type
'Min (Count
, Container
.Length
) loop
1078 J
: constant Index_Type
:= Container
.Last
;
1079 X
: Element_Access
:= E
(J
);
1082 -- Note that we first isolate the element we're deleting,
1083 -- removing it from the vector, before we actually deallocate
1084 -- it, in order to preserve representation invariants even if
1085 -- the deallocation fails.
1088 Container
.Last
:= J
- 1;
1090 -- Container invariants have been restored, so it is now safe
1091 -- to deallocate the element.
1104 (Container
: Vector
;
1105 Index
: Index_Type
) return Element_Type
1108 if Index
> Container
.Last
then
1109 raise Constraint_Error
with "Index is out of range";
1113 EA
: constant Element_Access
:= Container
.Elements
.EA
(Index
);
1116 raise Constraint_Error
with "element is empty";
1123 function Element
(Position
: Cursor
) return Element_Type
is
1125 if Position
.Container
= null then
1126 raise Constraint_Error
with "Position cursor has no element";
1129 if Position
.Index
> Position
.Container
.Last
then
1130 raise Constraint_Error
with "Position cursor is out of range";
1134 EA
: constant Element_Access
:=
1135 Position
.Container
.Elements
.EA
(Position
.Index
);
1138 raise Constraint_Error
with "element is empty";
1149 procedure Finalize
(Container
: in out Vector
) is
1151 Clear
(Container
); -- Checks busy-bit
1154 X
: Elements_Access
:= Container
.Elements
;
1156 Container
.Elements
:= null;
1161 procedure Finalize
(Object
: in out Iterator
) is
1162 B
: Natural renames Object
.Container
.Busy
;
1167 procedure Finalize
(Control
: in out Reference_Control_Type
) is
1169 if Control
.Container
/= null then
1171 C
: Vector
renames Control
.Container
.all;
1172 B
: Natural renames C
.Busy
;
1173 L
: Natural renames C
.Lock
;
1179 Control
.Container
:= null;
1188 (Container
: Vector
;
1189 Item
: Element_Type
;
1190 Position
: Cursor
:= No_Element
) return Cursor
1193 if Position
.Container
/= null then
1194 if Position
.Container
/= Container
'Unrestricted_Access then
1195 raise Program_Error
with "Position cursor denotes wrong container";
1198 if Position
.Index
> Container
.Last
then
1199 raise Program_Error
with "Position index is out of range";
1203 -- Per AI05-0022, the container implementation is required to detect
1204 -- element tampering by a generic actual subprogram.
1207 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1208 L
: Natural renames Container
'Unrestricted_Access.Lock
;
1210 Result
: Index_Type
'Base;
1217 for J
in Position
.Index
.. Container
.Last
loop
1218 if Container
.Elements
.EA
(J
) /= null
1219 and then Container
.Elements
.EA
(J
).all = Item
1229 if Result
= No_Index
then
1232 return Cursor
'(Container'Unrestricted_Access, Result);
1248 (Container : Vector;
1249 Item : Element_Type;
1250 Index : Index_Type := Index_Type'First) return Extended_Index
1252 B : Natural renames Container'Unrestricted_Access.Busy;
1253 L : Natural renames Container'Unrestricted_Access.Lock;
1255 Result : Index_Type'Base;
1258 -- Per AI05-0022, the container implementation is required to detect
1259 -- element tampering by a generic actual subprogram.
1265 for Indx in Index .. Container.Last loop
1266 if Container.Elements.EA (Indx) /= null
1267 and then Container.Elements.EA (Indx).all = Item
1290 function First (Container : Vector) return Cursor is
1292 if Is_Empty (Container) then
1296 return (Container'Unrestricted_Access, Index_Type'First);
1299 function First (Object : Iterator) return Cursor is
1301 -- The value of the iterator object's Index component influences the
1302 -- behavior of the First (and Last) selector function.
1304 -- When the Index component is No_Index, this means the iterator
1305 -- object was constructed without a start expression, in which case the
1306 -- (forward) iteration starts from the (logical) beginning of the entire
1307 -- sequence of items (corresponding to Container.First, for a forward
1310 -- Otherwise, this is iteration over a partial sequence of items.
1311 -- When the Index component isn't No_Index, the iterator object was
1312 -- constructed with a start expression, that specifies the position
1313 -- from which the (forward) partial iteration begins.
1315 if Object.Index = No_Index then
1316 return First (Object.Container.all);
1318 return Cursor'(Object
.Container
, Object
.Index
);
1326 function First_Element
(Container
: Vector
) return Element_Type
is
1328 if Container
.Last
= No_Index
then
1329 raise Constraint_Error
with "Container is empty";
1333 EA
: constant Element_Access
:=
1334 Container
.Elements
.EA
(Index_Type
'First);
1337 raise Constraint_Error
with "first element is empty";
1348 function First_Index
(Container
: Vector
) return Index_Type
is
1349 pragma Unreferenced
(Container
);
1351 return Index_Type
'First;
1354 ---------------------
1355 -- Generic_Sorting --
1356 ---------------------
1358 package body Generic_Sorting
is
1360 -----------------------
1361 -- Local Subprograms --
1362 -----------------------
1364 function Is_Less
(L
, R
: Element_Access
) return Boolean;
1365 pragma Inline
(Is_Less
);
1371 function Is_Less
(L
, R
: Element_Access
) return Boolean is
1378 return L
.all < R
.all;
1386 function Is_Sorted
(Container
: Vector
) return Boolean is
1388 if Container
.Last
<= Index_Type
'First then
1392 -- Per AI05-0022, the container implementation is required to detect
1393 -- element tampering by a generic actual subprogram.
1396 E
: Elements_Array
renames Container
.Elements
.EA
;
1398 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1399 L
: Natural renames Container
'Unrestricted_Access.Lock
;
1408 for I
in Index_Type
'First .. Container
.Last
- 1 loop
1409 if Is_Less
(E
(I
+ 1), E
(I
)) then
1432 procedure Merge
(Target
, Source
: in out Vector
) is
1433 I
, J
: Index_Type
'Base;
1436 -- The semantics of Merge changed slightly per AI05-0021. It was
1437 -- originally the case that if Target and Source denoted the same
1438 -- container object, then the GNAT implementation of Merge did
1439 -- nothing. However, it was argued that RM05 did not precisely
1440 -- specify the semantics for this corner case. The decision of the
1441 -- ARG was that if Target and Source denote the same non-empty
1442 -- container object, then Program_Error is raised.
1444 if Source
.Last
< Index_Type
'First then -- Source is empty
1448 if Target
'Address = Source
'Address then
1449 raise Program_Error
with
1450 "Target and Source denote same non-empty container";
1453 if Target
.Last
< Index_Type
'First then -- Target is empty
1454 Move
(Target
=> Target
, Source
=> Source
);
1458 if Source
.Busy
> 0 then
1459 raise Program_Error
with
1460 "attempt to tamper with cursors (vector is busy)";
1463 I
:= Target
.Last
; -- original value (before Set_Length)
1464 Target
.Set_Length
(Length
(Target
) + Length
(Source
));
1466 -- Per AI05-0022, the container implementation is required to detect
1467 -- element tampering by a generic actual subprogram.
1470 TA
: Elements_Array
renames Target
.Elements
.EA
;
1471 SA
: Elements_Array
renames Source
.Elements
.EA
;
1473 TB
: Natural renames Target
.Busy
;
1474 TL
: Natural renames Target
.Lock
;
1476 SB
: Natural renames Source
.Busy
;
1477 SL
: Natural renames Source
.Lock
;
1486 J
:= Target
.Last
; -- new value (after Set_Length)
1487 while Source
.Last
>= Index_Type
'First loop
1489 (Source
.Last
<= Index_Type
'First
1490 or else not (Is_Less
(SA
(Source
.Last
),
1491 SA
(Source
.Last
- 1))));
1493 if I
< Index_Type
'First then
1495 Src
: Elements_Array
renames
1496 SA
(Index_Type
'First .. Source
.Last
);
1498 TA
(Index_Type
'First .. J
) := Src
;
1499 Src
:= (others => null);
1502 Source
.Last
:= No_Index
;
1507 (I
<= Index_Type
'First
1508 or else not (Is_Less
(TA
(I
), TA
(I
- 1))));
1511 Src
: Element_Access
renames SA
(Source
.Last
);
1512 Tgt
: Element_Access
renames TA
(I
);
1515 if Is_Less
(Src
, Tgt
) then
1516 Target
.Elements
.EA
(J
) := Tgt
;
1521 Target
.Elements
.EA
(J
) := Src
;
1523 Source
.Last
:= Source
.Last
- 1;
1552 procedure Sort
(Container
: in out Vector
) is
1553 procedure Sort
is new Generic_Array_Sort
1554 (Index_Type
=> Index_Type
,
1555 Element_Type
=> Element_Access
,
1556 Array_Type
=> Elements_Array
,
1559 -- Start of processing for Sort
1562 if Container
.Last
<= Index_Type
'First then
1566 -- The exception behavior for the vector container must match that
1567 -- for the list container, so we check for cursor tampering here
1568 -- (which will catch more things) instead of for element tampering
1569 -- (which will catch fewer things). It's true that the elements of
1570 -- this vector container could be safely moved around while (say) an
1571 -- iteration is taking place (iteration only increments the busy
1572 -- counter), and so technically all we would need here is a test for
1573 -- element tampering (indicated by the lock counter), that's simply
1574 -- an artifact of our array-based implementation. Logically Sort
1575 -- requires a check for cursor tampering.
1577 if Container
.Busy
> 0 then
1578 raise Program_Error
with
1579 "attempt to tamper with cursors (vector is busy)";
1582 -- Per AI05-0022, the container implementation is required to detect
1583 -- element tampering by a generic actual subprogram.
1586 B
: Natural renames Container
.Busy
;
1587 L
: Natural renames Container
.Lock
;
1593 Sort
(Container
.Elements
.EA
(Index_Type
'First .. Container
.Last
));
1606 end Generic_Sorting
;
1612 function Has_Element
(Position
: Cursor
) return Boolean is
1614 if Position
.Container
= null then
1617 return Position
.Index
<= Position
.Container
.Last
;
1626 (Container
: in out Vector
;
1627 Before
: Extended_Index
;
1628 New_Item
: Element_Type
;
1629 Count
: Count_Type
:= 1)
1631 Old_Length
: constant Count_Type
:= Container
.Length
;
1633 Max_Length
: Count_Type
'Base; -- determined from range of Index_Type
1634 New_Length
: Count_Type
'Base; -- sum of current length and Count
1635 New_Last
: Index_Type
'Base; -- last index of vector after insertion
1637 Index
: Index_Type
'Base; -- scratch for intermediate values
1638 J
: Count_Type
'Base; -- scratch
1640 New_Capacity
: Count_Type
'Base; -- length of new, expanded array
1641 Dst_Last
: Index_Type
'Base; -- last index of new, expanded array
1642 Dst
: Elements_Access
; -- new, expanded internal array
1645 -- As a precondition on the generic actual Index_Type, the base type
1646 -- must include Index_Type'Pred (Index_Type'First); this is the value
1647 -- that Container.Last assumes when the vector is empty. However, we do
1648 -- not allow that as the value for Index when specifying where the new
1649 -- items should be inserted, so we must manually check. (That the user
1650 -- is allowed to specify the value at all here is a consequence of the
1651 -- declaration of the Extended_Index subtype, which includes the values
1652 -- in the base range that immediately precede and immediately follow the
1653 -- values in the Index_Type.)
1655 if Before
< Index_Type
'First then
1656 raise Constraint_Error
with
1657 "Before index is out of range (too small)";
1660 -- We do allow a value greater than Container.Last to be specified as
1661 -- the Index, but only if it's immediately greater. This allows for the
1662 -- case of appending items to the back end of the vector. (It is assumed
1663 -- that specifying an index value greater than Last + 1 indicates some
1664 -- deeper flaw in the caller's algorithm, so that case is treated as a
1667 if Before
> Container
.Last
1668 and then Before
> Container
.Last
+ 1
1670 raise Constraint_Error
with
1671 "Before index is out of range (too large)";
1674 -- We treat inserting 0 items into the container as a no-op, even when
1675 -- the container is busy, so we simply return.
1681 -- There are two constraints we need to satisfy. The first constraint is
1682 -- that a container cannot have more than Count_Type'Last elements, so
1683 -- we must check the sum of the current length and the insertion count.
1684 -- Note that we cannot simply add these values, because of the
1685 -- possibility of overflow.
1687 if Old_Length
> Count_Type
'Last - Count
then
1688 raise Constraint_Error
with "Count is out of range";
1691 -- It is now safe compute the length of the new vector, without fear of
1694 New_Length
:= Old_Length
+ Count
;
1696 -- The second constraint is that the new Last index value cannot exceed
1697 -- Index_Type'Last. In each branch below, we calculate the maximum
1698 -- length (computed from the range of values in Index_Type), and then
1699 -- compare the new length to the maximum length. If the new length is
1700 -- acceptable, then we compute the new last index from that.
1702 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1704 -- We have to handle the case when there might be more values in the
1705 -- range of Index_Type than in the range of Count_Type.
1707 if Index_Type'First <= 0 then
1709 -- We know that No_Index (the same as Index_Type'First - 1) is
1710 -- less than 0, so it is safe to compute the following sum without
1711 -- fear of overflow.
1713 Index := No_Index + Index_Type'Base (Count_Type'Last);
1715 if Index <= Index_Type'Last then
1717 -- We have determined that range of Index_Type has at least as
1718 -- many values as in Count_Type, so Count_Type'Last is the
1719 -- maximum number of items that are allowed.
1721 Max_Length := Count_Type'Last;
1724 -- The range of Index_Type has fewer values than in Count_Type,
1725 -- so the maximum number of items is computed from the range of
1728 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1732 -- No_Index is equal or greater than 0, so we can safely compute
1733 -- the difference without fear of overflow (which we would have to
1734 -- worry about if No_Index were less than 0, but that case is
1737 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1740 elsif Index_Type'First <= 0 then
1742 -- We know that No_Index (the same as Index_Type'First - 1) is less
1743 -- than 0, so it is safe to compute the following sum without fear of
1746 J := Count_Type'Base (No_Index) + Count_Type'Last;
1748 if J <= Count_Type'Base (Index_Type'Last) then
1750 -- We have determined that range of Index_Type has at least as
1751 -- many values as in Count_Type, so Count_Type'Last is the maximum
1752 -- number of items that are allowed.
1754 Max_Length := Count_Type'Last;
1757 -- The range of Index_Type has fewer values than Count_Type does,
1758 -- so the maximum number of items is computed from the range of
1762 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1766 -- No_Index is equal or greater than 0, so we can safely compute the
1767 -- difference without fear of overflow (which we would have to worry
1768 -- about if No_Index were less than 0, but that case is handled
1772 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1775 -- We have just computed the maximum length (number of items). We must
1776 -- now compare the requested length to the maximum length, as we do not
1777 -- allow a vector expand beyond the maximum (because that would create
1778 -- an internal array with a last index value greater than
1779 -- Index_Type'Last, with no way to index those elements).
1781 if New_Length > Max_Length then
1782 raise Constraint_Error with "Count is out of range";
1785 -- New_Last is the last index value of the items in the container after
1786 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1787 -- compute its value from the New_Length.
1789 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1790 New_Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1792 New_Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1795 if Container
.Elements
= null then
1796 pragma Assert
(Container
.Last
= No_Index
);
1798 -- This is the simplest case, with which we must always begin: we're
1799 -- inserting items into an empty vector that hasn't allocated an
1800 -- internal array yet. Note that we don't need to check the busy bit
1801 -- here, because an empty container cannot be busy.
1803 -- In an indefinite vector, elements are allocated individually, and
1804 -- stored as access values on the internal array (the length of which
1805 -- represents the vector "capacity"), which is separately allocated.
1807 Container
.Elements
:= new Elements_Type
(New_Last
);
1809 -- The element backbone has been successfully allocated, so now we
1810 -- allocate the elements.
1812 for Idx
in Container
.Elements
.EA
'Range loop
1814 -- In order to preserve container invariants, we always attempt
1815 -- the element allocation first, before setting the Last index
1816 -- value, in case the allocation fails (either because there is no
1817 -- storage available, or because element initialization fails).
1820 -- The element allocator may need an accessibility check in the
1821 -- case actual type is class-wide or has access discriminants
1822 -- (see RM 4.8(10.1) and AI12-0035).
1824 pragma Unsuppress
(Accessibility_Check
);
1827 Container
.Elements
.EA
(Idx
) := new Element_Type
'(New_Item);
1830 -- The allocation of the element succeeded, so it is now safe to
1831 -- update the Last index, restoring container invariants.
1833 Container.Last := Idx;
1839 -- The tampering bits exist to prevent an item from being harmfully
1840 -- manipulated while it is being visited. Query, Update, and Iterate
1841 -- increment the busy count on entry, and decrement the count on
1842 -- exit. Insert checks the count to determine whether it is being called
1843 -- while the associated callback procedure is executing.
1845 if Container.Busy > 0 then
1846 raise Program_Error with
1847 "attempt to tamper with cursors (vector is busy)";
1850 if New_Length <= Container.Elements.EA'Length then
1852 -- In this case, we're inserting elements into a vector that has
1853 -- already allocated an internal array, and the existing array has
1854 -- enough unused storage for the new items.
1857 E : Elements_Array renames Container.Elements.EA;
1858 K : Index_Type'Base;
1861 if Before > Container.Last then
1863 -- The new items are being appended to the vector, so no
1864 -- sliding of existing elements is required.
1866 for Idx in Before .. New_Last loop
1868 -- In order to preserve container invariants, we always
1869 -- attempt the element allocation first, before setting the
1870 -- Last index value, in case the allocation fails (either
1871 -- because there is no storage available, or because element
1872 -- initialization fails).
1875 -- The element allocator may need an accessibility check
1876 -- in case the actual type is class-wide or has access
1877 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1879 pragma Unsuppress (Accessibility_Check);
1882 E (Idx) := new Element_Type'(New_Item
);
1885 -- The allocation of the element succeeded, so it is now
1886 -- safe to update the Last index, restoring container
1889 Container
.Last
:= Idx
;
1893 -- The new items are being inserted before some existing
1894 -- elements, so we must slide the existing elements up to their
1895 -- new home. We use the wider of Index_Type'Base and
1896 -- Count_Type'Base as the type for intermediate index values.
1898 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1899 Index := Before + Index_Type'Base (Count);
1901 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1904 -- The new items are being inserted in the middle of the array,
1905 -- in the range [Before, Index). Copy the existing elements to
1906 -- the end of the array, to make room for the new items.
1908 E (Index .. New_Last) := E (Before .. Container.Last);
1909 Container.Last := New_Last;
1911 -- We have copied the existing items up to the end of the
1912 -- array, to make room for the new items in the middle of
1913 -- the array. Now we actually allocate the new items.
1915 -- Note: initialize K outside loop to make it clear that
1916 -- K always has a value if the exception handler triggers.
1921 -- The element allocator may need an accessibility check in
1922 -- the case the actual type is class-wide or has access
1923 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1925 pragma Unsuppress (Accessibility_Check);
1928 while K < Index loop
1929 E (K) := new Element_Type'(New_Item
);
1936 -- Values in the range [Before, K) were successfully
1937 -- allocated, but values in the range [K, Index) are
1938 -- stale (these array positions contain copies of the
1939 -- old items, that did not get assigned a new item,
1940 -- because the allocation failed). We must finish what
1941 -- we started by clearing out all of the stale values,
1942 -- leaving a "hole" in the middle of the array.
1944 E
(K
.. Index
- 1) := (others => null);
1953 -- In this case, we're inserting elements into a vector that has already
1954 -- allocated an internal array, but the existing array does not have
1955 -- enough storage, so we must allocate a new, longer array. In order to
1956 -- guarantee that the amortized insertion cost is O(1), we always
1957 -- allocate an array whose length is some power-of-two factor of the
1958 -- current array length. (The new array cannot have a length less than
1959 -- the New_Length of the container, but its last index value cannot be
1960 -- greater than Index_Type'Last.)
1962 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
1963 while New_Capacity
< New_Length
loop
1964 if New_Capacity
> Count_Type
'Last / 2 then
1965 New_Capacity
:= Count_Type
'Last;
1969 New_Capacity
:= 2 * New_Capacity
;
1972 if New_Capacity
> Max_Length
then
1974 -- We have reached the limit of capacity, so no further expansion
1975 -- will occur. (This is not a problem, as there is never a need to
1976 -- have more capacity than the maximum container length.)
1978 New_Capacity
:= Max_Length
;
1981 -- We have computed the length of the new internal array (and this is
1982 -- what "vector capacity" means), so use that to compute its last index.
1984 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1985 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1988 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1991 -- Now we allocate the new, longer internal array. If the allocation
1992 -- fails, we have not changed any container state, so no side-effect
1993 -- will occur as a result of propagating the exception.
1995 Dst := new Elements_Type (Dst_Last);
1997 -- We have our new internal array. All that needs to be done now is to
1998 -- copy the existing items (if any) from the old array (the "source"
1999 -- array) to the new array (the "destination" array), and then
2000 -- deallocate the old array.
2003 Src : Elements_Access := Container.Elements;
2006 Dst.EA (Index_Type'First .. Before - 1) :=
2007 Src.EA (Index_Type'First .. Before - 1);
2009 if Before > Container.Last then
2011 -- The new items are being appended to the vector, so no
2012 -- sliding of existing elements is required.
2014 -- We have copied the elements from to the old source array to the
2015 -- new destination array, so we can now deallocate the old array.
2017 Container.Elements := Dst;
2020 -- Now we append the new items.
2022 for Idx in Before .. New_Last loop
2024 -- In order to preserve container invariants, we always attempt
2025 -- the element allocation first, before setting the Last index
2026 -- value, in case the allocation fails (either because there
2027 -- is no storage available, or because element initialization
2031 -- The element allocator may need an accessibility check in
2032 -- the case the actual type is class-wide or has access
2033 -- discriminants (see RM 4.8(10.1) and AI12-0035).
2035 pragma Unsuppress (Accessibility_Check);
2038 Dst.EA (Idx) := new Element_Type'(New_Item
);
2041 -- The allocation of the element succeeded, so it is now safe
2042 -- to update the Last index, restoring container invariants.
2044 Container
.Last
:= Idx
;
2048 -- The new items are being inserted before some existing elements,
2049 -- so we must slide the existing elements up to their new home.
2051 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2052 Index := Before + Index_Type'Base (Count);
2054 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2057 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
2059 -- We have copied the elements from to the old source array to the
2060 -- new destination array, so we can now deallocate the old array.
2062 Container.Elements := Dst;
2063 Container.Last := New_Last;
2066 -- The new array has a range in the middle containing null access
2067 -- values. Fill in that partition of the array with the new items.
2069 for Idx in Before .. Index - 1 loop
2071 -- Note that container invariants have already been satisfied
2072 -- (in particular, the Last index value of the vector has
2073 -- already been updated), so if this allocation fails we simply
2074 -- let it propagate.
2077 -- The element allocator may need an accessibility check in
2078 -- the case the actual type is class-wide or has access
2079 -- discriminants (see RM 4.8(10.1) and AI12-0035).
2081 pragma Unsuppress (Accessibility_Check);
2084 Dst.EA (Idx) := new Element_Type'(New_Item
);
2092 (Container
: in out Vector
;
2093 Before
: Extended_Index
;
2096 N
: constant Count_Type
:= Length
(New_Item
);
2097 J
: Index_Type
'Base;
2100 -- Use Insert_Space to create the "hole" (the destination slice) into
2101 -- which we copy the source items.
2103 Insert_Space
(Container
, Before
, Count
=> N
);
2107 -- There's nothing else to do here (vetting of parameters was
2108 -- performed already in Insert_Space), so we simply return.
2113 if Container
'Address /= New_Item
'Address then
2115 -- This is the simple case. New_Item denotes an object different
2116 -- from Container, so there's nothing special we need to do to copy
2117 -- the source items to their destination, because all of the source
2118 -- items are contiguous.
2121 subtype Src_Index_Subtype
is Index_Type
'Base range
2122 Index_Type
'First .. New_Item
.Last
;
2124 Src
: Elements_Array
renames
2125 New_Item
.Elements
.EA
(Src_Index_Subtype
);
2127 Dst
: Elements_Array
renames Container
.Elements
.EA
;
2129 Dst_Index
: Index_Type
'Base;
2132 Dst_Index
:= Before
- 1;
2133 for Src_Index
in Src
'Range loop
2134 Dst_Index
:= Dst_Index
+ 1;
2136 if Src
(Src_Index
) /= null then
2137 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
2145 -- New_Item denotes the same object as Container, so an insertion has
2146 -- potentially split the source items. The first source slice is
2147 -- [Index_Type'First, Before), and the second source slice is
2148 -- [J, Container.Last], where index value J is the first index of the
2149 -- second slice. (J gets computed below, but only after we have
2150 -- determined that the second source slice is non-empty.) The
2151 -- destination slice is always the range [Before, J). We perform the
2152 -- copy in two steps, using each of the two slices of the source items.
2155 L : constant Index_Type'Base := Before - 1;
2157 subtype Src_Index_Subtype is Index_Type'Base range
2158 Index_Type'First .. L;
2160 Src : Elements_Array renames
2161 Container.Elements.EA (Src_Index_Subtype);
2163 Dst : Elements_Array renames Container.Elements.EA;
2165 Dst_Index : Index_Type'Base;
2168 -- We first copy the source items that precede the space we
2169 -- inserted. (If Before equals Index_Type'First, then this first
2170 -- source slice will be empty, which is harmless.)
2172 Dst_Index := Before - 1;
2173 for Src_Index in Src'Range loop
2174 Dst_Index := Dst_Index + 1;
2176 if Src (Src_Index) /= null then
2177 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
2181 if Src
'Length = N
then
2183 -- The new items were effectively appended to the container, so we
2184 -- have already copied all of the items that need to be copied.
2185 -- We return early here, even though the source slice below is
2186 -- empty (so the assignment would be harmless), because we want to
2187 -- avoid computing J, which will overflow if J is greater than
2188 -- Index_Type'Base'Last.
2194 -- Index value J is the first index of the second source slice. (It is
2195 -- also 1 greater than the last index of the destination slice.) Note:
2196 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
2197 -- to avoid overflow. Prevent that by returning early above, immediately
2198 -- after copying the first slice of the source, and determining that
2199 -- this second slice of the source is empty.
2201 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2202 J := Before + Index_Type'Base (N);
2204 J := Index_Type'Base (Count_Type'Base (Before) + N);
2208 subtype Src_Index_Subtype is Index_Type'Base range
2209 J .. Container.Last;
2211 Src : Elements_Array renames
2212 Container.Elements.EA (Src_Index_Subtype);
2214 Dst : Elements_Array renames Container.Elements.EA;
2216 Dst_Index : Index_Type'Base;
2219 -- We next copy the source items that follow the space we inserted.
2220 -- Index value Dst_Index is the first index of that portion of the
2221 -- destination that receives this slice of the source. (For the
2222 -- reasons given above, this slice is guaranteed to be non-empty.)
2224 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2225 Dst_Index
:= J
- Index_Type
'Base (Src
'Length);
2227 Dst_Index
:= Index_Type
'Base (Count_Type
'Base (J
) - Src
'Length);
2230 for Src_Index
in Src
'Range loop
2231 if Src
(Src_Index
) /= null then
2232 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
2235 Dst_Index := Dst_Index + 1;
2241 (Container : in out Vector;
2245 Index : Index_Type'Base;
2248 if Before.Container /= null
2249 and then Before.Container /= Container'Unrestricted_Access
2251 raise Program_Error with "Before cursor denotes wrong container";
2254 if Is_Empty (New_Item) then
2258 if Before.Container = null or else Before.Index > Container.Last then
2259 if Container.Last = Index_Type'Last then
2260 raise Constraint_Error with
2261 "vector is already at its maximum length";
2264 Index := Container.Last + 1;
2267 Index := Before.Index;
2270 Insert (Container, Index, New_Item);
2274 (Container : in out Vector;
2277 Position : out Cursor)
2279 Index : Index_Type'Base;
2282 if Before.Container /= null
2283 and then Before.Container /=
2284 Vector_Access'(Container
'Unrestricted_Access)
2286 raise Program_Error
with "Before cursor denotes wrong container";
2289 if Is_Empty
(New_Item
) then
2290 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2291 Position
:= No_Element
;
2293 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2299 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2300 if Container
.Last
= Index_Type
'Last then
2301 raise Constraint_Error
with
2302 "vector is already at its maximum length";
2305 Index
:= Container
.Last
+ 1;
2308 Index
:= Before
.Index
;
2311 Insert
(Container
, Index
, New_Item
);
2313 Position
:= Cursor
'(Container'Unrestricted_Access, Index);
2317 (Container : in out Vector;
2319 New_Item : Element_Type;
2320 Count : Count_Type := 1)
2322 Index : Index_Type'Base;
2325 if Before.Container /= null
2326 and then Before.Container /= Container'Unrestricted_Access
2328 raise Program_Error with "Before cursor denotes wrong container";
2335 if Before.Container = null or else Before.Index > Container.Last then
2336 if Container.Last = Index_Type'Last then
2337 raise Constraint_Error with
2338 "vector is already at its maximum length";
2341 Index := Container.Last + 1;
2344 Index := Before.Index;
2347 Insert (Container, Index, New_Item, Count);
2351 (Container : in out Vector;
2353 New_Item : Element_Type;
2354 Position : out Cursor;
2355 Count : Count_Type := 1)
2357 Index : Index_Type'Base;
2360 if Before.Container /= null
2361 and then Before.Container /= Container'Unrestricted_Access
2363 raise Program_Error with "Before cursor denotes wrong container";
2367 if Before.Container = null
2368 or else Before.Index > Container.Last
2370 Position := No_Element;
2372 Position := (Container'Unrestricted_Access, Before.Index);
2378 if Before.Container = null or else Before.Index > Container.Last then
2379 if Container.Last = Index_Type'Last then
2380 raise Constraint_Error with
2381 "vector is already at its maximum length";
2384 Index := Container.Last + 1;
2387 Index := Before.Index;
2390 Insert (Container, Index, New_Item, Count);
2392 Position := (Container'Unrestricted_Access, Index);
2399 procedure Insert_Space
2400 (Container : in out Vector;
2401 Before : Extended_Index;
2402 Count : Count_Type := 1)
2404 Old_Length : constant Count_Type := Container.Length;
2406 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2407 New_Length : Count_Type'Base; -- sum of current length and Count
2408 New_Last : Index_Type'Base; -- last index of vector after insertion
2410 Index : Index_Type'Base; -- scratch for intermediate values
2411 J : Count_Type'Base; -- scratch
2413 New_Capacity : Count_Type'Base; -- length of new, expanded array
2414 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2415 Dst : Elements_Access; -- new, expanded internal array
2418 -- As a precondition on the generic actual Index_Type, the base type
2419 -- must include Index_Type'Pred (Index_Type'First); this is the value
2420 -- that Container.Last assumes when the vector is empty. However, we do
2421 -- not allow that as the value for Index when specifying where the new
2422 -- items should be inserted, so we must manually check. (That the user
2423 -- is allowed to specify the value at all here is a consequence of the
2424 -- declaration of the Extended_Index subtype, which includes the values
2425 -- in the base range that immediately precede and immediately follow the
2426 -- values in the Index_Type.)
2428 if Before < Index_Type'First then
2429 raise Constraint_Error with
2430 "Before index is out of range (too small)";
2433 -- We do allow a value greater than Container.Last to be specified as
2434 -- the Index, but only if it's immediately greater. This allows for the
2435 -- case of appending items to the back end of the vector. (It is assumed
2436 -- that specifying an index value greater than Last + 1 indicates some
2437 -- deeper flaw in the caller's algorithm, so that case is treated as a
2440 if Before > Container.Last and then Before > Container.Last + 1 then
2441 raise Constraint_Error with
2442 "Before index is out of range (too large)";
2445 -- We treat inserting 0 items into the container as a no-op, even when
2446 -- the container is busy, so we simply return.
2452 -- There are two constraints we need to satisfy. The first constraint is
2453 -- that a container cannot have more than Count_Type'Last elements, so
2454 -- we must check the sum of the current length and the insertion
2455 -- count. Note that we cannot simply add these values, because of the
2456 -- possibility of overflow.
2458 if Old_Length > Count_Type'Last - Count then
2459 raise Constraint_Error with "Count is out of range";
2462 -- It is now safe compute the length of the new vector, without fear of
2465 New_Length := Old_Length + Count;
2467 -- The second constraint is that the new Last index value cannot exceed
2468 -- Index_Type'Last. In each branch below, we calculate the maximum
2469 -- length (computed from the range of values in Index_Type), and then
2470 -- compare the new length to the maximum length. If the new length is
2471 -- acceptable, then we compute the new last index from that.
2473 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2474 -- We have to handle the case when there might be more values in the
2475 -- range of Index_Type than in the range of Count_Type.
2477 if Index_Type
'First <= 0 then
2479 -- We know that No_Index (the same as Index_Type'First - 1) is
2480 -- less than 0, so it is safe to compute the following sum without
2481 -- fear of overflow.
2483 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
2485 if Index
<= Index_Type
'Last then
2487 -- We have determined that range of Index_Type has at least as
2488 -- many values as in Count_Type, so Count_Type'Last is the
2489 -- maximum number of items that are allowed.
2491 Max_Length
:= Count_Type
'Last;
2494 -- The range of Index_Type has fewer values than in Count_Type,
2495 -- so the maximum number of items is computed from the range of
2498 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2502 -- No_Index is equal or greater than 0, so we can safely compute
2503 -- the difference without fear of overflow (which we would have to
2504 -- worry about if No_Index were less than 0, but that case is
2507 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2510 elsif Index_Type
'First <= 0 then
2512 -- We know that No_Index (the same as Index_Type'First - 1) is less
2513 -- than 0, so it is safe to compute the following sum without fear of
2516 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
2518 if J
<= Count_Type
'Base (Index_Type
'Last) then
2520 -- We have determined that range of Index_Type has at least as
2521 -- many values as in Count_Type, so Count_Type'Last is the maximum
2522 -- number of items that are allowed.
2524 Max_Length
:= Count_Type
'Last;
2527 -- The range of Index_Type has fewer values than Count_Type does,
2528 -- so the maximum number of items is computed from the range of
2532 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2536 -- No_Index is equal or greater than 0, so we can safely compute the
2537 -- difference without fear of overflow (which we would have to worry
2538 -- about if No_Index were less than 0, but that case is handled
2542 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2545 -- We have just computed the maximum length (number of items). We must
2546 -- now compare the requested length to the maximum length, as we do not
2547 -- allow a vector expand beyond the maximum (because that would create
2548 -- an internal array with a last index value greater than
2549 -- Index_Type'Last, with no way to index those elements).
2551 if New_Length
> Max_Length
then
2552 raise Constraint_Error
with "Count is out of range";
2555 -- New_Last is the last index value of the items in the container after
2556 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2557 -- compute its value from the New_Length.
2559 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2560 New_Last := No_Index + Index_Type'Base (New_Length);
2562 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2565 if Container.Elements = null then
2566 pragma Assert (Container.Last = No_Index);
2568 -- This is the simplest case, with which we must always begin: we're
2569 -- inserting items into an empty vector that hasn't allocated an
2570 -- internal array yet. Note that we don't need to check the busy bit
2571 -- here, because an empty container cannot be busy.
2573 -- In an indefinite vector, elements are allocated individually, and
2574 -- stored as access values on the internal array (the length of which
2575 -- represents the vector "capacity"), which is separately allocated.
2576 -- We have no elements here (because we're inserting "space"), so all
2577 -- we need to do is allocate the backbone.
2579 Container.Elements := new Elements_Type (New_Last);
2580 Container.Last := New_Last;
2585 -- The tampering bits exist to prevent an item from being harmfully
2586 -- manipulated while it is being visited. Query, Update, and Iterate
2587 -- increment the busy count on entry, and decrement the count on exit.
2588 -- Insert checks the count to determine whether it is being called while
2589 -- the associated callback procedure is executing.
2591 if Container.Busy > 0 then
2592 raise Program_Error with
2593 "attempt to tamper with cursors (vector is busy)";
2596 if New_Length <= Container.Elements.EA'Length then
2598 -- In this case, we are inserting elements into a vector that has
2599 -- already allocated an internal array, and the existing array has
2600 -- enough unused storage for the new items.
2603 E : Elements_Array renames Container.Elements.EA;
2606 if Before <= Container.Last then
2608 -- The new space is being inserted before some existing
2609 -- elements, so we must slide the existing elements up to
2610 -- their new home. We use the wider of Index_Type'Base and
2611 -- Count_Type'Base as the type for intermediate index values.
2613 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2614 Index
:= Before
+ Index_Type
'Base (Count
);
2616 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2619 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
2620 E
(Before
.. Index
- 1) := (others => null);
2624 Container
.Last
:= New_Last
;
2628 -- In this case, we're inserting elements into a vector that has already
2629 -- allocated an internal array, but the existing array does not have
2630 -- enough storage, so we must allocate a new, longer array. In order to
2631 -- guarantee that the amortized insertion cost is O(1), we always
2632 -- allocate an array whose length is some power-of-two factor of the
2633 -- current array length. (The new array cannot have a length less than
2634 -- the New_Length of the container, but its last index value cannot be
2635 -- greater than Index_Type'Last.)
2637 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
2638 while New_Capacity
< New_Length
loop
2639 if New_Capacity
> Count_Type
'Last / 2 then
2640 New_Capacity
:= Count_Type
'Last;
2644 New_Capacity
:= 2 * New_Capacity
;
2647 if New_Capacity
> Max_Length
then
2649 -- We have reached the limit of capacity, so no further expansion
2650 -- will occur. (This is not a problem, as there is never a need to
2651 -- have more capacity than the maximum container length.)
2653 New_Capacity
:= Max_Length
;
2656 -- We have computed the length of the new internal array (and this is
2657 -- what "vector capacity" means), so use that to compute its last index.
2659 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2660 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2663 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2666 -- Now we allocate the new, longer internal array. If the allocation
2667 -- fails, we have not changed any container state, so no side-effect
2668 -- will occur as a result of propagating the exception.
2670 Dst := new Elements_Type (Dst_Last);
2672 -- We have our new internal array. All that needs to be done now is to
2673 -- copy the existing items (if any) from the old array (the "source"
2674 -- array) to the new array (the "destination" array), and then
2675 -- deallocate the old array.
2678 Src : Elements_Access := Container.Elements;
2681 Dst.EA (Index_Type'First .. Before - 1) :=
2682 Src.EA (Index_Type'First .. Before - 1);
2684 if Before <= Container.Last then
2686 -- The new items are being inserted before some existing elements,
2687 -- so we must slide the existing elements up to their new home.
2689 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2690 Index
:= Before
+ Index_Type
'Base (Count
);
2692 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2695 Dst
.EA
(Index
.. New_Last
) := Src
.EA
(Before
.. Container
.Last
);
2698 -- We have copied the elements from to the old, source array to the
2699 -- new, destination array, so we can now restore invariants, and
2700 -- deallocate the old array.
2702 Container
.Elements
:= Dst
;
2703 Container
.Last
:= New_Last
;
2708 procedure Insert_Space
2709 (Container
: in out Vector
;
2711 Position
: out Cursor
;
2712 Count
: Count_Type
:= 1)
2714 Index
: Index_Type
'Base;
2717 if Before
.Container
/= null
2718 and then Before
.Container
/= Container
'Unrestricted_Access
2720 raise Program_Error
with "Before cursor denotes wrong container";
2724 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2725 Position
:= No_Element
;
2727 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2733 if Before
.Container
= null
2734 or else Before
.Index
> Container
.Last
2736 if Container
.Last
= Index_Type
'Last then
2737 raise Constraint_Error
with
2738 "vector is already at its maximum length";
2741 Index
:= Container
.Last
+ 1;
2744 Index
:= Before
.Index
;
2747 Insert_Space
(Container
, Index
, Count
);
2749 Position
:= Cursor
'(Container'Unrestricted_Access, Index);
2756 function Is_Empty (Container : Vector) return Boolean is
2758 return Container.Last < Index_Type'First;
2766 (Container : Vector;
2767 Process : not null access procedure (Position : Cursor))
2769 B : Natural renames Container'Unrestricted_Access.all.Busy;
2775 for Indx in Index_Type'First .. Container.Last loop
2776 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
2787 function Iterate
(Container
: Vector
)
2788 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
2790 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
2791 B
: Natural renames V
.Busy
;
2794 -- The value of its Index component influences the behavior of the First
2795 -- and Last selector functions of the iterator object. When the Index
2796 -- component is No_Index (as is the case here), this means the iterator
2797 -- object was constructed without a start expression. This is a complete
2798 -- iterator, meaning that the iteration starts from the (logical)
2799 -- beginning of the sequence of items.
2801 -- Note: For a forward iterator, Container.First is the beginning, and
2802 -- for a reverse iterator, Container.Last is the beginning.
2804 return It
: constant Iterator
:=
2805 (Limited_Controlled
with
2814 (Container
: Vector
;
2816 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
2818 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
2819 B
: Natural renames V
.Busy
;
2822 -- It was formerly the case that when Start = No_Element, the partial
2823 -- iterator was defined to behave the same as for a complete iterator,
2824 -- and iterate over the entire sequence of items. However, those
2825 -- semantics were unintuitive and arguably error-prone (it is too easy
2826 -- to accidentally create an endless loop), and so they were changed,
2827 -- per the ARG meeting in Denver on 2011/11. However, there was no
2828 -- consensus about what positive meaning this corner case should have,
2829 -- and so it was decided to simply raise an exception. This does imply,
2830 -- however, that it is not possible to use a partial iterator to specify
2831 -- an empty sequence of items.
2833 if Start
.Container
= null then
2834 raise Constraint_Error
with
2835 "Start position for iterator equals No_Element";
2838 if Start
.Container
/= V
then
2839 raise Program_Error
with
2840 "Start cursor of Iterate designates wrong vector";
2843 if Start
.Index
> V
.Last
then
2844 raise Constraint_Error
with
2845 "Start position for iterator equals No_Element";
2848 -- The value of its Index component influences the behavior of the First
2849 -- and Last selector functions of the iterator object. When the Index
2850 -- component is not No_Index (as is the case here), it means that this
2851 -- is a partial iteration, over a subset of the complete sequence of
2852 -- items. The iterator object was constructed with a start expression,
2853 -- indicating the position from which the iteration begins. Note that
2854 -- the start position has the same value irrespective of whether this
2855 -- is a forward or reverse iteration.
2857 return It
: constant Iterator
:=
2858 (Limited_Controlled
with
2860 Index
=> Start
.Index
)
2870 function Last
(Container
: Vector
) return Cursor
is
2872 if Is_Empty
(Container
) then
2876 return (Container
'Unrestricted_Access, Container
.Last
);
2879 function Last
(Object
: Iterator
) return Cursor
is
2881 -- The value of the iterator object's Index component influences the
2882 -- behavior of the Last (and First) selector function.
2884 -- When the Index component is No_Index, this means the iterator
2885 -- object was constructed without a start expression, in which case the
2886 -- (reverse) iteration starts from the (logical) beginning of the entire
2887 -- sequence (corresponding to Container.Last, for a reverse iterator).
2889 -- Otherwise, this is iteration over a partial sequence of items.
2890 -- When the Index component is not No_Index, the iterator object was
2891 -- constructed with a start expression, that specifies the position
2892 -- from which the (reverse) partial iteration begins.
2894 if Object
.Index
= No_Index
then
2895 return Last
(Object
.Container
.all);
2897 return Cursor
'(Object.Container, Object.Index);
2905 function Last_Element (Container : Vector) return Element_Type is
2907 if Container.Last = No_Index then
2908 raise Constraint_Error with "Container is empty";
2912 EA : constant Element_Access :=
2913 Container.Elements.EA (Container.Last);
2916 raise Constraint_Error with "last element is empty";
2927 function Last_Index (Container : Vector) return Extended_Index is
2929 return Container.Last;
2936 function Length (Container : Vector) return Count_Type is
2937 L : constant Index_Type'Base := Container.Last;
2938 F : constant Index_Type := Index_Type'First;
2941 -- The base range of the index type (Index_Type'Base) might not include
2942 -- all values for length (Count_Type). Contrariwise, the index type
2943 -- might include values outside the range of length. Hence we use
2944 -- whatever type is wider for intermediate values when calculating
2945 -- length. Note that no matter what the index type is, the maximum
2946 -- length to which a vector is allowed to grow is always the minimum
2947 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2949 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2950 -- to have a base range of -128 .. 127, but the corresponding vector
2951 -- would have lengths in the range 0 .. 255. In this case we would need
2952 -- to use Count_Type'Base for intermediate values.
2954 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2955 -- vector would have a maximum length of 10, but the index values lie
2956 -- outside the range of Count_Type (which is only 32 bits). In this
2957 -- case we would need to use Index_Type'Base for intermediate values.
2959 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
2960 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2962 return Count_Type (L - F + 1);
2971 (Target : in out Vector;
2972 Source : in out Vector)
2975 if Target'Address = Source'Address then
2979 if Source.Busy > 0 then
2980 raise Program_Error with
2981 "attempt to tamper with cursors (Source is busy)";
2984 Clear (Target); -- Checks busy-bit
2987 Target_Elements : constant Elements_Access := Target.Elements;
2989 Target.Elements := Source.Elements;
2990 Source.Elements := Target_Elements;
2993 Target.Last := Source.Last;
2994 Source.Last := No_Index;
3001 function Next (Position : Cursor) return Cursor is
3003 if Position.Container = null then
3005 elsif Position.Index < Position.Container.Last then
3006 return (Position.Container, Position.Index + 1);
3012 function Next (Object : Iterator; Position : Cursor) return Cursor is
3014 if Position.Container = null then
3016 elsif Position.Container /= Object.Container then
3017 raise Program_Error with
3018 "Position cursor of Next designates wrong vector";
3020 return Next (Position);
3024 procedure Next (Position : in out Cursor) is
3026 if Position.Container = null then
3028 elsif Position.Index < Position.Container.Last then
3029 Position.Index := Position.Index + 1;
3031 Position := No_Element;
3039 procedure Prepend (Container : in out Vector; New_Item : Vector) is
3041 Insert (Container, Index_Type'First, New_Item);
3045 (Container : in out Vector;
3046 New_Item : Element_Type;
3047 Count : Count_Type := 1)
3050 Insert (Container, Index_Type'First, New_Item, Count);
3057 procedure Previous (Position : in out Cursor) is
3059 if Position.Container = null then
3061 elsif Position.Index > Index_Type'First then
3062 Position.Index := Position.Index - 1;
3064 Position := No_Element;
3068 function Previous (Position : Cursor) return Cursor is
3070 if Position.Container = null then
3072 elsif Position.Index > Index_Type'First then
3073 return (Position.Container, Position.Index - 1);
3079 function Previous (Object : Iterator; Position : Cursor) return Cursor is
3081 if Position.Container = null then
3083 elsif Position.Container /= Object.Container then
3084 raise Program_Error with
3085 "Position cursor of Previous designates wrong vector";
3087 return Previous (Position);
3095 procedure Query_Element
3096 (Container : Vector;
3098 Process : not null access procedure (Element : Element_Type))
3100 V : Vector renames Container'Unrestricted_Access.all;
3101 B : Natural renames V.Busy;
3102 L : Natural renames V.Lock;
3105 if Index > Container.Last then
3106 raise Constraint_Error with "Index is out of range";
3109 if V.Elements.EA (Index) = null then
3110 raise Constraint_Error with "element is null";
3117 Process (V.Elements.EA (Index).all);
3129 procedure Query_Element
3131 Process : not null access procedure (Element : Element_Type))
3134 if Position.Container = null then
3135 raise Constraint_Error with "Position cursor has no element";
3137 Query_Element (Position.Container.all, Position.Index, Process);
3146 (Stream : not null access Root_Stream_Type'Class;
3147 Container : out Vector)
3149 Length : Count_Type'Base;
3150 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
3156 Count_Type'Base'Read
(Stream
, Length
);
3158 if Length
> Capacity
(Container
) then
3159 Reserve_Capacity
(Container
, Capacity
=> Length
);
3162 for J
in Count_Type
range 1 .. Length
loop
3165 Boolean'Read (Stream
, B
);
3168 Container
.Elements
.EA
(Last
) :=
3169 new Element_Type
'(Element_Type'Input (Stream));
3172 Container.Last := Last;
3177 (Stream : not null access Root_Stream_Type'Class;
3178 Position : out Cursor)
3181 raise Program_Error with "attempt to stream vector cursor";
3185 (Stream : not null access Root_Stream_Type'Class;
3186 Item : out Reference_Type)
3189 raise Program_Error with "attempt to stream reference";
3193 (Stream : not null access Root_Stream_Type'Class;
3194 Item : out Constant_Reference_Type)
3197 raise Program_Error with "attempt to stream reference";
3205 (Container : aliased in out Vector;
3206 Position : Cursor) return Reference_Type
3211 if Position.Container = null then
3212 raise Constraint_Error with "Position cursor has no element";
3215 if Position.Container /= Container'Unrestricted_Access then
3216 raise Program_Error with "Position cursor denotes wrong container";
3219 if Position.Index > Position.Container.Last then
3220 raise Constraint_Error with "Position cursor is out of range";
3223 E := Container.Elements.EA (Position.Index);
3226 raise Constraint_Error with "element at Position is empty";
3230 C : Vector renames Container'Unrestricted_Access.all;
3231 B : Natural renames C.Busy;
3232 L : Natural renames C.Lock;
3234 return R : constant Reference_Type :=
3235 (Element => E.all'Access,
3236 Control => (Controlled with Position.Container))
3245 (Container : aliased in out Vector;
3246 Index : Index_Type) return Reference_Type
3251 if Index > Container.Last then
3252 raise Constraint_Error with "Index is out of range";
3255 E := Container.Elements.EA (Index);
3258 raise Constraint_Error with "element at Index is empty";
3262 C : Vector renames Container'Unrestricted_Access.all;
3263 B : Natural renames C.Busy;
3264 L : Natural renames C.Lock;
3266 return R : constant Reference_Type :=
3267 (Element => E.all'Access,
3268 Control => (Controlled with Container'Unrestricted_Access))
3276 ---------------------
3277 -- Replace_Element --
3278 ---------------------
3280 procedure Replace_Element
3281 (Container : in out Vector;
3283 New_Item : Element_Type)
3286 if Index > Container.Last then
3287 raise Constraint_Error with "Index is out of range";
3290 if Container.Lock > 0 then
3291 raise Program_Error with
3292 "attempt to tamper with elements (vector is locked)";
3296 X : Element_Access := Container.Elements.EA (Index);
3298 -- The element allocator may need an accessibility check in the case
3299 -- where the actual type is class-wide or has access discriminants
3300 -- (see RM 4.8(10.1) and AI12-0035).
3302 pragma Unsuppress (Accessibility_Check);
3305 Container.Elements.EA (Index) := new Element_Type'(New_Item
);
3308 end Replace_Element
;
3310 procedure Replace_Element
3311 (Container
: in out Vector
;
3313 New_Item
: Element_Type
)
3316 if Position
.Container
= null then
3317 raise Constraint_Error
with "Position cursor has no element";
3320 if Position
.Container
/= Container
'Unrestricted_Access then
3321 raise Program_Error
with "Position cursor denotes wrong container";
3324 if Position
.Index
> Container
.Last
then
3325 raise Constraint_Error
with "Position cursor is out of range";
3328 if Container
.Lock
> 0 then
3329 raise Program_Error
with
3330 "attempt to tamper with elements (vector is locked)";
3334 X
: Element_Access
:= Container
.Elements
.EA
(Position
.Index
);
3336 -- The element allocator may need an accessibility check in the case
3337 -- where the actual type is class-wide or has access discriminants
3338 -- (see RM 4.8(10.1) and AI12-0035).
3340 pragma Unsuppress
(Accessibility_Check
);
3343 Container
.Elements
.EA
(Position
.Index
) := new Element_Type
'(New_Item);
3346 end Replace_Element;
3348 ----------------------
3349 -- Reserve_Capacity --
3350 ----------------------
3352 procedure Reserve_Capacity
3353 (Container : in out Vector;
3354 Capacity : Count_Type)
3356 N : constant Count_Type := Length (Container);
3358 Index : Count_Type'Base;
3359 Last : Index_Type'Base;
3362 -- Reserve_Capacity can be used to either expand the storage available
3363 -- for elements (this would be its typical use, in anticipation of
3364 -- future insertion), or to trim back storage. In the latter case,
3365 -- storage can only be trimmed back to the limit of the container
3366 -- length. Note that Reserve_Capacity neither deletes (active) elements
3367 -- nor inserts elements; it only affects container capacity, never
3368 -- container length.
3370 if Capacity = 0 then
3372 -- This is a request to trim back storage, to the minimum amount
3373 -- possible given the current state of the container.
3377 -- The container is empty, so in this unique case we can
3378 -- deallocate the entire internal array. Note that an empty
3379 -- container can never be busy, so there's no need to check the
3383 X : Elements_Access := Container.Elements;
3386 -- First we remove the internal array from the container, to
3387 -- handle the case when the deallocation raises an exception
3388 -- (although that's unlikely, since this is simply an array of
3389 -- access values, all of which are null).
3391 Container.Elements := null;
3393 -- Container invariants have been restored, so it is now safe
3394 -- to attempt to deallocate the internal array.
3399 elsif N < Container.Elements.EA'Length then
3401 -- The container is not empty, and the current length is less than
3402 -- the current capacity, so there's storage available to trim. In
3403 -- this case, we allocate a new internal array having a length
3404 -- that exactly matches the number of items in the
3405 -- container. (Reserve_Capacity does not delete active elements,
3406 -- so this is the best we can do with respect to minimizing
3409 if Container.Busy > 0 then
3410 raise Program_Error with
3411 "attempt to tamper with cursors (vector is busy)";
3415 subtype Array_Index_Subtype is Index_Type'Base range
3416 Index_Type'First .. Container.Last;
3418 Src : Elements_Array renames
3419 Container.Elements.EA (Array_Index_Subtype);
3421 X : Elements_Access := Container.Elements;
3424 -- Although we have isolated the old internal array that we're
3425 -- going to deallocate, we don't deallocate it until we have
3426 -- successfully allocated a new one. If there is an exception
3427 -- during allocation (because there is not enough storage), we
3428 -- let it propagate without causing any side-effect.
3430 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
3432 -- We have successfully allocated a new internal array (with a
3433 -- smaller length than the old one, and containing a copy of
3434 -- just the active elements in the container), so we can
3435 -- deallocate the old array.
3444 -- Reserve_Capacity can be used to expand the storage available for
3445 -- elements, but we do not let the capacity grow beyond the number of
3446 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3447 -- to refer to the elements with index values greater than
3448 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3449 -- the Last index value of the new internal array, in a way that avoids
3450 -- any possibility of overflow.
3452 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3454 -- We perform a two-part test. First we determine whether the
3455 -- computed Last value lies in the base range of the type, and then
3456 -- determine whether it lies in the range of the index (sub)type.
3458 -- Last must satisfy this relation:
3459 -- First + Length - 1 <= Last
3460 -- We regroup terms:
3461 -- First - 1 <= Last - Length
3462 -- Which can rewrite as:
3463 -- No_Index <= Last - Length
3465 if Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
then
3466 raise Constraint_Error
with "Capacity is out of range";
3469 -- We now know that the computed value of Last is within the base
3470 -- range of the type, so it is safe to compute its value:
3472 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
3474 -- Finally we test whether the value is within the range of the
3475 -- generic actual index subtype:
3477 if Last
> Index_Type
'Last then
3478 raise Constraint_Error
with "Capacity is out of range";
3481 elsif Index_Type
'First <= 0 then
3483 -- Here we can compute Last directly, in the normal way. We know that
3484 -- No_Index is less than 0, so there is no danger of overflow when
3485 -- adding the (positive) value of Capacity.
3487 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
3489 if Index
> Count_Type
'Base (Index_Type
'Last) then
3490 raise Constraint_Error
with "Capacity is out of range";
3493 -- We know that the computed value (having type Count_Type) of Last
3494 -- is within the range of the generic actual index subtype, so it is
3495 -- safe to convert to Index_Type:
3497 Last
:= Index_Type
'Base (Index
);
3500 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3501 -- must test the length indirectly (by working backwards from the
3502 -- largest possible value of Last), in order to prevent overflow.
3504 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
3506 if Index
< Count_Type
'Base (No_Index
) then
3507 raise Constraint_Error
with "Capacity is out of range";
3510 -- We have determined that the value of Capacity would not create a
3511 -- Last index value outside of the range of Index_Type, so we can now
3512 -- safely compute its value.
3514 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
3517 -- The requested capacity is non-zero, but we don't know yet whether
3518 -- this is a request for expansion or contraction of storage.
3520 if Container
.Elements
= null then
3522 -- The container is empty (it doesn't even have an internal array),
3523 -- so this represents a request to allocate storage having the given
3526 Container
.Elements
:= new Elements_Type
(Last
);
3530 if Capacity
<= N
then
3532 -- This is a request to trim back storage, but only to the limit of
3533 -- what's already in the container. (Reserve_Capacity never deletes
3534 -- active elements, it only reclaims excess storage.)
3536 if N
< Container
.Elements
.EA
'Length then
3538 -- The container is not empty (because the requested capacity is
3539 -- positive, and less than or equal to the container length), and
3540 -- the current length is less than the current capacity, so there
3541 -- is storage available to trim. In this case, we allocate a new
3542 -- internal array having a length that exactly matches the number
3543 -- of items in the container.
3545 if Container
.Busy
> 0 then
3546 raise Program_Error
with
3547 "attempt to tamper with cursors (vector is busy)";
3551 subtype Array_Index_Subtype
is Index_Type
'Base range
3552 Index_Type
'First .. Container
.Last
;
3554 Src
: Elements_Array
renames
3555 Container
.Elements
.EA
(Array_Index_Subtype
);
3557 X
: Elements_Access
:= Container
.Elements
;
3560 -- Although we have isolated the old internal array that we're
3561 -- going to deallocate, we don't deallocate it until we have
3562 -- successfully allocated a new one. If there is an exception
3563 -- during allocation (because there is not enough storage), we
3564 -- let it propagate without causing any side-effect.
3566 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
3568 -- We have successfully allocated a new internal array (with a
3569 -- smaller length than the old one, and containing a copy of
3570 -- just the active elements in the container), so it is now
3571 -- safe to deallocate the old array.
3580 -- The requested capacity is larger than the container length (the
3581 -- number of active elements). Whether this represents a request for
3582 -- expansion or contraction of the current capacity depends on what the
3583 -- current capacity is.
3585 if Capacity = Container.Elements.EA'Length then
3587 -- The requested capacity matches the existing capacity, so there's
3588 -- nothing to do here. We treat this case as a no-op, and simply
3589 -- return without checking the busy bit.
3594 -- There is a change in the capacity of a non-empty container, so a new
3595 -- internal array will be allocated. (The length of the new internal
3596 -- array could be less or greater than the old internal array. We know
3597 -- only that the length of the new internal array is greater than the
3598 -- number of active elements in the container.) We must check whether
3599 -- the container is busy before doing anything else.
3601 if Container.Busy > 0 then
3602 raise Program_Error with
3603 "attempt to tamper with cursors (vector is busy)";
3606 -- We now allocate a new internal array, having a length different from
3607 -- its current value.
3610 X : Elements_Access := Container.Elements;
3612 subtype Index_Subtype is Index_Type'Base range
3613 Index_Type'First .. Container.Last;
3616 -- We now allocate a new internal array, having a length different
3617 -- from its current value.
3619 Container.Elements := new Elements_Type (Last);
3621 -- We have successfully allocated the new internal array, so now we
3622 -- move the existing elements from the existing the old internal
3623 -- array onto the new one. Note that we're just copying access
3624 -- values, to this should not raise any exceptions.
3626 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3628 -- We have moved the elements from the old internal array, so now we
3629 -- can deallocate it.
3633 end Reserve_Capacity;
3635 ----------------------
3636 -- Reverse_Elements --
3637 ----------------------
3639 procedure Reverse_Elements (Container : in out Vector) is
3641 if Container.Length <= 1 then
3645 -- The exception behavior for the vector container must match that for
3646 -- the list container, so we check for cursor tampering here (which will
3647 -- catch more things) instead of for element tampering (which will catch
3648 -- fewer things). It's true that the elements of this vector container
3649 -- could be safely moved around while (say) an iteration is taking place
3650 -- (iteration only increments the busy counter), and so technically all
3651 -- we would need here is a test for element tampering (indicated by the
3652 -- lock counter), that's simply an artifact of our array-based
3653 -- implementation. Logically Reverse_Elements requires a check for
3654 -- cursor tampering.
3656 if Container.Busy > 0 then
3657 raise Program_Error with
3658 "attempt to tamper with cursors (vector is busy)";
3664 E : Elements_Array renames Container.Elements.EA;
3667 I := Index_Type'First;
3668 J := Container.Last;
3671 EI : constant Element_Access := E (I);
3682 end Reverse_Elements;
3688 function Reverse_Find
3689 (Container : Vector;
3690 Item : Element_Type;
3691 Position : Cursor := No_Element) return Cursor
3693 Last : Index_Type'Base;
3696 if Position.Container /= null
3697 and then Position.Container /= Container'Unrestricted_Access
3699 raise Program_Error with "Position cursor denotes wrong container";
3702 if Position.Container = null or else Position.Index > Container.Last then
3703 Last := Container.Last;
3705 Last := Position.Index;
3708 -- Per AI05-0022, the container implementation is required to detect
3709 -- element tampering by a generic actual subprogram.
3712 B : Natural renames Container'Unrestricted_Access.Busy;
3713 L : Natural renames Container'Unrestricted_Access.Lock;
3715 Result : Index_Type'Base;
3722 for Indx in reverse Index_Type'First .. Last loop
3723 if Container.Elements.EA (Indx) /= null
3724 and then Container.Elements.EA (Indx).all = Item
3734 if Result = No_Index then
3737 return Cursor'(Container
'Unrestricted_Access, Result
);
3748 ------------------------
3749 -- Reverse_Find_Index --
3750 ------------------------
3752 function Reverse_Find_Index
3753 (Container
: Vector
;
3754 Item
: Element_Type
;
3755 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
3757 B
: Natural renames Container
'Unrestricted_Access.Busy
;
3758 L
: Natural renames Container
'Unrestricted_Access.Lock
;
3760 Last
: constant Index_Type
'Base :=
3761 (if Index
> Container
.Last
then Container
.Last
else Index
);
3763 Result
: Index_Type
'Base;
3766 -- Per AI05-0022, the container implementation is required to detect
3767 -- element tampering by a generic actual subprogram.
3773 for Indx
in reverse Index_Type
'First .. Last
loop
3774 if Container
.Elements
.EA
(Indx
) /= null
3775 and then Container
.Elements
.EA
(Indx
).all = Item
3792 end Reverse_Find_Index
;
3794 ---------------------
3795 -- Reverse_Iterate --
3796 ---------------------
3798 procedure Reverse_Iterate
3799 (Container
: Vector
;
3800 Process
: not null access procedure (Position
: Cursor
))
3802 V
: Vector
renames Container
'Unrestricted_Access.all;
3803 B
: Natural renames V
.Busy
;
3809 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
3810 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
3819 end Reverse_Iterate;
3825 procedure Set_Length
3826 (Container : in out Vector;
3827 Length : Count_Type)
3829 Count : constant Count_Type'Base := Container.Length - Length;
3832 -- Set_Length allows the user to set the length explicitly, instead of
3833 -- implicitly as a side-effect of deletion or insertion. If the
3834 -- requested length is less than the current length, this is equivalent
3835 -- to deleting items from the back end of the vector. If the requested
3836 -- length is greater than the current length, then this is equivalent to
3837 -- inserting "space" (nonce items) at the end.
3840 Container.Delete_Last (Count);
3842 elsif Container.Last >= Index_Type'Last then
3843 raise Constraint_Error with "vector is already at its maximum length";
3846 Container.Insert_Space (Container.Last + 1, -Count);
3855 (Container : in out Vector;
3859 if I > Container.Last then
3860 raise Constraint_Error with "I index is out of range";
3863 if J > Container.Last then
3864 raise Constraint_Error with "J index is out of range";
3871 if Container.Lock > 0 then
3872 raise Program_Error with
3873 "attempt to tamper with elements (vector is locked)";
3877 EI : Element_Access renames Container.Elements.EA (I);
3878 EJ : Element_Access renames Container.Elements.EA (J);
3880 EI_Copy : constant Element_Access := EI;
3889 (Container : in out Vector;
3893 if I.Container = null then
3894 raise Constraint_Error with "I cursor has no element";
3897 if J.Container = null then
3898 raise Constraint_Error with "J cursor has no element";
3901 if I.Container /= Container'Unrestricted_Access then
3902 raise Program_Error with "I cursor denotes wrong container";
3905 if J.Container /= Container'Unrestricted_Access then
3906 raise Program_Error with "J cursor denotes wrong container";
3909 Swap (Container, I.Index, J.Index);
3917 (Container : Vector;
3918 Index : Extended_Index) return Cursor
3921 if Index not in Index_Type'First .. Container.Last then
3925 return Cursor'(Container
'Unrestricted_Access, Index
);
3932 function To_Index
(Position
: Cursor
) return Extended_Index
is
3934 if Position
.Container
= null then
3936 elsif Position
.Index
<= Position
.Container
.Last
then
3937 return Position
.Index
;
3947 function To_Vector
(Length
: Count_Type
) return Vector
is
3948 Index
: Count_Type
'Base;
3949 Last
: Index_Type
'Base;
3950 Elements
: Elements_Access
;
3954 return Empty_Vector
;
3957 -- We create a vector object with a capacity that matches the specified
3958 -- Length, but we do not allow the vector capacity (the length of the
3959 -- internal array) to exceed the number of values in Index_Type'Range
3960 -- (otherwise, there would be no way to refer to those components via an
3961 -- index). We must therefore check whether the specified Length would
3962 -- create a Last index value greater than Index_Type'Last.
3964 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3966 -- We perform a two-part test. First we determine whether the
3967 -- computed Last value lies in the base range of the type, and then
3968 -- determine whether it lies in the range of the index (sub)type.
3970 -- Last must satisfy this relation:
3971 -- First + Length - 1 <= Last
3972 -- We regroup terms:
3973 -- First - 1 <= Last - Length
3974 -- Which can rewrite as:
3975 -- No_Index <= Last - Length
3977 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
3978 raise Constraint_Error
with "Length is out of range";
3981 -- We now know that the computed value of Last is within the base
3982 -- range of the type, so it is safe to compute its value:
3984 Last
:= No_Index
+ Index_Type
'Base (Length
);
3986 -- Finally we test whether the value is within the range of the
3987 -- generic actual index subtype:
3989 if Last
> Index_Type
'Last then
3990 raise Constraint_Error
with "Length is out of range";
3993 elsif Index_Type
'First <= 0 then
3995 -- Here we can compute Last directly, in the normal way. We know that
3996 -- No_Index is less than 0, so there is no danger of overflow when
3997 -- adding the (positive) value of Length.
3999 Index
:= Count_Type
'Base (No_Index
) + Length
; -- Last
4001 if Index
> Count_Type
'Base (Index_Type
'Last) then
4002 raise Constraint_Error
with "Length is out of range";
4005 -- We know that the computed value (having type Count_Type) of Last
4006 -- is within the range of the generic actual index subtype, so it is
4007 -- safe to convert to Index_Type:
4009 Last
:= Index_Type
'Base (Index
);
4012 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
4013 -- must test the length indirectly (by working backwards from the
4014 -- largest possible value of Last), in order to prevent overflow.
4016 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
4018 if Index
< Count_Type
'Base (No_Index
) then
4019 raise Constraint_Error
with "Length is out of range";
4022 -- We have determined that the value of Length would not create a
4023 -- Last index value outside of the range of Index_Type, so we can now
4024 -- safely compute its value.
4026 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
4029 Elements
:= new Elements_Type
(Last
);
4031 return Vector
'(Controlled with Elements, Last, 0, 0);
4035 (New_Item : Element_Type;
4036 Length : Count_Type) return Vector
4038 Index : Count_Type'Base;
4039 Last : Index_Type'Base;
4040 Elements : Elements_Access;
4044 return Empty_Vector;
4047 -- We create a vector object with a capacity that matches the specified
4048 -- Length, but we do not allow the vector capacity (the length of the
4049 -- internal array) to exceed the number of values in Index_Type'Range
4050 -- (otherwise, there would be no way to refer to those components via an
4051 -- index). We must therefore check whether the specified Length would
4052 -- create a Last index value greater than Index_Type'Last.
4054 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
4056 -- We perform a two-part test. First we determine whether the
4057 -- computed Last value lies in the base range of the type, and then
4058 -- determine whether it lies in the range of the index (sub)type.
4060 -- Last must satisfy this relation:
4061 -- First + Length - 1 <= Last
4062 -- We regroup terms:
4063 -- First - 1 <= Last - Length
4064 -- Which can rewrite as:
4065 -- No_Index <= Last - Length
4067 if Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index then
4068 raise Constraint_Error with "Length is out of range";
4071 -- We now know that the computed value of Last is within the base
4072 -- range of the type, so it is safe to compute its value:
4074 Last := No_Index + Index_Type'Base (Length);
4076 -- Finally we test whether the value is within the range of the
4077 -- generic actual index subtype:
4079 if Last > Index_Type'Last then
4080 raise Constraint_Error with "Length is out of range";
4083 elsif Index_Type'First <= 0 then
4085 -- Here we can compute Last directly, in the normal way. We know that
4086 -- No_Index is less than 0, so there is no danger of overflow when
4087 -- adding the (positive) value of Length.
4089 Index := Count_Type'Base (No_Index) + Length; -- Last
4091 if Index > Count_Type'Base (Index_Type'Last) then
4092 raise Constraint_Error with "Length is out of range";
4095 -- We know that the computed value (having type Count_Type) of Last
4096 -- is within the range of the generic actual index subtype, so it is
4097 -- safe to convert to Index_Type:
4099 Last := Index_Type'Base (Index);
4102 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
4103 -- must test the length indirectly (by working backwards from the
4104 -- largest possible value of Last), in order to prevent overflow.
4106 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
4108 if Index < Count_Type'Base (No_Index) then
4109 raise Constraint_Error with "Length is out of range";
4112 -- We have determined that the value of Length would not create a
4113 -- Last index value outside of the range of Index_Type, so we can now
4114 -- safely compute its value.
4116 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
4119 Elements := new Elements_Type (Last);
4121 -- We use Last as the index of the loop used to populate the internal
4122 -- array with items. In general, we prefer to initialize the loop index
4123 -- immediately prior to entering the loop. However, Last is also used in
4124 -- the exception handler (to reclaim elements that have been allocated,
4125 -- before propagating the exception), and the initialization of Last
4126 -- after entering the block containing the handler confuses some static
4127 -- analysis tools, with respect to whether Last has been properly
4128 -- initialized when the handler executes. So here we initialize our loop
4129 -- variable earlier than we prefer, before entering the block, so there
4132 Last := Index_Type'First;
4135 -- The element allocator may need an accessibility check in the case
4136 -- where the actual type is class-wide or has access discriminants
4137 -- (see RM 4.8(10.1) and AI12-0035).
4139 pragma Unsuppress (Accessibility_Check);
4143 Elements.EA (Last) := new Element_Type'(New_Item
);
4144 exit when Last
= Elements
.Last
;
4150 for J
in Index_Type
'First .. Last
- 1 loop
4151 Free
(Elements
.EA
(J
));
4158 return (Controlled
with Elements
, Last
, 0, 0);
4161 --------------------
4162 -- Update_Element --
4163 --------------------
4165 procedure Update_Element
4166 (Container
: in out Vector
;
4168 Process
: not null access procedure (Element
: in out Element_Type
))
4170 B
: Natural renames Container
.Busy
;
4171 L
: Natural renames Container
.Lock
;
4174 if Index
> Container
.Last
then
4175 raise Constraint_Error
with "Index is out of range";
4178 if Container
.Elements
.EA
(Index
) = null then
4179 raise Constraint_Error
with "element is null";
4186 Process
(Container
.Elements
.EA
(Index
).all);
4198 procedure Update_Element
4199 (Container
: in out Vector
;
4201 Process
: not null access procedure (Element
: in out Element_Type
))
4204 if Position
.Container
= null then
4205 raise Constraint_Error
with "Position cursor has no element";
4207 elsif Position
.Container
/= Container
'Unrestricted_Access then
4208 raise Program_Error
with "Position cursor denotes wrong container";
4211 Update_Element
(Container
, Position
.Index
, Process
);
4220 (Stream
: not null access Root_Stream_Type
'Class;
4223 N
: constant Count_Type
:= Length
(Container
);
4226 Count_Type
'Base'Write (Stream, N);
4233 E : Elements_Array renames Container.Elements.EA;
4236 for Indx in Index_Type'First .. Container.Last loop
4237 if E (Indx) = null then
4238 Boolean'Write (Stream, False);
4240 Boolean'Write (Stream, True);
4241 Element_Type'Output (Stream, E (Indx).all);
4248 (Stream : not null access Root_Stream_Type'Class;
4252 raise Program_Error with "attempt to stream vector cursor";
4256 (Stream : not null access Root_Stream_Type'Class;
4257 Item : Reference_Type)
4260 raise Program_Error with "attempt to stream reference";
4264 (Stream : not null access Root_Stream_Type'Class;
4265 Item : Constant_Reference_Type)
4268 raise Program_Error with "attempt to stream reference";
4271 end Ada.Containers.Indefinite_Vectors;