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-2014, 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
37 pragma Annotate
(CodePeer
, Skip_Analysis
);
40 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
43 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
49 function "&" (Left
, Right
: Vector
) return Vector
is
50 LN
: constant Count_Type
:= Length
(Left
);
51 RN
: constant Count_Type
:= Length
(Right
);
52 N
: Count_Type
'Base; -- length of result
53 J
: Count_Type
'Base; -- for computing intermediate values
54 Last
: Index_Type
'Base; -- Last index of result
57 -- We decide that the capacity of the result is the sum of the lengths
58 -- of the vector parameters. We could decide to make it larger, but we
59 -- have no basis for knowing how much larger, so we just allocate the
60 -- minimum amount of storage.
62 -- Here we handle the easy cases first, when one of the vector
63 -- parameters is empty. (We say "easy" because there's nothing to
64 -- compute, that can potentially overflow.)
72 RE
: Elements_Array
renames
73 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
75 Elements
: Elements_Access
:= new Elements_Type
(Right
.Last
);
78 -- Elements of an indefinite vector are allocated, so we cannot
79 -- use simple slice assignment to give a value to our result.
80 -- Hence we must walk the array of the Right vector, and copy
81 -- each source element individually.
83 for I
in Elements
.EA
'Range loop
85 if RE
(I
) /= null then
86 Elements
.EA
(I
) := new Element_Type
'(RE (I).all);
91 for J in Index_Type'First .. I - 1 loop
92 Free (Elements.EA (J));
100 return (Controlled with Elements, Right.Last, 0, 0);
106 LE : Elements_Array renames
107 Left.Elements.EA (Index_Type'First .. Left.Last);
109 Elements : Elements_Access := new Elements_Type (Left.Last);
112 -- Elements of an indefinite vector are allocated, so we cannot
113 -- use simple slice assignment to give a value to our result.
114 -- Hence we must walk the array of the Left vector, and copy
115 -- each source element individually.
117 for I in Elements.EA'Range loop
119 if LE (I) /= null then
120 Elements.EA (I) := new Element_Type'(LE
(I
).all);
125 for J
in Index_Type
'First .. I
- 1 loop
126 Free
(Elements
.EA
(J
));
134 return (Controlled
with Elements
, Left
.Last
, 0, 0);
138 -- Neither of the vector parameters is empty, so we must compute the
139 -- length of the result vector and its last index. (This is the harder
140 -- case, because our computations must avoid overflow.)
142 -- There are two constraints we need to satisfy. The first constraint is
143 -- that a container cannot have more than Count_Type'Last elements, so
144 -- we must check the sum of the combined lengths. Note that we cannot
145 -- simply add the lengths, because of the possibility of overflow.
147 if LN
> Count_Type
'Last - RN
then
148 raise Constraint_Error
with "new length is out of range";
151 -- It is now safe compute the length of the new vector.
155 -- The second constraint is that the new Last index value cannot
156 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
157 -- Count_Type'Base as the type for intermediate values.
159 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
161 -- We perform a two-part test. First we determine whether the
162 -- computed Last value lies in the base range of the type, and then
163 -- determine whether it lies in the range of the index (sub)type.
165 -- Last must satisfy this relation:
166 -- First + Length - 1 <= Last
168 -- First - 1 <= Last - Length
169 -- Which can rewrite as:
170 -- No_Index <= Last - Length
172 if Index_Type'Base'Last
- Index_Type
'Base (N
) < No_Index
then
173 raise Constraint_Error
with "new length is out of range";
176 -- We now know that the computed value of Last is within the base
177 -- range of the type, so it is safe to compute its value:
179 Last
:= No_Index
+ Index_Type
'Base (N
);
181 -- Finally we test whether the value is within the range of the
182 -- generic actual index subtype:
184 if Last
> Index_Type
'Last then
185 raise Constraint_Error
with "new length is out of range";
188 elsif Index_Type
'First <= 0 then
190 -- Here we can compute Last directly, in the normal way. We know that
191 -- No_Index is less than 0, so there is no danger of overflow when
192 -- adding the (positive) value of length.
194 J
:= Count_Type
'Base (No_Index
) + N
; -- Last
196 if J
> Count_Type
'Base (Index_Type
'Last) then
197 raise Constraint_Error
with "new length is out of range";
200 -- We know that the computed value (having type Count_Type) of Last
201 -- is within the range of the generic actual index subtype, so it is
202 -- safe to convert to Index_Type:
204 Last
:= Index_Type
'Base (J
);
207 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
208 -- must test the length indirectly (by working backwards from the
209 -- largest possible value of Last), in order to prevent overflow.
211 J
:= Count_Type
'Base (Index_Type
'Last) - N
; -- No_Index
213 if J
< Count_Type
'Base (No_Index
) then
214 raise Constraint_Error
with "new length is out of range";
217 -- We have determined that the result length would not create a Last
218 -- index value outside of the range of Index_Type, so we can now
219 -- safely compute its value.
221 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + N
);
225 LE
: Elements_Array
renames
226 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
227 RE
: Elements_Array
renames
228 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
230 Elements
: Elements_Access
:= new Elements_Type
(Last
);
232 I
: Index_Type
'Base := No_Index
;
235 -- Elements of an indefinite vector are allocated, so we cannot use
236 -- simple slice assignment to give a value to our result. Hence we
237 -- must walk the array of each vector parameter, and copy each source
238 -- element individually.
240 for LI
in LE
'Range loop
244 if LE
(LI
) /= null then
245 Elements
.EA
(I
) := new Element_Type
'(LE (LI).all);
250 for J in Index_Type'First .. I - 1 loop
251 Free (Elements.EA (J));
259 for RI in RE'Range loop
263 if RE (RI) /= null then
264 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
269 for J
in Index_Type
'First .. I
- 1 loop
270 Free
(Elements
.EA
(J
));
278 return (Controlled
with Elements
, Last
, 0, 0);
282 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
284 -- We decide that the capacity of the result is the sum of the lengths
285 -- of the parameters. We could decide to make it larger, but we have no
286 -- basis for knowing how much larger, so we just allocate the minimum
287 -- amount of storage.
289 -- Here we handle the easy case first, when the vector parameter (Left)
292 if Left
.Is_Empty
then
294 Elements
: Elements_Access
:= new Elements_Type
(Index_Type
'First);
298 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Right);
305 return (Controlled with Elements, Index_Type'First, 0, 0);
309 -- The vector parameter is not empty, so we must compute the length of
310 -- the result vector and its last index, but in such a way that overflow
311 -- is avoided. We must satisfy two constraints: the new length cannot
312 -- exceed Count_Type'Last, and the new Last index cannot exceed
315 if Left.Length = Count_Type'Last then
316 raise Constraint_Error with "new length is out of range";
319 if Left.Last >= Index_Type'Last then
320 raise Constraint_Error with "new length is out of range";
324 Last : constant Index_Type := Left.Last + 1;
326 LE : Elements_Array renames
327 Left.Elements.EA (Index_Type'First .. Left.Last);
329 Elements : Elements_Access := new Elements_Type (Last);
332 for I in LE'Range loop
334 if LE (I) /= null then
335 Elements.EA (I) := new Element_Type'(LE
(I
).all);
340 for J
in Index_Type
'First .. I
- 1 loop
341 Free
(Elements
.EA
(J
));
350 Elements
.EA
(Last
) := new Element_Type
'(Right);
354 for J in Index_Type'First .. Last - 1 loop
355 Free (Elements.EA (J));
362 return (Controlled with Elements, Last, 0, 0);
366 function "&" (Left : Element_Type; Right : Vector) return Vector is
368 -- We decide that the capacity of the result is the sum of the lengths
369 -- of the parameters. We could decide to make it larger, but we have no
370 -- basis for knowing how much larger, so we just allocate the minimum
371 -- amount of storage.
373 -- Here we handle the easy case first, when the vector parameter (Right)
376 if Right.Is_Empty then
378 Elements : Elements_Access := new Elements_Type (Index_Type'First);
382 Elements.EA (Index_Type'First) := new Element_Type'(Left
);
389 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
393 -- The vector parameter is not empty, so we must compute the length of
394 -- the result vector and its last index, but in such a way that overflow
395 -- is avoided. We must satisfy two constraints: the new length cannot
396 -- exceed Count_Type'Last, and the new Last index cannot exceed
399 if Right
.Length
= Count_Type
'Last then
400 raise Constraint_Error
with "new length is out of range";
403 if Right
.Last
>= Index_Type
'Last then
404 raise Constraint_Error
with "new length is out of range";
408 Last
: constant Index_Type
:= Right
.Last
+ 1;
410 RE
: Elements_Array
renames
411 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
413 Elements
: Elements_Access
:= new Elements_Type
(Last
);
415 I
: Index_Type
'Base := Index_Type
'First;
419 Elements
.EA
(I
) := new Element_Type
'(Left);
426 for RI in RE'Range loop
430 if RE (RI) /= null then
431 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
436 for J
in Index_Type
'First .. I
- 1 loop
437 Free
(Elements
.EA
(J
));
445 return (Controlled
with Elements
, Last
, 0, 0);
449 function "&" (Left
, Right
: Element_Type
) return Vector
is
451 -- We decide that the capacity of the result is the sum of the lengths
452 -- of the parameters. We could decide to make it larger, but we have no
453 -- basis for knowing how much larger, so we just allocate the minimum
454 -- amount of storage.
456 -- We must compute the length of the result vector and its last index,
457 -- but in such a way that overflow is avoided. We must satisfy two
458 -- constraints: the new length cannot exceed Count_Type'Last (here, we
459 -- know that that condition is satisfied), and the new Last index cannot
460 -- exceed Index_Type'Last.
462 if Index_Type
'First >= Index_Type
'Last then
463 raise Constraint_Error
with "new length is out of range";
467 Last
: constant Index_Type
:= Index_Type
'First + 1;
468 Elements
: Elements_Access
:= new Elements_Type
(Last
);
472 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Left);
480 Elements.EA (Last) := new Element_Type'(Right
);
483 Free
(Elements
.EA
(Index_Type
'First));
488 return (Controlled
with Elements
, Last
, 0, 0);
496 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
497 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
498 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
500 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
501 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
506 if Left
'Address = Right
'Address then
510 if Left
.Last
/= Right
.Last
then
514 -- Per AI05-0022, the container implementation is required to detect
515 -- element tampering by a generic actual subprogram.
524 for J
in Index_Type
'First .. Left
.Last
loop
525 if Left
.Elements
.EA
(J
) = null then
526 if Right
.Elements
.EA
(J
) /= null then
531 elsif Right
.Elements
.EA
(J
) = null then
535 elsif Left
.Elements
.EA
(J
).all /= Right
.Elements
.EA
(J
).all then
564 procedure Adjust
(Container
: in out Vector
) is
566 if Container
.Last
= No_Index
then
567 Container
.Elements
:= null;
572 L
: constant Index_Type
:= Container
.Last
;
573 E
: Elements_Array
renames
574 Container
.Elements
.EA
(Index_Type
'First .. L
);
577 Container
.Elements
:= null;
578 Container
.Last
:= No_Index
;
582 Container
.Elements
:= new Elements_Type
(L
);
584 for J
in E
'Range loop
585 if E
(J
) /= null then
586 Container
.Elements
.EA
(J
) := new Element_Type
'(E (J).all);
594 procedure Adjust (Control : in out Reference_Control_Type) is
596 if Control.Container /= null then
598 C : Vector renames Control.Container.all;
599 B : Natural renames C.Busy;
600 L : Natural renames C.Lock;
612 procedure Append (Container : in out Vector; New_Item : Vector) is
614 if Is_Empty (New_Item) then
616 elsif Container.Last = Index_Type'Last then
617 raise Constraint_Error with "vector is already at its maximum length";
619 Insert (Container, Container.Last + 1, New_Item);
624 (Container : in out Vector;
625 New_Item : Element_Type;
626 Count : Count_Type := 1)
631 elsif Container.Last = Index_Type'Last then
632 raise Constraint_Error with "vector is already at its maximum length";
634 Insert (Container, Container.Last + 1, New_Item, Count);
642 procedure Assign (Target : in out Vector; Source : Vector) is
644 if Target'Address = Source'Address then
648 Target.Append (Source);
656 function Capacity (Container : Vector) return Count_Type is
658 if Container.Elements = null then
661 return Container.Elements.EA'Length;
669 procedure Clear (Container : in out Vector) is
671 if Container.Busy > 0 then
672 raise Program_Error with
673 "attempt to tamper with cursors (vector is busy)";
676 while Container.Last >= Index_Type'First loop
678 X : Element_Access := Container.Elements.EA (Container.Last);
680 Container.Elements.EA (Container.Last) := null;
681 Container.Last := Container.Last - 1;
688 ------------------------
689 -- Constant_Reference --
690 ------------------------
692 function Constant_Reference
693 (Container : aliased Vector;
694 Position : Cursor) return Constant_Reference_Type
699 if Position.Container = null then
700 raise Constraint_Error with "Position cursor has no element";
703 if Position.Container /= Container'Unrestricted_Access then
704 raise Program_Error with "Position cursor denotes wrong container";
707 if Position.Index > Position.Container.Last then
708 raise Constraint_Error with "Position cursor is out of range";
711 E := Container.Elements.EA (Position.Index);
714 raise Constraint_Error with "element at Position is empty";
718 C : Vector renames Container'Unrestricted_Access.all;
719 B : Natural renames C.Busy;
720 L : Natural renames C.Lock;
722 return R : constant Constant_Reference_Type :=
723 (Element => E.all'Access,
724 Control => (Controlled with Container'Unrestricted_Access))
730 end Constant_Reference;
732 function Constant_Reference
733 (Container : aliased Vector;
734 Index : Index_Type) return Constant_Reference_Type
739 if Index > Container.Last then
740 raise Constraint_Error with "Index is out of range";
743 E := Container.Elements.EA (Index);
746 raise Constraint_Error with "element at Index is empty";
750 C : Vector renames Container'Unrestricted_Access.all;
751 B : Natural renames C.Busy;
752 L : Natural renames C.Lock;
754 return R : constant Constant_Reference_Type :=
755 (Element => E.all'Access,
756 Control => (Controlled with Container'Unrestricted_Access))
762 end Constant_Reference;
770 Item : Element_Type) return Boolean
773 return Find_Index (Container, Item) /= No_Index;
782 Capacity : Count_Type := 0) return Vector
790 elsif Capacity >= Source.Length then
795 with "Requested capacity is less than Source length";
798 return Target : Vector do
799 Target.Reserve_Capacity (C);
800 Target.Assign (Source);
809 (Container : in out Vector;
810 Index : Extended_Index;
811 Count : Count_Type := 1)
813 Old_Last : constant Index_Type'Base := Container.Last;
814 New_Last : Index_Type'Base;
815 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
816 J : Index_Type'Base; -- first index of items that slide down
819 -- Delete removes items from the vector, the number of which is the
820 -- minimum of the specified Count and the items (if any) that exist from
821 -- Index to Container.Last. There are no constraints on the specified
822 -- value of Count (it can be larger than what's available at this
823 -- position in the vector, for example), but there are constraints on
824 -- the allowed values of the Index.
826 -- As a precondition on the generic actual Index_Type, the base type
827 -- must include Index_Type'Pred (Index_Type'First); this is the value
828 -- that Container.Last assumes when the vector is empty. However, we do
829 -- not allow that as the value for Index when specifying which items
830 -- should be deleted, so we must manually check. (That the user is
831 -- allowed to specify the value at all here is a consequence of the
832 -- declaration of the Extended_Index subtype, which includes the values
833 -- in the base range that immediately precede and immediately follow the
834 -- values in the Index_Type.)
836 if Index < Index_Type'First then
837 raise Constraint_Error with "Index is out of range (too small)";
840 -- We do allow a value greater than Container.Last to be specified as
841 -- the Index, but only if it's immediately greater. This allows the
842 -- corner case of deleting no items from the back end of the vector to
843 -- be treated as a no-op. (It is assumed that specifying an index value
844 -- greater than Last + 1 indicates some deeper flaw in the caller's
845 -- algorithm, so that case is treated as a proper error.)
847 if Index > Old_Last then
848 if Index > Old_Last + 1 then
849 raise Constraint_Error with "Index is out of range (too large)";
855 -- Here and elsewhere we treat deleting 0 items from the container as a
856 -- no-op, even when the container is busy, so we simply return.
862 -- The internal elements array isn't guaranteed to exist unless we have
863 -- elements, so we handle that case here in order to avoid having to
864 -- check it later. (Note that an empty vector can never be busy, so
865 -- there's no semantic harm in returning early.)
867 if Container.Is_Empty then
871 -- The tampering bits exist to prevent an item from being deleted (or
872 -- otherwise harmfully manipulated) while it is being visited. Query,
873 -- Update, and Iterate increment the busy count on entry, and decrement
874 -- the count on exit. Delete checks the count to determine whether it is
875 -- being called while the associated callback procedure is executing.
877 if Container.Busy > 0 then
878 raise Program_Error with
879 "attempt to tamper with cursors (vector is busy)";
882 -- We first calculate what's available for deletion starting at
883 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
884 -- Count_Type'Base as the type for intermediate values. (See function
885 -- Length for more information.)
887 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
888 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
891 Count2 := Count_Type'Base (Old_Last - Index + 1);
894 -- If the number of elements requested (Count) for deletion is equal to
895 -- (or greater than) the number of elements available (Count2) for
896 -- deletion beginning at Index, then everything from Index to
897 -- Container.Last is deleted (this is equivalent to Delete_Last).
899 if Count >= Count2 then
900 -- Elements in an indefinite vector are allocated, so we must iterate
901 -- over the loop and deallocate elements one-at-a-time. We work from
902 -- back to front, deleting the last element during each pass, in
903 -- order to gracefully handle deallocation failures.
906 EA : Elements_Array renames Container.Elements.EA;
909 while Container.Last >= Index loop
911 K : constant Index_Type := Container.Last;
912 X : Element_Access := EA (K);
915 -- We first isolate the element we're deleting, removing it
916 -- from the vector before we attempt to deallocate it, in
917 -- case the deallocation fails.
920 Container.Last := K - 1;
922 -- Container invariants have been restored, so it is now
923 -- safe to attempt to deallocate the element.
933 -- There are some elements that aren't being deleted (the requested
934 -- count was less than the available count), so we must slide them down
935 -- to Index. We first calculate the index values of the respective array
936 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
937 -- type for intermediate calculations. For the elements that slide down,
938 -- index value New_Last is the last index value of their new home, and
939 -- index value J is the first index of their old home.
941 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
942 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
943 J
:= Index
+ Index_Type
'Base (Count
);
945 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
946 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
949 -- The internal elements array isn't guaranteed to exist unless we have
950 -- elements, but we have that guarantee here because we know we have
951 -- elements to slide. The array index values for each slice have
952 -- already been determined, so what remains to be done is to first
953 -- deallocate the elements that are being deleted, and then slide down
954 -- to Index the elements that aren't being deleted.
957 EA
: Elements_Array
renames Container
.Elements
.EA
;
960 -- Before we can slide down the elements that aren't being deleted,
961 -- we need to deallocate the elements that are being deleted.
963 for K
in Index
.. J
- 1 loop
965 X
: Element_Access
:= EA
(K
);
968 -- First we remove the element we're about to deallocate from
969 -- the vector, in case the deallocation fails, in order to
970 -- preserve representation invariants.
974 -- The element has been removed from the vector, so it is now
975 -- safe to attempt to deallocate it.
981 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
982 Container
.Last
:= New_Last
;
987 (Container
: in out Vector
;
988 Position
: in out Cursor
;
989 Count
: Count_Type
:= 1)
991 pragma Warnings
(Off
, Position
);
994 if Position
.Container
= null then
995 raise Constraint_Error
with "Position cursor has no element";
997 elsif Position
.Container
/= Container
'Unrestricted_Access then
998 raise Program_Error
with "Position cursor denotes wrong container";
1000 elsif Position
.Index
> Container
.Last
then
1001 raise Program_Error
with "Position index is out of range";
1004 Delete
(Container
, Position
.Index
, Count
);
1005 Position
:= No_Element
;
1013 procedure Delete_First
1014 (Container
: in out Vector
;
1015 Count
: Count_Type
:= 1)
1021 elsif Count
>= Length
(Container
) then
1026 Delete
(Container
, Index_Type
'First, Count
);
1034 procedure Delete_Last
1035 (Container
: in out Vector
;
1036 Count
: Count_Type
:= 1)
1039 -- It is not permitted to delete items while the container is busy (for
1040 -- example, we're in the middle of a passive iteration). However, we
1041 -- always treat deleting 0 items as a no-op, even when we're busy, so we
1042 -- simply return without checking.
1048 -- We cannot simply subsume the empty case into the loop below (the loop
1049 -- would iterate 0 times), because we rename the internal array object
1050 -- (which is allocated), but an empty vector isn't guaranteed to have
1051 -- actually allocated an array. (Note that an empty vector can never be
1052 -- busy, so there's no semantic harm in returning early here.)
1054 if Container
.Is_Empty
then
1058 -- The tampering bits exist to prevent an item from being deleted (or
1059 -- otherwise harmfully manipulated) while it is being visited. Query,
1060 -- Update, and Iterate increment the busy count on entry, and decrement
1061 -- the count on exit. Delete_Last checks the count to determine whether
1062 -- it is being called while the associated callback procedure is
1065 if Container
.Busy
> 0 then
1066 raise Program_Error
with
1067 "attempt to tamper with cursors (vector is busy)";
1070 -- Elements in an indefinite vector are allocated, so we must iterate
1071 -- over the loop and deallocate elements one-at-a-time. We work from
1072 -- back to front, deleting the last element during each pass, in order
1073 -- to gracefully handle deallocation failures.
1076 E
: Elements_Array
renames Container
.Elements
.EA
;
1079 for Indx
in 1 .. Count_Type
'Min (Count
, Container
.Length
) loop
1081 J
: constant Index_Type
:= Container
.Last
;
1082 X
: Element_Access
:= E
(J
);
1085 -- Note that we first isolate the element we're deleting,
1086 -- removing it from the vector, before we actually deallocate
1087 -- it, in order to preserve representation invariants even if
1088 -- the deallocation fails.
1091 Container
.Last
:= J
- 1;
1093 -- Container invariants have been restored, so it is now safe
1094 -- to deallocate the element.
1107 (Container
: Vector
;
1108 Index
: Index_Type
) return Element_Type
1111 if Index
> Container
.Last
then
1112 raise Constraint_Error
with "Index is out of range";
1116 EA
: constant Element_Access
:= Container
.Elements
.EA
(Index
);
1119 raise Constraint_Error
with "element is empty";
1126 function Element
(Position
: Cursor
) return Element_Type
is
1128 if Position
.Container
= null then
1129 raise Constraint_Error
with "Position cursor has no element";
1132 if Position
.Index
> Position
.Container
.Last
then
1133 raise Constraint_Error
with "Position cursor is out of range";
1137 EA
: constant Element_Access
:=
1138 Position
.Container
.Elements
.EA
(Position
.Index
);
1141 raise Constraint_Error
with "element is empty";
1152 procedure Finalize
(Container
: in out Vector
) is
1154 Clear
(Container
); -- Checks busy-bit
1157 X
: Elements_Access
:= Container
.Elements
;
1159 Container
.Elements
:= null;
1164 procedure Finalize
(Object
: in out Iterator
) is
1165 B
: Natural renames Object
.Container
.Busy
;
1170 procedure Finalize
(Control
: in out Reference_Control_Type
) is
1172 if Control
.Container
/= null then
1174 C
: Vector
renames Control
.Container
.all;
1175 B
: Natural renames C
.Busy
;
1176 L
: Natural renames C
.Lock
;
1182 Control
.Container
:= null;
1191 (Container
: Vector
;
1192 Item
: Element_Type
;
1193 Position
: Cursor
:= No_Element
) return Cursor
1196 if Position
.Container
/= null then
1197 if Position
.Container
/= Container
'Unrestricted_Access then
1198 raise Program_Error
with "Position cursor denotes wrong container";
1201 if Position
.Index
> Container
.Last
then
1202 raise Program_Error
with "Position index is out of range";
1206 -- Per AI05-0022, the container implementation is required to detect
1207 -- element tampering by a generic actual subprogram.
1210 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1211 L
: Natural renames Container
'Unrestricted_Access.Lock
;
1213 Result
: Index_Type
'Base;
1220 for J
in Position
.Index
.. Container
.Last
loop
1221 if Container
.Elements
.EA
(J
) /= null
1222 and then Container
.Elements
.EA
(J
).all = Item
1232 if Result
= No_Index
then
1235 return Cursor
'(Container'Unrestricted_Access, Result);
1251 (Container : Vector;
1252 Item : Element_Type;
1253 Index : Index_Type := Index_Type'First) return Extended_Index
1255 B : Natural renames Container'Unrestricted_Access.Busy;
1256 L : Natural renames Container'Unrestricted_Access.Lock;
1258 Result : Index_Type'Base;
1261 -- Per AI05-0022, the container implementation is required to detect
1262 -- element tampering by a generic actual subprogram.
1268 for Indx in Index .. Container.Last loop
1269 if Container.Elements.EA (Indx) /= null
1270 and then Container.Elements.EA (Indx).all = Item
1294 function First (Container : Vector) return Cursor is
1296 if Is_Empty (Container) then
1300 return (Container'Unrestricted_Access, Index_Type'First);
1303 function First (Object : Iterator) return Cursor is
1305 -- The value of the iterator object's Index component influences the
1306 -- behavior of the First (and Last) selector function.
1308 -- When the Index component is No_Index, this means the iterator
1309 -- object was constructed without a start expression, in which case the
1310 -- (forward) iteration starts from the (logical) beginning of the entire
1311 -- sequence of items (corresponding to Container.First, for a forward
1314 -- Otherwise, this is iteration over a partial sequence of items.
1315 -- When the Index component isn't No_Index, the iterator object was
1316 -- constructed with a start expression, that specifies the position
1317 -- from which the (forward) partial iteration begins.
1319 if Object.Index = No_Index then
1320 return First (Object.Container.all);
1322 return Cursor'(Object
.Container
, Object
.Index
);
1330 function First_Element
(Container
: Vector
) return Element_Type
is
1332 if Container
.Last
= No_Index
then
1333 raise Constraint_Error
with "Container is empty";
1337 EA
: constant Element_Access
:=
1338 Container
.Elements
.EA
(Index_Type
'First);
1341 raise Constraint_Error
with "first element is empty";
1352 function First_Index
(Container
: Vector
) return Index_Type
is
1353 pragma Unreferenced
(Container
);
1355 return Index_Type
'First;
1358 ---------------------
1359 -- Generic_Sorting --
1360 ---------------------
1362 package body Generic_Sorting
is
1364 -----------------------
1365 -- Local Subprograms --
1366 -----------------------
1368 function Is_Less
(L
, R
: Element_Access
) return Boolean;
1369 pragma Inline
(Is_Less
);
1375 function Is_Less
(L
, R
: Element_Access
) return Boolean is
1382 return L
.all < R
.all;
1390 function Is_Sorted
(Container
: Vector
) return Boolean is
1392 if Container
.Last
<= Index_Type
'First then
1396 -- Per AI05-0022, the container implementation is required to detect
1397 -- element tampering by a generic actual subprogram.
1400 E
: Elements_Array
renames Container
.Elements
.EA
;
1402 B
: Natural renames Container
'Unrestricted_Access.Busy
;
1403 L
: Natural renames Container
'Unrestricted_Access.Lock
;
1412 for I
in Index_Type
'First .. Container
.Last
- 1 loop
1413 if Is_Less
(E
(I
+ 1), E
(I
)) then
1437 procedure Merge
(Target
, Source
: in out Vector
) is
1438 I
, J
: Index_Type
'Base;
1441 -- The semantics of Merge changed slightly per AI05-0021. It was
1442 -- originally the case that if Target and Source denoted the same
1443 -- container object, then the GNAT implementation of Merge did
1444 -- nothing. However, it was argued that RM05 did not precisely
1445 -- specify the semantics for this corner case. The decision of the
1446 -- ARG was that if Target and Source denote the same non-empty
1447 -- container object, then Program_Error is raised.
1449 if Source
.Last
< Index_Type
'First then -- Source is empty
1453 if Target
'Address = Source
'Address then
1454 raise Program_Error
with
1455 "Target and Source denote same non-empty container";
1458 if Target
.Last
< Index_Type
'First then -- Target is empty
1459 Move
(Target
=> Target
, Source
=> Source
);
1463 if Source
.Busy
> 0 then
1464 raise Program_Error
with
1465 "attempt to tamper with cursors (vector is busy)";
1468 I
:= Target
.Last
; -- original value (before Set_Length)
1469 Target
.Set_Length
(Length
(Target
) + Length
(Source
));
1471 -- Per AI05-0022, the container implementation is required to detect
1472 -- element tampering by a generic actual subprogram.
1475 TA
: Elements_Array
renames Target
.Elements
.EA
;
1476 SA
: Elements_Array
renames Source
.Elements
.EA
;
1478 TB
: Natural renames Target
.Busy
;
1479 TL
: Natural renames Target
.Lock
;
1481 SB
: Natural renames Source
.Busy
;
1482 SL
: Natural renames Source
.Lock
;
1491 J
:= Target
.Last
; -- new value (after Set_Length)
1492 while Source
.Last
>= Index_Type
'First loop
1494 (Source
.Last
<= Index_Type
'First
1495 or else not (Is_Less
(SA
(Source
.Last
),
1496 SA
(Source
.Last
- 1))));
1498 if I
< Index_Type
'First then
1500 Src
: Elements_Array
renames
1501 SA
(Index_Type
'First .. Source
.Last
);
1503 TA
(Index_Type
'First .. J
) := Src
;
1504 Src
:= (others => null);
1507 Source
.Last
:= No_Index
;
1512 (I
<= Index_Type
'First
1513 or else not (Is_Less
(TA
(I
), TA
(I
- 1))));
1516 Src
: Element_Access
renames SA
(Source
.Last
);
1517 Tgt
: Element_Access
renames TA
(I
);
1520 if Is_Less
(Src
, Tgt
) then
1521 Target
.Elements
.EA
(J
) := Tgt
;
1526 Target
.Elements
.EA
(J
) := Src
;
1528 Source
.Last
:= Source
.Last
- 1;
1557 procedure Sort
(Container
: in out Vector
) is
1558 procedure Sort
is new Generic_Array_Sort
1559 (Index_Type
=> Index_Type
,
1560 Element_Type
=> Element_Access
,
1561 Array_Type
=> Elements_Array
,
1564 -- Start of processing for Sort
1567 if Container
.Last
<= Index_Type
'First then
1571 -- The exception behavior for the vector container must match that
1572 -- for the list container, so we check for cursor tampering here
1573 -- (which will catch more things) instead of for element tampering
1574 -- (which will catch fewer things). It's true that the elements of
1575 -- this vector container could be safely moved around while (say) an
1576 -- iteration is taking place (iteration only increments the busy
1577 -- counter), and so technically all we would need here is a test for
1578 -- element tampering (indicated by the lock counter), that's simply
1579 -- an artifact of our array-based implementation. Logically Sort
1580 -- requires a check for cursor tampering.
1582 if Container
.Busy
> 0 then
1583 raise Program_Error
with
1584 "attempt to tamper with cursors (vector is busy)";
1587 -- Per AI05-0022, the container implementation is required to detect
1588 -- element tampering by a generic actual subprogram.
1591 B
: Natural renames Container
.Busy
;
1592 L
: Natural renames Container
.Lock
;
1598 Sort
(Container
.Elements
.EA
(Index_Type
'First .. Container
.Last
));
1612 end Generic_Sorting
;
1618 function Has_Element
(Position
: Cursor
) return Boolean is
1620 if Position
.Container
= null then
1623 return Position
.Index
<= Position
.Container
.Last
;
1632 (Container
: in out Vector
;
1633 Before
: Extended_Index
;
1634 New_Item
: Element_Type
;
1635 Count
: Count_Type
:= 1)
1637 Old_Length
: constant Count_Type
:= Container
.Length
;
1639 Max_Length
: Count_Type
'Base; -- determined from range of Index_Type
1640 New_Length
: Count_Type
'Base; -- sum of current length and Count
1641 New_Last
: Index_Type
'Base; -- last index of vector after insertion
1643 Index
: Index_Type
'Base; -- scratch for intermediate values
1644 J
: Count_Type
'Base; -- scratch
1646 New_Capacity
: Count_Type
'Base; -- length of new, expanded array
1647 Dst_Last
: Index_Type
'Base; -- last index of new, expanded array
1648 Dst
: Elements_Access
; -- new, expanded internal array
1651 -- As a precondition on the generic actual Index_Type, the base type
1652 -- must include Index_Type'Pred (Index_Type'First); this is the value
1653 -- that Container.Last assumes when the vector is empty. However, we do
1654 -- not allow that as the value for Index when specifying where the new
1655 -- items should be inserted, so we must manually check. (That the user
1656 -- is allowed to specify the value at all here is a consequence of the
1657 -- declaration of the Extended_Index subtype, which includes the values
1658 -- in the base range that immediately precede and immediately follow the
1659 -- values in the Index_Type.)
1661 if Before
< Index_Type
'First then
1662 raise Constraint_Error
with
1663 "Before index is out of range (too small)";
1666 -- We do allow a value greater than Container.Last to be specified as
1667 -- the Index, but only if it's immediately greater. This allows for the
1668 -- case of appending items to the back end of the vector. (It is assumed
1669 -- that specifying an index value greater than Last + 1 indicates some
1670 -- deeper flaw in the caller's algorithm, so that case is treated as a
1673 if Before
> Container
.Last
1674 and then Before
> Container
.Last
+ 1
1676 raise Constraint_Error
with
1677 "Before index is out of range (too large)";
1680 -- We treat inserting 0 items into the container as a no-op, even when
1681 -- the container is busy, so we simply return.
1687 -- There are two constraints we need to satisfy. The first constraint is
1688 -- that a container cannot have more than Count_Type'Last elements, so
1689 -- we must check the sum of the current length and the insertion count.
1690 -- Note that we cannot simply add these values, because of the
1691 -- possibility of overflow.
1693 if Old_Length
> Count_Type
'Last - Count
then
1694 raise Constraint_Error
with "Count is out of range";
1697 -- It is now safe compute the length of the new vector, without fear of
1700 New_Length
:= Old_Length
+ Count
;
1702 -- The second constraint is that the new Last index value cannot exceed
1703 -- Index_Type'Last. In each branch below, we calculate the maximum
1704 -- length (computed from the range of values in Index_Type), and then
1705 -- compare the new length to the maximum length. If the new length is
1706 -- acceptable, then we compute the new last index from that.
1708 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1710 -- We have to handle the case when there might be more values in the
1711 -- range of Index_Type than in the range of Count_Type.
1713 if Index_Type'First <= 0 then
1715 -- We know that No_Index (the same as Index_Type'First - 1) is
1716 -- less than 0, so it is safe to compute the following sum without
1717 -- fear of overflow.
1719 Index := No_Index + Index_Type'Base (Count_Type'Last);
1721 if Index <= Index_Type'Last then
1723 -- We have determined that range of Index_Type has at least as
1724 -- many values as in Count_Type, so Count_Type'Last is the
1725 -- maximum number of items that are allowed.
1727 Max_Length := Count_Type'Last;
1730 -- The range of Index_Type has fewer values than in Count_Type,
1731 -- so the maximum number of items is computed from the range of
1734 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1738 -- No_Index is equal or greater than 0, so we can safely compute
1739 -- the difference without fear of overflow (which we would have to
1740 -- worry about if No_Index were less than 0, but that case is
1743 if Index_Type'Last - No_Index >=
1744 Count_Type'Pos (Count_Type'Last)
1746 -- We have determined that range of Index_Type has at least as
1747 -- many values as in Count_Type, so Count_Type'Last is the
1748 -- maximum number of items that are allowed.
1750 Max_Length := Count_Type'Last;
1753 -- The range of Index_Type has fewer values than in Count_Type,
1754 -- so the maximum number of items is computed from the range of
1757 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1761 elsif Index_Type'First <= 0 then
1763 -- We know that No_Index (the same as Index_Type'First - 1) is less
1764 -- than 0, so it is safe to compute the following sum without fear of
1767 J := Count_Type'Base (No_Index) + Count_Type'Last;
1769 if J <= Count_Type'Base (Index_Type'Last) then
1771 -- We have determined that range of Index_Type has at least as
1772 -- many values as in Count_Type, so Count_Type'Last is the maximum
1773 -- number of items that are allowed.
1775 Max_Length := Count_Type'Last;
1778 -- The range of Index_Type has fewer values than Count_Type does,
1779 -- so the maximum number of items is computed from the range of
1783 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1787 -- No_Index is equal or greater than 0, so we can safely compute the
1788 -- difference without fear of overflow (which we would have to worry
1789 -- about if No_Index were less than 0, but that case is handled
1793 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1796 -- We have just computed the maximum length (number of items). We must
1797 -- now compare the requested length to the maximum length, as we do not
1798 -- allow a vector expand beyond the maximum (because that would create
1799 -- an internal array with a last index value greater than
1800 -- Index_Type'Last, with no way to index those elements).
1802 if New_Length > Max_Length then
1803 raise Constraint_Error with "Count is out of range";
1806 -- New_Last is the last index value of the items in the container after
1807 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1808 -- compute its value from the New_Length.
1810 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1811 New_Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1813 New_Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1816 if Container
.Elements
= null then
1817 pragma Assert
(Container
.Last
= No_Index
);
1819 -- This is the simplest case, with which we must always begin: we're
1820 -- inserting items into an empty vector that hasn't allocated an
1821 -- internal array yet. Note that we don't need to check the busy bit
1822 -- here, because an empty container cannot be busy.
1824 -- In an indefinite vector, elements are allocated individually, and
1825 -- stored as access values on the internal array (the length of which
1826 -- represents the vector "capacity"), which is separately allocated.
1828 Container
.Elements
:= new Elements_Type
(New_Last
);
1830 -- The element backbone has been successfully allocated, so now we
1831 -- allocate the elements.
1833 for Idx
in Container
.Elements
.EA
'Range loop
1835 -- In order to preserve container invariants, we always attempt
1836 -- the element allocation first, before setting the Last index
1837 -- value, in case the allocation fails (either because there is no
1838 -- storage available, or because element initialization fails).
1841 -- The element allocator may need an accessibility check in the
1842 -- case actual type is class-wide or has access discriminants
1843 -- (see RM 4.8(10.1) and AI12-0035).
1845 pragma Unsuppress
(Accessibility_Check
);
1848 Container
.Elements
.EA
(Idx
) := new Element_Type
'(New_Item);
1851 -- The allocation of the element succeeded, so it is now safe to
1852 -- update the Last index, restoring container invariants.
1854 Container.Last := Idx;
1860 -- The tampering bits exist to prevent an item from being harmfully
1861 -- manipulated while it is being visited. Query, Update, and Iterate
1862 -- increment the busy count on entry, and decrement the count on
1863 -- exit. Insert checks the count to determine whether it is being called
1864 -- while the associated callback procedure is executing.
1866 if Container.Busy > 0 then
1867 raise Program_Error with
1868 "attempt to tamper with cursors (vector is busy)";
1871 if New_Length <= Container.Elements.EA'Length then
1873 -- In this case, we're inserting elements into a vector that has
1874 -- already allocated an internal array, and the existing array has
1875 -- enough unused storage for the new items.
1878 E : Elements_Array renames Container.Elements.EA;
1879 K : Index_Type'Base;
1882 if Before > Container.Last then
1884 -- The new items are being appended to the vector, so no
1885 -- sliding of existing elements is required.
1887 for Idx in Before .. New_Last loop
1889 -- In order to preserve container invariants, we always
1890 -- attempt the element allocation first, before setting the
1891 -- Last index value, in case the allocation fails (either
1892 -- because there is no storage available, or because element
1893 -- initialization fails).
1896 -- The element allocator may need an accessibility check
1897 -- in case the actual type is class-wide or has access
1898 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1900 pragma Unsuppress (Accessibility_Check);
1903 E (Idx) := new Element_Type'(New_Item
);
1906 -- The allocation of the element succeeded, so it is now
1907 -- safe to update the Last index, restoring container
1910 Container
.Last
:= Idx
;
1914 -- The new items are being inserted before some existing
1915 -- elements, so we must slide the existing elements up to their
1916 -- new home. We use the wider of Index_Type'Base and
1917 -- Count_Type'Base as the type for intermediate index values.
1919 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1920 Index := Before + Index_Type'Base (Count);
1922 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1925 -- The new items are being inserted in the middle of the array,
1926 -- in the range [Before, Index). Copy the existing elements to
1927 -- the end of the array, to make room for the new items.
1929 E (Index .. New_Last) := E (Before .. Container.Last);
1930 Container.Last := New_Last;
1932 -- We have copied the existing items up to the end of the
1933 -- array, to make room for the new items in the middle of
1934 -- the array. Now we actually allocate the new items.
1936 -- Note: initialize K outside loop to make it clear that
1937 -- K always has a value if the exception handler triggers.
1942 -- The element allocator may need an accessibility check in
1943 -- the case the actual type is class-wide or has access
1944 -- discriminants (see RM 4.8(10.1) and AI12-0035).
1946 pragma Unsuppress (Accessibility_Check);
1949 while K < Index loop
1950 E (K) := new Element_Type'(New_Item
);
1957 -- Values in the range [Before, K) were successfully
1958 -- allocated, but values in the range [K, Index) are
1959 -- stale (these array positions contain copies of the
1960 -- old items, that did not get assigned a new item,
1961 -- because the allocation failed). We must finish what
1962 -- we started by clearing out all of the stale values,
1963 -- leaving a "hole" in the middle of the array.
1965 E
(K
.. Index
- 1) := (others => null);
1974 -- In this case, we're inserting elements into a vector that has already
1975 -- allocated an internal array, but the existing array does not have
1976 -- enough storage, so we must allocate a new, longer array. In order to
1977 -- guarantee that the amortized insertion cost is O(1), we always
1978 -- allocate an array whose length is some power-of-two factor of the
1979 -- current array length. (The new array cannot have a length less than
1980 -- the New_Length of the container, but its last index value cannot be
1981 -- greater than Index_Type'Last.)
1983 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
1984 while New_Capacity
< New_Length
loop
1985 if New_Capacity
> Count_Type
'Last / 2 then
1986 New_Capacity
:= Count_Type
'Last;
1990 New_Capacity
:= 2 * New_Capacity
;
1993 if New_Capacity
> Max_Length
then
1995 -- We have reached the limit of capacity, so no further expansion
1996 -- will occur. (This is not a problem, as there is never a need to
1997 -- have more capacity than the maximum container length.)
1999 New_Capacity
:= Max_Length
;
2002 -- We have computed the length of the new internal array (and this is
2003 -- what "vector capacity" means), so use that to compute its last index.
2005 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2006 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2009 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2012 -- Now we allocate the new, longer internal array. If the allocation
2013 -- fails, we have not changed any container state, so no side-effect
2014 -- will occur as a result of propagating the exception.
2016 Dst := new Elements_Type (Dst_Last);
2018 -- We have our new internal array. All that needs to be done now is to
2019 -- copy the existing items (if any) from the old array (the "source"
2020 -- array) to the new array (the "destination" array), and then
2021 -- deallocate the old array.
2024 Src : Elements_Access := Container.Elements;
2027 Dst.EA (Index_Type'First .. Before - 1) :=
2028 Src.EA (Index_Type'First .. Before - 1);
2030 if Before > Container.Last then
2032 -- The new items are being appended to the vector, so no
2033 -- sliding of existing elements is required.
2035 -- We have copied the elements from to the old source array to the
2036 -- new destination array, so we can now deallocate the old array.
2038 Container.Elements := Dst;
2041 -- Now we append the new items.
2043 for Idx in Before .. New_Last loop
2045 -- In order to preserve container invariants, we always attempt
2046 -- the element allocation first, before setting the Last index
2047 -- value, in case the allocation fails (either because there
2048 -- is no storage available, or because element initialization
2052 -- The element allocator may need an accessibility check in
2053 -- the case the actual type is class-wide or has access
2054 -- discriminants (see RM 4.8(10.1) and AI12-0035).
2056 pragma Unsuppress (Accessibility_Check);
2059 Dst.EA (Idx) := new Element_Type'(New_Item
);
2062 -- The allocation of the element succeeded, so it is now safe
2063 -- to update the Last index, restoring container invariants.
2065 Container
.Last
:= Idx
;
2069 -- The new items are being inserted before some existing elements,
2070 -- so we must slide the existing elements up to their new home.
2072 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2073 Index := Before + Index_Type'Base (Count);
2075 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2078 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
2080 -- We have copied the elements from to the old source array to the
2081 -- new destination array, so we can now deallocate the old array.
2083 Container.Elements := Dst;
2084 Container.Last := New_Last;
2087 -- The new array has a range in the middle containing null access
2088 -- values. Fill in that partition of the array with the new items.
2090 for Idx in Before .. Index - 1 loop
2092 -- Note that container invariants have already been satisfied
2093 -- (in particular, the Last index value of the vector has
2094 -- already been updated), so if this allocation fails we simply
2095 -- let it propagate.
2098 -- The element allocator may need an accessibility check in
2099 -- the case the actual type is class-wide or has access
2100 -- discriminants (see RM 4.8(10.1) and AI12-0035).
2102 pragma Unsuppress (Accessibility_Check);
2105 Dst.EA (Idx) := new Element_Type'(New_Item
);
2113 (Container
: in out Vector
;
2114 Before
: Extended_Index
;
2117 N
: constant Count_Type
:= Length
(New_Item
);
2118 J
: Index_Type
'Base;
2121 -- Use Insert_Space to create the "hole" (the destination slice) into
2122 -- which we copy the source items.
2124 Insert_Space
(Container
, Before
, Count
=> N
);
2128 -- There's nothing else to do here (vetting of parameters was
2129 -- performed already in Insert_Space), so we simply return.
2134 if Container
'Address /= New_Item
'Address then
2136 -- This is the simple case. New_Item denotes an object different
2137 -- from Container, so there's nothing special we need to do to copy
2138 -- the source items to their destination, because all of the source
2139 -- items are contiguous.
2142 subtype Src_Index_Subtype
is Index_Type
'Base range
2143 Index_Type
'First .. New_Item
.Last
;
2145 Src
: Elements_Array
renames
2146 New_Item
.Elements
.EA
(Src_Index_Subtype
);
2148 Dst
: Elements_Array
renames Container
.Elements
.EA
;
2150 Dst_Index
: Index_Type
'Base;
2153 Dst_Index
:= Before
- 1;
2154 for Src_Index
in Src
'Range loop
2155 Dst_Index
:= Dst_Index
+ 1;
2157 if Src
(Src_Index
) /= null then
2158 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
2166 -- New_Item denotes the same object as Container, so an insertion has
2167 -- potentially split the source items. The first source slice is
2168 -- [Index_Type'First, Before), and the second source slice is
2169 -- [J, Container.Last], where index value J is the first index of the
2170 -- second slice. (J gets computed below, but only after we have
2171 -- determined that the second source slice is non-empty.) The
2172 -- destination slice is always the range [Before, J). We perform the
2173 -- copy in two steps, using each of the two slices of the source items.
2176 L : constant Index_Type'Base := Before - 1;
2178 subtype Src_Index_Subtype is Index_Type'Base range
2179 Index_Type'First .. L;
2181 Src : Elements_Array renames
2182 Container.Elements.EA (Src_Index_Subtype);
2184 Dst : Elements_Array renames Container.Elements.EA;
2186 Dst_Index : Index_Type'Base;
2189 -- We first copy the source items that precede the space we
2190 -- inserted. (If Before equals Index_Type'First, then this first
2191 -- source slice will be empty, which is harmless.)
2193 Dst_Index := Before - 1;
2194 for Src_Index in Src'Range loop
2195 Dst_Index := Dst_Index + 1;
2197 if Src (Src_Index) /= null then
2198 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
2202 if Src
'Length = N
then
2204 -- The new items were effectively appended to the container, so we
2205 -- have already copied all of the items that need to be copied.
2206 -- We return early here, even though the source slice below is
2207 -- empty (so the assignment would be harmless), because we want to
2208 -- avoid computing J, which will overflow if J is greater than
2209 -- Index_Type'Base'Last.
2215 -- Index value J is the first index of the second source slice. (It is
2216 -- also 1 greater than the last index of the destination slice.) Note:
2217 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
2218 -- to avoid overflow. Prevent that by returning early above, immediately
2219 -- after copying the first slice of the source, and determining that
2220 -- this second slice of the source is empty.
2222 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2223 J := Before + Index_Type'Base (N);
2225 J := Index_Type'Base (Count_Type'Base (Before) + N);
2229 subtype Src_Index_Subtype is Index_Type'Base range
2230 J .. Container.Last;
2232 Src : Elements_Array renames
2233 Container.Elements.EA (Src_Index_Subtype);
2235 Dst : Elements_Array renames Container.Elements.EA;
2237 Dst_Index : Index_Type'Base;
2240 -- We next copy the source items that follow the space we inserted.
2241 -- Index value Dst_Index is the first index of that portion of the
2242 -- destination that receives this slice of the source. (For the
2243 -- reasons given above, this slice is guaranteed to be non-empty.)
2245 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2246 Dst_Index
:= J
- Index_Type
'Base (Src
'Length);
2248 Dst_Index
:= Index_Type
'Base (Count_Type
'Base (J
) - Src
'Length);
2251 for Src_Index
in Src
'Range loop
2252 if Src
(Src_Index
) /= null then
2253 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
2256 Dst_Index := Dst_Index + 1;
2262 (Container : in out Vector;
2266 Index : Index_Type'Base;
2269 if Before.Container /= null
2270 and then Before.Container /= Container'Unrestricted_Access
2272 raise Program_Error with "Before cursor denotes wrong container";
2275 if Is_Empty (New_Item) then
2279 if Before.Container = null or else Before.Index > Container.Last then
2280 if Container.Last = Index_Type'Last then
2281 raise Constraint_Error with
2282 "vector is already at its maximum length";
2285 Index := Container.Last + 1;
2288 Index := Before.Index;
2291 Insert (Container, Index, New_Item);
2295 (Container : in out Vector;
2298 Position : out Cursor)
2300 Index : Index_Type'Base;
2303 if Before.Container /= null
2304 and then Before.Container /=
2305 Vector_Access'(Container
'Unrestricted_Access)
2307 raise Program_Error
with "Before cursor denotes wrong container";
2310 if Is_Empty
(New_Item
) then
2311 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2312 Position
:= No_Element
;
2314 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2320 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2321 if Container
.Last
= Index_Type
'Last then
2322 raise Constraint_Error
with
2323 "vector is already at its maximum length";
2326 Index
:= Container
.Last
+ 1;
2329 Index
:= Before
.Index
;
2332 Insert
(Container
, Index
, New_Item
);
2334 Position
:= Cursor
'(Container'Unrestricted_Access, Index);
2338 (Container : in out Vector;
2340 New_Item : Element_Type;
2341 Count : Count_Type := 1)
2343 Index : Index_Type'Base;
2346 if Before.Container /= null
2347 and then Before.Container /= Container'Unrestricted_Access
2349 raise Program_Error with "Before cursor denotes wrong container";
2356 if Before.Container = null or else Before.Index > Container.Last then
2357 if Container.Last = Index_Type'Last then
2358 raise Constraint_Error with
2359 "vector is already at its maximum length";
2362 Index := Container.Last + 1;
2365 Index := Before.Index;
2368 Insert (Container, Index, New_Item, Count);
2372 (Container : in out Vector;
2374 New_Item : Element_Type;
2375 Position : out Cursor;
2376 Count : Count_Type := 1)
2378 Index : Index_Type'Base;
2381 if Before.Container /= null
2382 and then Before.Container /= Container'Unrestricted_Access
2384 raise Program_Error with "Before cursor denotes wrong container";
2388 if Before.Container = null
2389 or else Before.Index > Container.Last
2391 Position := No_Element;
2393 Position := (Container'Unrestricted_Access, Before.Index);
2399 if Before.Container = null or else Before.Index > Container.Last then
2400 if Container.Last = Index_Type'Last then
2401 raise Constraint_Error with
2402 "vector is already at its maximum length";
2405 Index := Container.Last + 1;
2408 Index := Before.Index;
2411 Insert (Container, Index, New_Item, Count);
2413 Position := (Container'Unrestricted_Access, Index);
2420 procedure Insert_Space
2421 (Container : in out Vector;
2422 Before : Extended_Index;
2423 Count : Count_Type := 1)
2425 Old_Length : constant Count_Type := Container.Length;
2427 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2428 New_Length : Count_Type'Base; -- sum of current length and Count
2429 New_Last : Index_Type'Base; -- last index of vector after insertion
2431 Index : Index_Type'Base; -- scratch for intermediate values
2432 J : Count_Type'Base; -- scratch
2434 New_Capacity : Count_Type'Base; -- length of new, expanded array
2435 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2436 Dst : Elements_Access; -- new, expanded internal array
2439 -- As a precondition on the generic actual Index_Type, the base type
2440 -- must include Index_Type'Pred (Index_Type'First); this is the value
2441 -- that Container.Last assumes when the vector is empty. However, we do
2442 -- not allow that as the value for Index when specifying where the new
2443 -- items should be inserted, so we must manually check. (That the user
2444 -- is allowed to specify the value at all here is a consequence of the
2445 -- declaration of the Extended_Index subtype, which includes the values
2446 -- in the base range that immediately precede and immediately follow the
2447 -- values in the Index_Type.)
2449 if Before < Index_Type'First then
2450 raise Constraint_Error with
2451 "Before index is out of range (too small)";
2454 -- We do allow a value greater than Container.Last to be specified as
2455 -- the Index, but only if it's immediately greater. This allows for the
2456 -- case of appending items to the back end of the vector. (It is assumed
2457 -- that specifying an index value greater than Last + 1 indicates some
2458 -- deeper flaw in the caller's algorithm, so that case is treated as a
2461 if Before > Container.Last and then Before > Container.Last + 1 then
2462 raise Constraint_Error with
2463 "Before index is out of range (too large)";
2466 -- We treat inserting 0 items into the container as a no-op, even when
2467 -- the container is busy, so we simply return.
2473 -- There are two constraints we need to satisfy. The first constraint is
2474 -- that a container cannot have more than Count_Type'Last elements, so
2475 -- we must check the sum of the current length and the insertion
2476 -- count. Note that we cannot simply add these values, because of the
2477 -- possibility of overflow.
2479 if Old_Length > Count_Type'Last - Count then
2480 raise Constraint_Error with "Count is out of range";
2483 -- It is now safe compute the length of the new vector, without fear of
2486 New_Length := Old_Length + Count;
2488 -- The second constraint is that the new Last index value cannot exceed
2489 -- Index_Type'Last. In each branch below, we calculate the maximum
2490 -- length (computed from the range of values in Index_Type), and then
2491 -- compare the new length to the maximum length. If the new length is
2492 -- acceptable, then we compute the new last index from that.
2494 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2495 -- We have to handle the case when there might be more values in the
2496 -- range of Index_Type than in the range of Count_Type.
2498 if Index_Type
'First <= 0 then
2500 -- We know that No_Index (the same as Index_Type'First - 1) is
2501 -- less than 0, so it is safe to compute the following sum without
2502 -- fear of overflow.
2504 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
2506 if Index
<= Index_Type
'Last then
2508 -- We have determined that range of Index_Type has at least as
2509 -- many values as in Count_Type, so Count_Type'Last is the
2510 -- maximum number of items that are allowed.
2512 Max_Length
:= Count_Type
'Last;
2515 -- The range of Index_Type has fewer values than in Count_Type,
2516 -- so the maximum number of items is computed from the range of
2519 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2523 -- No_Index is equal or greater than 0, so we can safely compute
2524 -- the difference without fear of overflow (which we would have to
2525 -- worry about if No_Index were less than 0, but that case is
2528 if Index_Type
'Last - No_Index
>=
2529 Count_Type
'Pos (Count_Type
'Last)
2531 -- We have determined that range of Index_Type has at least as
2532 -- many values as in Count_Type, so Count_Type'Last is the
2533 -- maximum number of items that are allowed.
2535 Max_Length
:= Count_Type
'Last;
2538 -- The range of Index_Type has fewer values than in Count_Type,
2539 -- so the maximum number of items is computed from the range of
2542 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2546 elsif Index_Type
'First <= 0 then
2548 -- We know that No_Index (the same as Index_Type'First - 1) is less
2549 -- than 0, so it is safe to compute the following sum without fear of
2552 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
2554 if J
<= Count_Type
'Base (Index_Type
'Last) then
2556 -- We have determined that range of Index_Type has at least as
2557 -- many values as in Count_Type, so Count_Type'Last is the maximum
2558 -- number of items that are allowed.
2560 Max_Length
:= Count_Type
'Last;
2563 -- The range of Index_Type has fewer values than Count_Type does,
2564 -- so the maximum number of items is computed from the range of
2568 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2572 -- No_Index is equal or greater than 0, so we can safely compute the
2573 -- difference without fear of overflow (which we would have to worry
2574 -- about if No_Index were less than 0, but that case is handled
2578 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2581 -- We have just computed the maximum length (number of items). We must
2582 -- now compare the requested length to the maximum length, as we do not
2583 -- allow a vector expand beyond the maximum (because that would create
2584 -- an internal array with a last index value greater than
2585 -- Index_Type'Last, with no way to index those elements).
2587 if New_Length
> Max_Length
then
2588 raise Constraint_Error
with "Count is out of range";
2591 -- New_Last is the last index value of the items in the container after
2592 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2593 -- compute its value from the New_Length.
2595 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2596 New_Last := No_Index + Index_Type'Base (New_Length);
2598 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2601 if Container.Elements = null then
2602 pragma Assert (Container.Last = No_Index);
2604 -- This is the simplest case, with which we must always begin: we're
2605 -- inserting items into an empty vector that hasn't allocated an
2606 -- internal array yet. Note that we don't need to check the busy bit
2607 -- here, because an empty container cannot be busy.
2609 -- In an indefinite vector, elements are allocated individually, and
2610 -- stored as access values on the internal array (the length of which
2611 -- represents the vector "capacity"), which is separately allocated.
2612 -- We have no elements here (because we're inserting "space"), so all
2613 -- we need to do is allocate the backbone.
2615 Container.Elements := new Elements_Type (New_Last);
2616 Container.Last := New_Last;
2621 -- The tampering bits exist to prevent an item from being harmfully
2622 -- manipulated while it is being visited. Query, Update, and Iterate
2623 -- increment the busy count on entry, and decrement the count on exit.
2624 -- Insert checks the count to determine whether it is being called while
2625 -- the associated callback procedure is executing.
2627 if Container.Busy > 0 then
2628 raise Program_Error with
2629 "attempt to tamper with cursors (vector is busy)";
2632 if New_Length <= Container.Elements.EA'Length then
2634 -- In this case, we are inserting elements into a vector that has
2635 -- already allocated an internal array, and the existing array has
2636 -- enough unused storage for the new items.
2639 E : Elements_Array renames Container.Elements.EA;
2642 if Before <= Container.Last then
2644 -- The new space is being inserted before some existing
2645 -- elements, so we must slide the existing elements up to
2646 -- their new home. We use the wider of Index_Type'Base and
2647 -- Count_Type'Base as the type for intermediate index values.
2649 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2650 Index
:= Before
+ Index_Type
'Base (Count
);
2652 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2655 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
2656 E
(Before
.. Index
- 1) := (others => null);
2660 Container
.Last
:= New_Last
;
2664 -- In this case, we're inserting elements into a vector that has already
2665 -- allocated an internal array, but the existing array does not have
2666 -- enough storage, so we must allocate a new, longer array. In order to
2667 -- guarantee that the amortized insertion cost is O(1), we always
2668 -- allocate an array whose length is some power-of-two factor of the
2669 -- current array length. (The new array cannot have a length less than
2670 -- the New_Length of the container, but its last index value cannot be
2671 -- greater than Index_Type'Last.)
2673 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
2674 while New_Capacity
< New_Length
loop
2675 if New_Capacity
> Count_Type
'Last / 2 then
2676 New_Capacity
:= Count_Type
'Last;
2680 New_Capacity
:= 2 * New_Capacity
;
2683 if New_Capacity
> Max_Length
then
2685 -- We have reached the limit of capacity, so no further expansion
2686 -- will occur. (This is not a problem, as there is never a need to
2687 -- have more capacity than the maximum container length.)
2689 New_Capacity
:= Max_Length
;
2692 -- We have computed the length of the new internal array (and this is
2693 -- what "vector capacity" means), so use that to compute its last index.
2695 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2696 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2699 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2702 -- Now we allocate the new, longer internal array. If the allocation
2703 -- fails, we have not changed any container state, so no side-effect
2704 -- will occur as a result of propagating the exception.
2706 Dst := new Elements_Type (Dst_Last);
2708 -- We have our new internal array. All that needs to be done now is to
2709 -- copy the existing items (if any) from the old array (the "source"
2710 -- array) to the new array (the "destination" array), and then
2711 -- deallocate the old array.
2714 Src : Elements_Access := Container.Elements;
2717 Dst.EA (Index_Type'First .. Before - 1) :=
2718 Src.EA (Index_Type'First .. Before - 1);
2720 if Before <= Container.Last then
2722 -- The new items are being inserted before some existing elements,
2723 -- so we must slide the existing elements up to their new home.
2725 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2726 Index
:= Before
+ Index_Type
'Base (Count
);
2728 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2731 Dst
.EA
(Index
.. New_Last
) := Src
.EA
(Before
.. Container
.Last
);
2734 -- We have copied the elements from to the old, source array to the
2735 -- new, destination array, so we can now restore invariants, and
2736 -- deallocate the old array.
2738 Container
.Elements
:= Dst
;
2739 Container
.Last
:= New_Last
;
2744 procedure Insert_Space
2745 (Container
: in out Vector
;
2747 Position
: out Cursor
;
2748 Count
: Count_Type
:= 1)
2750 Index
: Index_Type
'Base;
2753 if Before
.Container
/= null
2754 and then Before
.Container
/= Container
'Unrestricted_Access
2756 raise Program_Error
with "Before cursor denotes wrong container";
2760 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2761 Position
:= No_Element
;
2763 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2769 if Before
.Container
= null
2770 or else Before
.Index
> Container
.Last
2772 if Container
.Last
= Index_Type
'Last then
2773 raise Constraint_Error
with
2774 "vector is already at its maximum length";
2777 Index
:= Container
.Last
+ 1;
2780 Index
:= Before
.Index
;
2783 Insert_Space
(Container
, Index
, Count
);
2785 Position
:= Cursor
'(Container'Unrestricted_Access, Index);
2792 function Is_Empty (Container : Vector) return Boolean is
2794 return Container.Last < Index_Type'First;
2802 (Container : Vector;
2803 Process : not null access procedure (Position : Cursor))
2805 B : Natural renames Container'Unrestricted_Access.all.Busy;
2811 for Indx in Index_Type'First .. Container.Last loop
2812 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
2823 function Iterate
(Container
: Vector
)
2824 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
2826 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
2827 B
: Natural renames V
.Busy
;
2830 -- The value of its Index component influences the behavior of the First
2831 -- and Last selector functions of the iterator object. When the Index
2832 -- component is No_Index (as is the case here), this means the iterator
2833 -- object was constructed without a start expression. This is a complete
2834 -- iterator, meaning that the iteration starts from the (logical)
2835 -- beginning of the sequence of items.
2837 -- Note: For a forward iterator, Container.First is the beginning, and
2838 -- for a reverse iterator, Container.Last is the beginning.
2840 return It
: constant Iterator
:=
2841 (Limited_Controlled
with
2850 (Container
: Vector
;
2852 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
2854 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
2855 B
: Natural renames V
.Busy
;
2858 -- It was formerly the case that when Start = No_Element, the partial
2859 -- iterator was defined to behave the same as for a complete iterator,
2860 -- and iterate over the entire sequence of items. However, those
2861 -- semantics were unintuitive and arguably error-prone (it is too easy
2862 -- to accidentally create an endless loop), and so they were changed,
2863 -- per the ARG meeting in Denver on 2011/11. However, there was no
2864 -- consensus about what positive meaning this corner case should have,
2865 -- and so it was decided to simply raise an exception. This does imply,
2866 -- however, that it is not possible to use a partial iterator to specify
2867 -- an empty sequence of items.
2869 if Start
.Container
= null then
2870 raise Constraint_Error
with
2871 "Start position for iterator equals No_Element";
2874 if Start
.Container
/= V
then
2875 raise Program_Error
with
2876 "Start cursor of Iterate designates wrong vector";
2879 if Start
.Index
> V
.Last
then
2880 raise Constraint_Error
with
2881 "Start position for iterator equals No_Element";
2884 -- The value of its Index component influences the behavior of the First
2885 -- and Last selector functions of the iterator object. When the Index
2886 -- component is not No_Index (as is the case here), it means that this
2887 -- is a partial iteration, over a subset of the complete sequence of
2888 -- items. The iterator object was constructed with a start expression,
2889 -- indicating the position from which the iteration begins. Note that
2890 -- the start position has the same value irrespective of whether this
2891 -- is a forward or reverse iteration.
2893 return It
: constant Iterator
:=
2894 (Limited_Controlled
with
2896 Index
=> Start
.Index
)
2906 function Last
(Container
: Vector
) return Cursor
is
2908 if Is_Empty
(Container
) then
2912 return (Container
'Unrestricted_Access, Container
.Last
);
2915 function Last
(Object
: Iterator
) return Cursor
is
2917 -- The value of the iterator object's Index component influences the
2918 -- behavior of the Last (and First) selector function.
2920 -- When the Index component is No_Index, this means the iterator
2921 -- object was constructed without a start expression, in which case the
2922 -- (reverse) iteration starts from the (logical) beginning of the entire
2923 -- sequence (corresponding to Container.Last, for a reverse iterator).
2925 -- Otherwise, this is iteration over a partial sequence of items.
2926 -- When the Index component is not No_Index, the iterator object was
2927 -- constructed with a start expression, that specifies the position
2928 -- from which the (reverse) partial iteration begins.
2930 if Object
.Index
= No_Index
then
2931 return Last
(Object
.Container
.all);
2933 return Cursor
'(Object.Container, Object.Index);
2941 function Last_Element (Container : Vector) return Element_Type is
2943 if Container.Last = No_Index then
2944 raise Constraint_Error with "Container is empty";
2948 EA : constant Element_Access :=
2949 Container.Elements.EA (Container.Last);
2952 raise Constraint_Error with "last element is empty";
2963 function Last_Index (Container : Vector) return Extended_Index is
2965 return Container.Last;
2972 function Length (Container : Vector) return Count_Type is
2973 L : constant Index_Type'Base := Container.Last;
2974 F : constant Index_Type := Index_Type'First;
2977 -- The base range of the index type (Index_Type'Base) might not include
2978 -- all values for length (Count_Type). Contrariwise, the index type
2979 -- might include values outside the range of length. Hence we use
2980 -- whatever type is wider for intermediate values when calculating
2981 -- length. Note that no matter what the index type is, the maximum
2982 -- length to which a vector is allowed to grow is always the minimum
2983 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2985 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2986 -- to have a base range of -128 .. 127, but the corresponding vector
2987 -- would have lengths in the range 0 .. 255. In this case we would need
2988 -- to use Count_Type'Base for intermediate values.
2990 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2991 -- vector would have a maximum length of 10, but the index values lie
2992 -- outside the range of Count_Type (which is only 32 bits). In this
2993 -- case we would need to use Index_Type'Base for intermediate values.
2995 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
2996 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2998 return Count_Type (L - F + 1);
3007 (Target : in out Vector;
3008 Source : in out Vector)
3011 if Target'Address = Source'Address then
3015 if Source.Busy > 0 then
3016 raise Program_Error with
3017 "attempt to tamper with cursors (Source is busy)";
3020 Clear (Target); -- Checks busy-bit
3023 Target_Elements : constant Elements_Access := Target.Elements;
3025 Target.Elements := Source.Elements;
3026 Source.Elements := Target_Elements;
3029 Target.Last := Source.Last;
3030 Source.Last := No_Index;
3037 function Next (Position : Cursor) return Cursor is
3039 if Position.Container = null then
3041 elsif Position.Index < Position.Container.Last then
3042 return (Position.Container, Position.Index + 1);
3048 function Next (Object : Iterator; Position : Cursor) return Cursor is
3050 if Position.Container = null then
3052 elsif Position.Container /= Object.Container then
3053 raise Program_Error with
3054 "Position cursor of Next designates wrong vector";
3056 return Next (Position);
3060 procedure Next (Position : in out Cursor) is
3062 if Position.Container = null then
3064 elsif Position.Index < Position.Container.Last then
3065 Position.Index := Position.Index + 1;
3067 Position := No_Element;
3075 procedure Prepend (Container : in out Vector; New_Item : Vector) is
3077 Insert (Container, Index_Type'First, New_Item);
3081 (Container : in out Vector;
3082 New_Item : Element_Type;
3083 Count : Count_Type := 1)
3086 Insert (Container, Index_Type'First, New_Item, Count);
3093 procedure Previous (Position : in out Cursor) is
3095 if Position.Container = null then
3097 elsif Position.Index > Index_Type'First then
3098 Position.Index := Position.Index - 1;
3100 Position := No_Element;
3104 function Previous (Position : Cursor) return Cursor is
3106 if Position.Container = null then
3108 elsif Position.Index > Index_Type'First then
3109 return (Position.Container, Position.Index - 1);
3115 function Previous (Object : Iterator; Position : Cursor) return Cursor is
3117 if Position.Container = null then
3119 elsif Position.Container /= Object.Container then
3120 raise Program_Error with
3121 "Position cursor of Previous designates wrong vector";
3123 return Previous (Position);
3131 procedure Query_Element
3132 (Container : Vector;
3134 Process : not null access procedure (Element : Element_Type))
3136 V : Vector renames Container'Unrestricted_Access.all;
3137 B : Natural renames V.Busy;
3138 L : Natural renames V.Lock;
3141 if Index > Container.Last then
3142 raise Constraint_Error with "Index is out of range";
3145 if V.Elements.EA (Index) = null then
3146 raise Constraint_Error with "element is null";
3153 Process (V.Elements.EA (Index).all);
3165 procedure Query_Element
3167 Process : not null access procedure (Element : Element_Type))
3170 if Position.Container = null then
3171 raise Constraint_Error with "Position cursor has no element";
3173 Query_Element (Position.Container.all, Position.Index, Process);
3182 (Stream : not null access Root_Stream_Type'Class;
3183 Container : out Vector)
3185 Length : Count_Type'Base;
3186 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
3192 Count_Type'Base'Read
(Stream
, Length
);
3194 if Length
> Capacity
(Container
) then
3195 Reserve_Capacity
(Container
, Capacity
=> Length
);
3198 for J
in Count_Type
range 1 .. Length
loop
3201 Boolean'Read (Stream
, B
);
3204 Container
.Elements
.EA
(Last
) :=
3205 new Element_Type
'(Element_Type'Input (Stream));
3208 Container.Last := Last;
3213 (Stream : not null access Root_Stream_Type'Class;
3214 Position : out Cursor)
3217 raise Program_Error with "attempt to stream vector cursor";
3221 (Stream : not null access Root_Stream_Type'Class;
3222 Item : out Reference_Type)
3225 raise Program_Error with "attempt to stream reference";
3229 (Stream : not null access Root_Stream_Type'Class;
3230 Item : out Constant_Reference_Type)
3233 raise Program_Error with "attempt to stream reference";
3241 (Container : aliased in out Vector;
3242 Position : Cursor) return Reference_Type
3247 if Position.Container = null then
3248 raise Constraint_Error with "Position cursor has no element";
3251 if Position.Container /= Container'Unrestricted_Access then
3252 raise Program_Error with "Position cursor denotes wrong container";
3255 if Position.Index > Position.Container.Last then
3256 raise Constraint_Error with "Position cursor is out of range";
3259 E := Container.Elements.EA (Position.Index);
3262 raise Constraint_Error with "element at Position is empty";
3266 C : Vector renames Container'Unrestricted_Access.all;
3267 B : Natural renames C.Busy;
3268 L : Natural renames C.Lock;
3270 return R : constant Reference_Type :=
3271 (Element => E.all'Access,
3272 Control => (Controlled with Position.Container))
3281 (Container : aliased in out Vector;
3282 Index : Index_Type) return Reference_Type
3287 if Index > Container.Last then
3288 raise Constraint_Error with "Index is out of range";
3291 E := Container.Elements.EA (Index);
3294 raise Constraint_Error with "element at Index is empty";
3298 C : Vector renames Container'Unrestricted_Access.all;
3299 B : Natural renames C.Busy;
3300 L : Natural renames C.Lock;
3302 return R : constant Reference_Type :=
3303 (Element => E.all'Access,
3304 Control => (Controlled with Container'Unrestricted_Access))
3312 ---------------------
3313 -- Replace_Element --
3314 ---------------------
3316 procedure Replace_Element
3317 (Container : in out Vector;
3319 New_Item : Element_Type)
3322 if Index > Container.Last then
3323 raise Constraint_Error with "Index is out of range";
3326 if Container.Lock > 0 then
3327 raise Program_Error with
3328 "attempt to tamper with elements (vector is locked)";
3332 X : Element_Access := Container.Elements.EA (Index);
3334 -- The element allocator may need an accessibility check in the case
3335 -- where the actual type is class-wide or has access discriminants
3336 -- (see RM 4.8(10.1) and AI12-0035).
3338 pragma Unsuppress (Accessibility_Check);
3341 Container.Elements.EA (Index) := new Element_Type'(New_Item
);
3344 end Replace_Element
;
3346 procedure Replace_Element
3347 (Container
: in out Vector
;
3349 New_Item
: Element_Type
)
3352 if Position
.Container
= null then
3353 raise Constraint_Error
with "Position cursor has no element";
3356 if Position
.Container
/= Container
'Unrestricted_Access then
3357 raise Program_Error
with "Position cursor denotes wrong container";
3360 if Position
.Index
> Container
.Last
then
3361 raise Constraint_Error
with "Position cursor is out of range";
3364 if Container
.Lock
> 0 then
3365 raise Program_Error
with
3366 "attempt to tamper with elements (vector is locked)";
3370 X
: Element_Access
:= Container
.Elements
.EA
(Position
.Index
);
3372 -- The element allocator may need an accessibility check in the case
3373 -- where the actual type is class-wide or has access discriminants
3374 -- (see RM 4.8(10.1) and AI12-0035).
3376 pragma Unsuppress
(Accessibility_Check
);
3379 Container
.Elements
.EA
(Position
.Index
) := new Element_Type
'(New_Item);
3382 end Replace_Element;
3384 ----------------------
3385 -- Reserve_Capacity --
3386 ----------------------
3388 procedure Reserve_Capacity
3389 (Container : in out Vector;
3390 Capacity : Count_Type)
3392 N : constant Count_Type := Length (Container);
3394 Index : Count_Type'Base;
3395 Last : Index_Type'Base;
3398 -- Reserve_Capacity can be used to either expand the storage available
3399 -- for elements (this would be its typical use, in anticipation of
3400 -- future insertion), or to trim back storage. In the latter case,
3401 -- storage can only be trimmed back to the limit of the container
3402 -- length. Note that Reserve_Capacity neither deletes (active) elements
3403 -- nor inserts elements; it only affects container capacity, never
3404 -- container length.
3406 if Capacity = 0 then
3408 -- This is a request to trim back storage, to the minimum amount
3409 -- possible given the current state of the container.
3413 -- The container is empty, so in this unique case we can
3414 -- deallocate the entire internal array. Note that an empty
3415 -- container can never be busy, so there's no need to check the
3419 X : Elements_Access := Container.Elements;
3422 -- First we remove the internal array from the container, to
3423 -- handle the case when the deallocation raises an exception
3424 -- (although that's unlikely, since this is simply an array of
3425 -- access values, all of which are null).
3427 Container.Elements := null;
3429 -- Container invariants have been restored, so it is now safe
3430 -- to attempt to deallocate the internal array.
3435 elsif N < Container.Elements.EA'Length then
3437 -- The container is not empty, and the current length is less than
3438 -- the current capacity, so there's storage available to trim. In
3439 -- this case, we allocate a new internal array having a length
3440 -- that exactly matches the number of items in the
3441 -- container. (Reserve_Capacity does not delete active elements,
3442 -- so this is the best we can do with respect to minimizing
3445 if Container.Busy > 0 then
3446 raise Program_Error with
3447 "attempt to tamper with cursors (vector is busy)";
3451 subtype Array_Index_Subtype is Index_Type'Base range
3452 Index_Type'First .. Container.Last;
3454 Src : Elements_Array renames
3455 Container.Elements.EA (Array_Index_Subtype);
3457 X : Elements_Access := Container.Elements;
3460 -- Although we have isolated the old internal array that we're
3461 -- going to deallocate, we don't deallocate it until we have
3462 -- successfully allocated a new one. If there is an exception
3463 -- during allocation (because there is not enough storage), we
3464 -- let it propagate without causing any side-effect.
3466 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
3468 -- We have successfully allocated a new internal array (with a
3469 -- smaller length than the old one, and containing a copy of
3470 -- just the active elements in the container), so we can
3471 -- deallocate the old array.
3480 -- Reserve_Capacity can be used to expand the storage available for
3481 -- elements, but we do not let the capacity grow beyond the number of
3482 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3483 -- to refer to the elements with index values greater than
3484 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3485 -- the Last index value of the new internal array, in a way that avoids
3486 -- any possibility of overflow.
3488 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3490 -- We perform a two-part test. First we determine whether the
3491 -- computed Last value lies in the base range of the type, and then
3492 -- determine whether it lies in the range of the index (sub)type.
3494 -- Last must satisfy this relation:
3495 -- First + Length - 1 <= Last
3496 -- We regroup terms:
3497 -- First - 1 <= Last - Length
3498 -- Which can rewrite as:
3499 -- No_Index <= Last - Length
3501 if Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
then
3502 raise Constraint_Error
with "Capacity is out of range";
3505 -- We now know that the computed value of Last is within the base
3506 -- range of the type, so it is safe to compute its value:
3508 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
3510 -- Finally we test whether the value is within the range of the
3511 -- generic actual index subtype:
3513 if Last
> Index_Type
'Last then
3514 raise Constraint_Error
with "Capacity is out of range";
3517 elsif Index_Type
'First <= 0 then
3519 -- Here we can compute Last directly, in the normal way. We know that
3520 -- No_Index is less than 0, so there is no danger of overflow when
3521 -- adding the (positive) value of Capacity.
3523 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
3525 if Index
> Count_Type
'Base (Index_Type
'Last) then
3526 raise Constraint_Error
with "Capacity is out of range";
3529 -- We know that the computed value (having type Count_Type) of Last
3530 -- is within the range of the generic actual index subtype, so it is
3531 -- safe to convert to Index_Type:
3533 Last
:= Index_Type
'Base (Index
);
3536 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3537 -- must test the length indirectly (by working backwards from the
3538 -- largest possible value of Last), in order to prevent overflow.
3540 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
3542 if Index
< Count_Type
'Base (No_Index
) then
3543 raise Constraint_Error
with "Capacity is out of range";
3546 -- We have determined that the value of Capacity would not create a
3547 -- Last index value outside of the range of Index_Type, so we can now
3548 -- safely compute its value.
3550 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
3553 -- The requested capacity is non-zero, but we don't know yet whether
3554 -- this is a request for expansion or contraction of storage.
3556 if Container
.Elements
= null then
3558 -- The container is empty (it doesn't even have an internal array),
3559 -- so this represents a request to allocate storage having the given
3562 Container
.Elements
:= new Elements_Type
(Last
);
3566 if Capacity
<= N
then
3568 -- This is a request to trim back storage, but only to the limit of
3569 -- what's already in the container. (Reserve_Capacity never deletes
3570 -- active elements, it only reclaims excess storage.)
3572 if N
< Container
.Elements
.EA
'Length then
3574 -- The container is not empty (because the requested capacity is
3575 -- positive, and less than or equal to the container length), and
3576 -- the current length is less than the current capacity, so there
3577 -- is storage available to trim. In this case, we allocate a new
3578 -- internal array having a length that exactly matches the number
3579 -- of items in the container.
3581 if Container
.Busy
> 0 then
3582 raise Program_Error
with
3583 "attempt to tamper with cursors (vector is busy)";
3587 subtype Array_Index_Subtype
is Index_Type
'Base range
3588 Index_Type
'First .. Container
.Last
;
3590 Src
: Elements_Array
renames
3591 Container
.Elements
.EA
(Array_Index_Subtype
);
3593 X
: Elements_Access
:= Container
.Elements
;
3596 -- Although we have isolated the old internal array that we're
3597 -- going to deallocate, we don't deallocate it until we have
3598 -- successfully allocated a new one. If there is an exception
3599 -- during allocation (because there is not enough storage), we
3600 -- let it propagate without causing any side-effect.
3602 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
3604 -- We have successfully allocated a new internal array (with a
3605 -- smaller length than the old one, and containing a copy of
3606 -- just the active elements in the container), so it is now
3607 -- safe to deallocate the old array.
3616 -- The requested capacity is larger than the container length (the
3617 -- number of active elements). Whether this represents a request for
3618 -- expansion or contraction of the current capacity depends on what the
3619 -- current capacity is.
3621 if Capacity = Container.Elements.EA'Length then
3623 -- The requested capacity matches the existing capacity, so there's
3624 -- nothing to do here. We treat this case as a no-op, and simply
3625 -- return without checking the busy bit.
3630 -- There is a change in the capacity of a non-empty container, so a new
3631 -- internal array will be allocated. (The length of the new internal
3632 -- array could be less or greater than the old internal array. We know
3633 -- only that the length of the new internal array is greater than the
3634 -- number of active elements in the container.) We must check whether
3635 -- the container is busy before doing anything else.
3637 if Container.Busy > 0 then
3638 raise Program_Error with
3639 "attempt to tamper with cursors (vector is busy)";
3642 -- We now allocate a new internal array, having a length different from
3643 -- its current value.
3646 X : Elements_Access := Container.Elements;
3648 subtype Index_Subtype is Index_Type'Base range
3649 Index_Type'First .. Container.Last;
3652 -- We now allocate a new internal array, having a length different
3653 -- from its current value.
3655 Container.Elements := new Elements_Type (Last);
3657 -- We have successfully allocated the new internal array, so now we
3658 -- move the existing elements from the existing the old internal
3659 -- array onto the new one. Note that we're just copying access
3660 -- values, to this should not raise any exceptions.
3662 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3664 -- We have moved the elements from the old internal array, so now we
3665 -- can deallocate it.
3669 end Reserve_Capacity;
3671 ----------------------
3672 -- Reverse_Elements --
3673 ----------------------
3675 procedure Reverse_Elements (Container : in out Vector) is
3677 if Container.Length <= 1 then
3681 -- The exception behavior for the vector container must match that for
3682 -- the list container, so we check for cursor tampering here (which will
3683 -- catch more things) instead of for element tampering (which will catch
3684 -- fewer things). It's true that the elements of this vector container
3685 -- could be safely moved around while (say) an iteration is taking place
3686 -- (iteration only increments the busy counter), and so technically all
3687 -- we would need here is a test for element tampering (indicated by the
3688 -- lock counter), that's simply an artifact of our array-based
3689 -- implementation. Logically Reverse_Elements requires a check for
3690 -- cursor tampering.
3692 if Container.Busy > 0 then
3693 raise Program_Error with
3694 "attempt to tamper with cursors (vector is busy)";
3700 E : Elements_Array renames Container.Elements.EA;
3703 I := Index_Type'First;
3704 J := Container.Last;
3707 EI : constant Element_Access := E (I);
3718 end Reverse_Elements;
3724 function Reverse_Find
3725 (Container : Vector;
3726 Item : Element_Type;
3727 Position : Cursor := No_Element) return Cursor
3729 Last : Index_Type'Base;
3732 if Position.Container /= null
3733 and then Position.Container /= Container'Unrestricted_Access
3735 raise Program_Error with "Position cursor denotes wrong container";
3738 if Position.Container = null or else Position.Index > Container.Last then
3739 Last := Container.Last;
3741 Last := Position.Index;
3744 -- Per AI05-0022, the container implementation is required to detect
3745 -- element tampering by a generic actual subprogram.
3748 B : Natural renames Container'Unrestricted_Access.Busy;
3749 L : Natural renames Container'Unrestricted_Access.Lock;
3751 Result : Index_Type'Base;
3758 for Indx in reverse Index_Type'First .. Last loop
3759 if Container.Elements.EA (Indx) /= null
3760 and then Container.Elements.EA (Indx).all = Item
3770 if Result = No_Index then
3773 return Cursor'(Container
'Unrestricted_Access, Result
);
3784 ------------------------
3785 -- Reverse_Find_Index --
3786 ------------------------
3788 function Reverse_Find_Index
3789 (Container
: Vector
;
3790 Item
: Element_Type
;
3791 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
3793 B
: Natural renames Container
'Unrestricted_Access.Busy
;
3794 L
: Natural renames Container
'Unrestricted_Access.Lock
;
3796 Last
: constant Index_Type
'Base :=
3797 (if Index
> Container
.Last
then Container
.Last
else Index
);
3799 Result
: Index_Type
'Base;
3802 -- Per AI05-0022, the container implementation is required to detect
3803 -- element tampering by a generic actual subprogram.
3809 for Indx
in reverse Index_Type
'First .. Last
loop
3810 if Container
.Elements
.EA
(Indx
) /= null
3811 and then Container
.Elements
.EA
(Indx
).all = Item
3828 end Reverse_Find_Index
;
3830 ---------------------
3831 -- Reverse_Iterate --
3832 ---------------------
3834 procedure Reverse_Iterate
3835 (Container
: Vector
;
3836 Process
: not null access procedure (Position
: Cursor
))
3838 V
: Vector
renames Container
'Unrestricted_Access.all;
3839 B
: Natural renames V
.Busy
;
3845 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
3846 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
3855 end Reverse_Iterate;
3861 procedure Set_Length
3862 (Container : in out Vector;
3863 Length : Count_Type)
3865 Count : constant Count_Type'Base := Container.Length - Length;
3868 -- Set_Length allows the user to set the length explicitly, instead of
3869 -- implicitly as a side-effect of deletion or insertion. If the
3870 -- requested length is less than the current length, this is equivalent
3871 -- to deleting items from the back end of the vector. If the requested
3872 -- length is greater than the current length, then this is equivalent to
3873 -- inserting "space" (nonce items) at the end.
3876 Container.Delete_Last (Count);
3878 elsif Container.Last >= Index_Type'Last then
3879 raise Constraint_Error with "vector is already at its maximum length";
3882 Container.Insert_Space (Container.Last + 1, -Count);
3891 (Container : in out Vector;
3895 if I > Container.Last then
3896 raise Constraint_Error with "I index is out of range";
3899 if J > Container.Last then
3900 raise Constraint_Error with "J index is out of range";
3907 if Container.Lock > 0 then
3908 raise Program_Error with
3909 "attempt to tamper with elements (vector is locked)";
3913 EI : Element_Access renames Container.Elements.EA (I);
3914 EJ : Element_Access renames Container.Elements.EA (J);
3916 EI_Copy : constant Element_Access := EI;
3925 (Container : in out Vector;
3929 if I.Container = null then
3930 raise Constraint_Error with "I cursor has no element";
3933 if J.Container = null then
3934 raise Constraint_Error with "J cursor has no element";
3937 if I.Container /= Container'Unrestricted_Access then
3938 raise Program_Error with "I cursor denotes wrong container";
3941 if J.Container /= Container'Unrestricted_Access then
3942 raise Program_Error with "J cursor denotes wrong container";
3945 Swap (Container, I.Index, J.Index);
3953 (Container : Vector;
3954 Index : Extended_Index) return Cursor
3957 if Index not in Index_Type'First .. Container.Last then
3961 return Cursor'(Container
'Unrestricted_Access, Index
);
3968 function To_Index
(Position
: Cursor
) return Extended_Index
is
3970 if Position
.Container
= null then
3972 elsif Position
.Index
<= Position
.Container
.Last
then
3973 return Position
.Index
;
3983 function To_Vector
(Length
: Count_Type
) return Vector
is
3984 Index
: Count_Type
'Base;
3985 Last
: Index_Type
'Base;
3986 Elements
: Elements_Access
;
3990 return Empty_Vector
;
3993 -- We create a vector object with a capacity that matches the specified
3994 -- Length, but we do not allow the vector capacity (the length of the
3995 -- internal array) to exceed the number of values in Index_Type'Range
3996 -- (otherwise, there would be no way to refer to those components via an
3997 -- index). We must therefore check whether the specified Length would
3998 -- create a Last index value greater than Index_Type'Last.
4000 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
4002 -- We perform a two-part test. First we determine whether the
4003 -- computed Last value lies in the base range of the type, and then
4004 -- determine whether it lies in the range of the index (sub)type.
4006 -- Last must satisfy this relation:
4007 -- First + Length - 1 <= Last
4008 -- We regroup terms:
4009 -- First - 1 <= Last - Length
4010 -- Which can rewrite as:
4011 -- No_Index <= Last - Length
4013 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
4014 raise Constraint_Error
with "Length is out of range";
4017 -- We now know that the computed value of Last is within the base
4018 -- range of the type, so it is safe to compute its value:
4020 Last
:= No_Index
+ Index_Type
'Base (Length
);
4022 -- Finally we test whether the value is within the range of the
4023 -- generic actual index subtype:
4025 if Last
> Index_Type
'Last then
4026 raise Constraint_Error
with "Length is out of range";
4029 elsif Index_Type
'First <= 0 then
4031 -- Here we can compute Last directly, in the normal way. We know that
4032 -- No_Index is less than 0, so there is no danger of overflow when
4033 -- adding the (positive) value of Length.
4035 Index
:= Count_Type
'Base (No_Index
) + Length
; -- Last
4037 if Index
> Count_Type
'Base (Index_Type
'Last) then
4038 raise Constraint_Error
with "Length is out of range";
4041 -- We know that the computed value (having type Count_Type) of Last
4042 -- is within the range of the generic actual index subtype, so it is
4043 -- safe to convert to Index_Type:
4045 Last
:= Index_Type
'Base (Index
);
4048 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
4049 -- must test the length indirectly (by working backwards from the
4050 -- largest possible value of Last), in order to prevent overflow.
4052 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
4054 if Index
< Count_Type
'Base (No_Index
) then
4055 raise Constraint_Error
with "Length is out of range";
4058 -- We have determined that the value of Length would not create a
4059 -- Last index value outside of the range of Index_Type, so we can now
4060 -- safely compute its value.
4062 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
4065 Elements
:= new Elements_Type
(Last
);
4067 return Vector
'(Controlled with Elements, Last, 0, 0);
4071 (New_Item : Element_Type;
4072 Length : Count_Type) return Vector
4074 Index : Count_Type'Base;
4075 Last : Index_Type'Base;
4076 Elements : Elements_Access;
4080 return Empty_Vector;
4083 -- We create a vector object with a capacity that matches the specified
4084 -- Length, but we do not allow the vector capacity (the length of the
4085 -- internal array) to exceed the number of values in Index_Type'Range
4086 -- (otherwise, there would be no way to refer to those components via an
4087 -- index). We must therefore check whether the specified Length would
4088 -- create a Last index value greater than Index_Type'Last.
4090 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
4092 -- We perform a two-part test. First we determine whether the
4093 -- computed Last value lies in the base range of the type, and then
4094 -- determine whether it lies in the range of the index (sub)type.
4096 -- Last must satisfy this relation:
4097 -- First + Length - 1 <= Last
4098 -- We regroup terms:
4099 -- First - 1 <= Last - Length
4100 -- Which can rewrite as:
4101 -- No_Index <= Last - Length
4103 if Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index then
4104 raise Constraint_Error with "Length is out of range";
4107 -- We now know that the computed value of Last is within the base
4108 -- range of the type, so it is safe to compute its value:
4110 Last := No_Index + Index_Type'Base (Length);
4112 -- Finally we test whether the value is within the range of the
4113 -- generic actual index subtype:
4115 if Last > Index_Type'Last then
4116 raise Constraint_Error with "Length is out of range";
4119 elsif Index_Type'First <= 0 then
4121 -- Here we can compute Last directly, in the normal way. We know that
4122 -- No_Index is less than 0, so there is no danger of overflow when
4123 -- adding the (positive) value of Length.
4125 Index := Count_Type'Base (No_Index) + Length; -- Last
4127 if Index > Count_Type'Base (Index_Type'Last) then
4128 raise Constraint_Error with "Length is out of range";
4131 -- We know that the computed value (having type Count_Type) of Last
4132 -- is within the range of the generic actual index subtype, so it is
4133 -- safe to convert to Index_Type:
4135 Last := Index_Type'Base (Index);
4138 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
4139 -- must test the length indirectly (by working backwards from the
4140 -- largest possible value of Last), in order to prevent overflow.
4142 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
4144 if Index < Count_Type'Base (No_Index) then
4145 raise Constraint_Error with "Length is out of range";
4148 -- We have determined that the value of Length would not create a
4149 -- Last index value outside of the range of Index_Type, so we can now
4150 -- safely compute its value.
4152 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
4155 Elements := new Elements_Type (Last);
4157 -- We use Last as the index of the loop used to populate the internal
4158 -- array with items. In general, we prefer to initialize the loop index
4159 -- immediately prior to entering the loop. However, Last is also used in
4160 -- the exception handler (to reclaim elements that have been allocated,
4161 -- before propagating the exception), and the initialization of Last
4162 -- after entering the block containing the handler confuses some static
4163 -- analysis tools, with respect to whether Last has been properly
4164 -- initialized when the handler executes. So here we initialize our loop
4165 -- variable earlier than we prefer, before entering the block, so there
4168 Last := Index_Type'First;
4171 -- The element allocator may need an accessibility check in the case
4172 -- where the actual type is class-wide or has access discriminants
4173 -- (see RM 4.8(10.1) and AI12-0035).
4175 pragma Unsuppress (Accessibility_Check);
4179 Elements.EA (Last) := new Element_Type'(New_Item
);
4180 exit when Last
= Elements
.Last
;
4186 for J
in Index_Type
'First .. Last
- 1 loop
4187 Free
(Elements
.EA
(J
));
4194 return (Controlled
with Elements
, Last
, 0, 0);
4197 --------------------
4198 -- Update_Element --
4199 --------------------
4201 procedure Update_Element
4202 (Container
: in out Vector
;
4204 Process
: not null access procedure (Element
: in out Element_Type
))
4206 B
: Natural renames Container
.Busy
;
4207 L
: Natural renames Container
.Lock
;
4210 if Index
> Container
.Last
then
4211 raise Constraint_Error
with "Index is out of range";
4214 if Container
.Elements
.EA
(Index
) = null then
4215 raise Constraint_Error
with "element is null";
4222 Process
(Container
.Elements
.EA
(Index
).all);
4234 procedure Update_Element
4235 (Container
: in out Vector
;
4237 Process
: not null access procedure (Element
: in out Element_Type
))
4240 if Position
.Container
= null then
4241 raise Constraint_Error
with "Position cursor has no element";
4243 elsif Position
.Container
/= Container
'Unrestricted_Access then
4244 raise Program_Error
with "Position cursor denotes wrong container";
4247 Update_Element
(Container
, Position
.Index
, Process
);
4256 (Stream
: not null access Root_Stream_Type
'Class;
4259 N
: constant Count_Type
:= Length
(Container
);
4262 Count_Type
'Base'Write (Stream, N);
4269 E : Elements_Array renames Container.Elements.EA;
4272 for Indx in Index_Type'First .. Container.Last loop
4273 if E (Indx) = null then
4274 Boolean'Write (Stream, False);
4276 Boolean'Write (Stream, True);
4277 Element_Type'Output (Stream, E (Indx).all);
4284 (Stream : not null access Root_Stream_Type'Class;
4288 raise Program_Error with "attempt to stream vector cursor";
4292 (Stream : not null access Root_Stream_Type'Class;
4293 Item : Reference_Type)
4296 raise Program_Error with "attempt to stream reference";
4300 (Stream : not null access Root_Stream_Type'Class;
4301 Item : Constant_Reference_Type)
4304 raise Program_Error with "attempt to stream reference";
4307 end Ada.Containers.Indefinite_Vectors;