1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . V E C T O R S --
9 -- Copyright (C) 2004-2015, 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
.Vectors
is
37 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
38 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
39 -- See comment in Ada.Containers.Helpers
42 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
44 procedure Append_Slow_Path
45 (Container
: in out Vector
;
46 New_Item
: Element_Type
;
48 -- This is the slow path for Append. This is split out to minimize the size
49 -- of Append, because we have Inline (Append).
55 -- We decide that the capacity of the result of "&" is the minimum needed
56 -- -- the sum of the lengths of the vector parameters. We could decide to
57 -- make it larger, but we have no basis for knowing how much larger, so we
58 -- just allocate the minimum amount of storage.
60 function "&" (Left
, Right
: Vector
) return Vector
is
62 return Result
: Vector
do
63 Reserve_Capacity
(Result
, Length
(Left
) + Length
(Right
));
64 Append
(Result
, Left
);
65 Append
(Result
, Right
);
69 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
71 return Result
: Vector
do
72 Reserve_Capacity
(Result
, Length
(Left
) + 1);
73 Append
(Result
, Left
);
74 Append
(Result
, Right
);
78 function "&" (Left
: Element_Type
; Right
: Vector
) return Vector
is
80 return Result
: Vector
do
81 Reserve_Capacity
(Result
, 1 + Length
(Right
));
82 Append
(Result
, Left
);
83 Append
(Result
, Right
);
87 function "&" (Left
, Right
: Element_Type
) return Vector
is
89 return Result
: Vector
do
90 Reserve_Capacity
(Result
, 1 + 1);
91 Append
(Result
, Left
);
92 Append
(Result
, Right
);
100 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
102 if Left
.Last
/= Right
.Last
then
106 if Left
.Length
= 0 then
111 -- Per AI05-0022, the container implementation is required to detect
112 -- element tampering by a generic actual subprogram.
114 Lock_Left
: With_Lock
(Left
.TC
'Unrestricted_Access);
115 Lock_Right
: With_Lock
(Right
.TC
'Unrestricted_Access);
117 for J
in Index_Type
range Index_Type
'First .. Left
.Last
loop
118 if Left
.Elements
.EA
(J
) /= Right
.Elements
.EA
(J
) then
131 procedure Adjust
(Container
: in out Vector
) is
133 -- If the counts are nonzero, execution is technically erroneous, but
134 -- it seems friendly to allow things like concurrent "=" on shared
137 Zero_Counts
(Container
.TC
);
139 if Container
.Last
= No_Index
then
140 Container
.Elements
:= null;
145 L
: constant Index_Type
:= Container
.Last
;
146 EA
: Elements_Array
renames
147 Container
.Elements
.EA
(Index_Type
'First .. L
);
150 Container
.Elements
:= null;
152 -- Note: it may seem that the following assignment to Container.Last
153 -- is useless, since we assign it to L below. However this code is
154 -- used in case 'new Elements_Type' below raises an exception, to
155 -- keep Container in a consistent state.
157 Container
.Last
:= No_Index
;
158 Container
.Elements
:= new Elements_Type
'(L, EA);
167 procedure Append (Container : in out Vector; New_Item : Vector) is
169 if Is_Empty (New_Item) then
171 elsif Checks and then Container.Last = Index_Type'Last then
172 raise Constraint_Error with "vector is already at its maximum length";
174 Insert (Container, Container.Last + 1, New_Item);
179 (Container : in out Vector;
180 New_Item : Element_Type;
181 Count : Count_Type := 1)
184 -- In the general case, we pass the buck to Insert, but for efficiency,
185 -- we check for the usual case where Count = 1 and the vector has enough
186 -- room for at least one more element.
189 and then Container.Elements /= null
190 and then Container.Last /= Container.Elements.Last
192 TC_Check (Container.TC);
194 -- Increment Container.Last after assigning the New_Item, so we
195 -- leave the Container unmodified in case Finalize/Adjust raises
199 New_Last : constant Index_Type := Container.Last + 1;
201 Container.Elements.EA (New_Last) := New_Item;
202 Container.Last := New_Last;
206 Append_Slow_Path (Container, New_Item, Count);
210 ----------------------
211 -- Append_Slow_Path --
212 ----------------------
214 procedure Append_Slow_Path
215 (Container : in out Vector;
216 New_Item : Element_Type;
222 elsif Checks and then Container.Last = Index_Type'Last then
223 raise Constraint_Error with "vector is already at its maximum length";
225 Insert (Container, Container.Last + 1, New_Item, Count);
227 end Append_Slow_Path;
233 procedure Assign (Target : in out Vector; Source : Vector) is
235 if Target'Address = Source'Address then
239 Target.Append (Source);
247 function Capacity (Container : Vector) return Count_Type is
249 if Container.Elements = null then
252 return Container.Elements.EA'Length;
260 procedure Clear (Container : in out Vector) is
262 TC_Check (Container.TC);
263 Container.Last := No_Index;
266 ------------------------
267 -- Constant_Reference --
268 ------------------------
270 function Constant_Reference
271 (Container : aliased Vector;
272 Position : Cursor) return Constant_Reference_Type
276 if Position.Container = null then
277 raise Constraint_Error with "Position cursor has no element";
280 if Position.Container /= Container'Unrestricted_Access then
281 raise Program_Error with "Position cursor denotes wrong container";
284 if Position.Index > Position.Container.Last then
285 raise Constraint_Error with "Position cursor is out of range";
290 TC : constant Tamper_Counts_Access :=
291 Container.TC'Unrestricted_Access;
293 return R : constant Constant_Reference_Type :=
294 (Element => Container.Elements.EA (Position.Index)'Access,
295 Control => (Controlled with TC))
300 end Constant_Reference;
302 function Constant_Reference
303 (Container : aliased Vector;
304 Index : Index_Type) return Constant_Reference_Type
307 if Checks and then Index > Container.Last then
308 raise Constraint_Error with "Index is out of range";
312 TC : constant Tamper_Counts_Access :=
313 Container.TC'Unrestricted_Access;
315 return R : constant Constant_Reference_Type :=
316 (Element => Container.Elements.EA (Index)'Access,
317 Control => (Controlled with TC))
322 end Constant_Reference;
330 Item : Element_Type) return Boolean
333 return Find_Index (Container, Item) /= No_Index;
342 Capacity : Count_Type := 0) return Vector
347 if Capacity >= Source.Length then
353 if Checks and then Capacity /= 0 then
354 raise Capacity_Error with
355 "Requested capacity is less than Source length";
359 return Target : Vector do
360 Target.Reserve_Capacity (C);
361 Target.Assign (Source);
370 (Container : in out Vector;
371 Index : Extended_Index;
372 Count : Count_Type := 1)
374 Old_Last : constant Index_Type'Base := Container.Last;
375 New_Last : Index_Type'Base;
376 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
377 J : Index_Type'Base; -- first index of items that slide down
380 -- Delete removes items from the vector, the number of which is the
381 -- minimum of the specified Count and the items (if any) that exist from
382 -- Index to Container.Last. There are no constraints on the specified
383 -- value of Count (it can be larger than what's available at this
384 -- position in the vector, for example), but there are constraints on
385 -- the allowed values of the Index.
387 -- As a precondition on the generic actual Index_Type, the base type
388 -- must include Index_Type'Pred (Index_Type'First); this is the value
389 -- that Container.Last assumes when the vector is empty. However, we do
390 -- not allow that as the value for Index when specifying which items
391 -- should be deleted, so we must manually check. (That the user is
392 -- allowed to specify the value at all here is a consequence of the
393 -- declaration of the Extended_Index subtype, which includes the values
394 -- in the base range that immediately precede and immediately follow the
395 -- values in the Index_Type.)
397 if Checks and then Index < Index_Type'First then
398 raise Constraint_Error with "Index is out of range (too small)";
401 -- We do allow a value greater than Container.Last to be specified as
402 -- the Index, but only if it's immediately greater. This allows the
403 -- corner case of deleting no items from the back end of the vector to
404 -- be treated as a no-op. (It is assumed that specifying an index value
405 -- greater than Last + 1 indicates some deeper flaw in the caller's
406 -- algorithm, so that case is treated as a proper error.)
408 if Index > Old_Last then
409 if Checks and then Index > Old_Last + 1 then
410 raise Constraint_Error with "Index is out of range (too large)";
416 -- Here and elsewhere we treat deleting 0 items from the container as a
417 -- no-op, even when the container is busy, so we simply return.
423 -- The tampering bits exist to prevent an item from being deleted (or
424 -- otherwise harmfully manipulated) while it is being visited. Query,
425 -- Update, and Iterate increment the busy count on entry, and decrement
426 -- the count on exit. Delete checks the count to determine whether it is
427 -- being called while the associated callback procedure is executing.
429 TC_Check (Container.TC);
431 -- We first calculate what's available for deletion starting at
432 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
433 -- Count_Type'Base as the type for intermediate values. (See function
434 -- Length for more information.)
436 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
437 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
439 Count2 := Count_Type'Base (Old_Last - Index + 1);
442 -- If more elements are requested (Count) for deletion than are
443 -- available (Count2) for deletion beginning at Index, then everything
444 -- from Index is deleted. There are no elements to slide down, and so
445 -- all we need to do is set the value of Container.Last.
447 if Count >= Count2 then
448 Container.Last := Index - 1;
452 -- There are some elements that aren't being deleted (the requested
453 -- count was less than the available count), so we must slide them down
454 -- to Index. We first calculate the index values of the respective array
455 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
456 -- type for intermediate calculations. For the elements that slide down,
457 -- index value New_Last is the last index value of their new home, and
458 -- index value J is the first index of their old home.
460 if Index_Type'Base'Last
>= Count_Type_Last
then
461 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
462 J
:= Index
+ Index_Type
'Base (Count
);
464 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
465 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
468 -- The internal elements array isn't guaranteed to exist unless we have
469 -- elements, but we have that guarantee here because we know we have
470 -- elements to slide. The array index values for each slice have
471 -- already been determined, so we just slide down to Index the elements
472 -- that weren't deleted.
475 EA
: Elements_Array
renames Container
.Elements
.EA
;
477 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
478 Container
.Last
:= New_Last
;
483 (Container
: in out Vector
;
484 Position
: in out Cursor
;
485 Count
: Count_Type
:= 1)
489 if Position
.Container
= null then
490 raise Constraint_Error
with "Position cursor has no element";
492 elsif Position
.Container
/= Container
'Unrestricted_Access then
493 raise Program_Error
with "Position cursor denotes wrong container";
495 elsif Position
.Index
> Container
.Last
then
496 raise Program_Error
with "Position index is out of range";
500 Delete
(Container
, Position
.Index
, Count
);
501 Position
:= No_Element
;
508 procedure Delete_First
509 (Container
: in out Vector
;
510 Count
: Count_Type
:= 1)
516 elsif Count
>= Length
(Container
) then
521 Delete
(Container
, Index_Type
'First, Count
);
529 procedure Delete_Last
530 (Container
: in out Vector
;
531 Count
: Count_Type
:= 1)
534 -- It is not permitted to delete items while the container is busy (for
535 -- example, we're in the middle of a passive iteration). However, we
536 -- always treat deleting 0 items as a no-op, even when we're busy, so we
537 -- simply return without checking.
543 -- The tampering bits exist to prevent an item from being deleted (or
544 -- otherwise harmfully manipulated) while it is being visited. Query,
545 -- Update, and Iterate increment the busy count on entry, and decrement
546 -- the count on exit. Delete_Last checks the count to determine whether
547 -- it is being called while the associated callback procedure is
550 TC_Check
(Container
.TC
);
552 -- There is no restriction on how large Count can be when deleting
553 -- items. If it is equal or greater than the current length, then this
554 -- is equivalent to clearing the vector. (In particular, there's no need
555 -- for us to actually calculate the new value for Last.)
557 -- If the requested count is less than the current length, then we must
558 -- calculate the new value for Last. For the type we use the widest of
559 -- Index_Type'Base and Count_Type'Base for the intermediate values of
560 -- our calculation. (See the comments in Length for more information.)
562 if Count
>= Container
.Length
then
563 Container
.Last
:= No_Index
;
565 elsif Index_Type
'Base'Last >= Count_Type_Last then
566 Container.Last := Container.Last - Index_Type'Base (Count);
570 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
580 Index : Index_Type) return Element_Type
583 if Checks and then Index > Container.Last then
584 raise Constraint_Error with "Index is out of range";
587 return Container.Elements.EA (Index);
590 function Element (Position : Cursor) return Element_Type is
593 if Position.Container = null then
594 raise Constraint_Error with "Position cursor has no element";
595 elsif Position.Index > Position.Container.Last then
596 raise Constraint_Error with "Position cursor is out of range";
600 return Position.Container.Elements.EA (Position.Index);
607 procedure Finalize (Container : in out Vector) is
608 X : Elements_Access := Container.Elements;
611 Container.Elements := null;
612 Container.Last := No_Index;
616 TC_Check (Container.TC);
619 procedure Finalize (Object : in out Iterator) is
620 pragma Warnings (Off);
621 pragma Assert (T_Check); -- not called if check suppressed
622 pragma Warnings (On);
624 Unbusy (Object.Container.TC);
634 Position : Cursor := No_Element) return Cursor
637 if Checks and then Position.Container /= null then
638 if Position.Container /= Container'Unrestricted_Access then
639 raise Program_Error with "Position cursor denotes wrong container";
642 if Position.Index > Container.Last then
643 raise Program_Error with "Position index is out of range";
647 -- Per AI05-0022, the container implementation is required to detect
648 -- element tampering by a generic actual subprogram.
651 Lock : With_Lock (Container.TC'Unrestricted_Access);
653 for J in Position.Index .. Container.Last loop
654 if Container.Elements.EA (J) = Item then
655 return Cursor'(Container
'Unrestricted_Access, J
);
670 Index
: Index_Type
:= Index_Type
'First) return Extended_Index
672 -- Per AI05-0022, the container implementation is required to detect
673 -- element tampering by a generic actual subprogram.
675 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
677 for Indx
in Index
.. Container
.Last
loop
678 if Container
.Elements
.EA
(Indx
) = Item
then
690 function First
(Container
: Vector
) return Cursor
is
692 if Is_Empty
(Container
) then
696 return (Container
'Unrestricted_Access, Index_Type
'First);
699 function First
(Object
: Iterator
) return Cursor
is
701 -- The value of the iterator object's Index component influences the
702 -- behavior of the First (and Last) selector function.
704 -- When the Index component is No_Index, this means the iterator
705 -- object was constructed without a start expression, in which case the
706 -- (forward) iteration starts from the (logical) beginning of the entire
707 -- sequence of items (corresponding to Container.First, for a forward
710 -- Otherwise, this is iteration over a partial sequence of items.
711 -- When the Index component isn't No_Index, the iterator object was
712 -- constructed with a start expression, that specifies the position
713 -- from which the (forward) partial iteration begins.
715 if Object
.Index
= No_Index
then
716 return First
(Object
.Container
.all);
718 return Cursor
'(Object.Container, Object.Index);
726 function First_Element (Container : Vector) return Element_Type is
728 if Checks and then Container.Last = No_Index then
729 raise Constraint_Error with "Container is empty";
731 return Container.Elements.EA (Index_Type'First);
739 function First_Index (Container : Vector) return Index_Type is
740 pragma Unreferenced (Container);
742 return Index_Type'First;
745 ---------------------
746 -- Generic_Sorting --
747 ---------------------
749 package body Generic_Sorting is
755 function Is_Sorted (Container : Vector) return Boolean is
757 if Container.Last <= Index_Type'First then
761 -- Per AI05-0022, the container implementation is required to detect
762 -- element tampering by a generic actual subprogram.
765 Lock : With_Lock (Container.TC'Unrestricted_Access);
766 EA : Elements_Array renames Container.Elements.EA;
768 for J in Index_Type'First .. Container.Last - 1 loop
769 if EA (J + 1) < EA (J) then
782 procedure Merge (Target, Source : in out Vector) is
783 I : Index_Type'Base := Target.Last;
787 -- The semantics of Merge changed slightly per AI05-0021. It was
788 -- originally the case that if Target and Source denoted the same
789 -- container object, then the GNAT implementation of Merge did
790 -- nothing. However, it was argued that RM05 did not precisely
791 -- specify the semantics for this corner case. The decision of the
792 -- ARG was that if Target and Source denote the same non-empty
793 -- container object, then Program_Error is raised.
795 if Source.Last < Index_Type'First then -- Source is empty
799 if Checks and then Target'Address = Source'Address then
800 raise Program_Error with
801 "Target and Source denote same non-empty container";
804 if Target.Last < Index_Type'First then -- Target is empty
805 Move (Target => Target, Source => Source);
809 TC_Check (Source.TC);
811 Target.Set_Length (Length (Target) + Length (Source));
813 -- Per AI05-0022, the container implementation is required to detect
814 -- element tampering by a generic actual subprogram.
817 TA : Elements_Array renames Target.Elements.EA;
818 SA : Elements_Array renames Source.Elements.EA;
820 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
821 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
824 while Source.Last >= Index_Type'First loop
825 pragma Assert (Source.Last <= Index_Type'First
826 or else not (SA (Source.Last) <
827 SA (Source.Last - 1)));
829 if I < Index_Type'First then
830 TA (Index_Type'First .. J) :=
831 SA (Index_Type'First .. Source.Last);
833 Source.Last := No_Index;
837 pragma Assert (I <= Index_Type'First
838 or else not (TA (I) < TA (I - 1)));
840 if SA (Source.Last) < TA (I) then
845 TA (J) := SA (Source.Last);
846 Source.Last := Source.Last - 1;
858 procedure Sort (Container : in out Vector) is
860 new Generic_Array_Sort
861 (Index_Type => Index_Type,
862 Element_Type => Element_Type,
863 Array_Type => Elements_Array,
867 if Container.Last <= Index_Type'First then
871 -- The exception behavior for the vector container must match that
872 -- for the list container, so we check for cursor tampering here
873 -- (which will catch more things) instead of for element tampering
874 -- (which will catch fewer things). It's true that the elements of
875 -- this vector container could be safely moved around while (say) an
876 -- iteration is taking place (iteration only increments the busy
877 -- counter), and so technically all we would need here is a test for
878 -- element tampering (indicated by the lock counter), that's simply
879 -- an artifact of our array-based implementation. Logically Sort
880 -- requires a check for cursor tampering.
882 TC_Check (Container.TC);
884 -- Per AI05-0022, the container implementation is required to detect
885 -- element tampering by a generic actual subprogram.
888 Lock : With_Lock (Container.TC'Unchecked_Access);
890 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
896 ------------------------
897 -- Get_Element_Access --
898 ------------------------
900 function Get_Element_Access
901 (Position : Cursor) return not null Element_Access is
903 return Position.Container.Elements.EA (Position.Index)'Access;
904 end Get_Element_Access;
910 function Has_Element (Position : Cursor) return Boolean is
912 return Position /= No_Element;
920 (Container : in out Vector;
921 Before : Extended_Index;
922 New_Item : Element_Type;
923 Count : Count_Type := 1)
925 Old_Length : constant Count_Type := Container.Length;
927 Max_Length : Count_Type'Base; -- determined from range of Index_Type
928 New_Length : Count_Type'Base; -- sum of current length and Count
929 New_Last : Index_Type'Base; -- last index of vector after insertion
931 Index : Index_Type'Base; -- scratch for intermediate values
932 J : Count_Type'Base; -- scratch
934 New_Capacity : Count_Type'Base; -- length of new, expanded array
935 Dst_Last : Index_Type'Base; -- last index of new, expanded array
936 Dst : Elements_Access; -- new, expanded internal array
940 -- As a precondition on the generic actual Index_Type, the base type
941 -- must include Index_Type'Pred (Index_Type'First); this is the value
942 -- that Container.Last assumes when the vector is empty. However, we
943 -- do not allow that as the value for Index when specifying where the
944 -- new items should be inserted, so we must manually check. (That the
945 -- user is allowed to specify the value at all here is a consequence
946 -- of the declaration of the Extended_Index subtype, which includes
947 -- the values in the base range that immediately precede and
948 -- immediately follow the values in the Index_Type.)
950 if Before < Index_Type'First then
951 raise Constraint_Error with
952 "Before index is out of range (too small)";
955 -- We do allow a value greater than Container.Last to be specified as
956 -- the Index, but only if it's immediately greater. This allows for
957 -- the case of appending items to the back end of the vector. (It is
958 -- assumed that specifying an index value greater than Last + 1
959 -- indicates some deeper flaw in the caller's algorithm, so that case
960 -- is treated as a proper error.)
962 if Before > Container.Last + 1 then
963 raise Constraint_Error with
964 "Before index is out of range (too large)";
968 -- We treat inserting 0 items into the container as a no-op, even when
969 -- the container is busy, so we simply return.
975 -- There are two constraints we need to satisfy. The first constraint is
976 -- that a container cannot have more than Count_Type'Last elements, so
977 -- we must check the sum of the current length and the insertion count.
978 -- Note: we cannot simply add these values, because of the possibility
981 if Checks and then Old_Length > Count_Type'Last - Count then
982 raise Constraint_Error with "Count is out of range";
985 -- It is now safe compute the length of the new vector, without fear of
988 New_Length := Old_Length + Count;
990 -- The second constraint is that the new Last index value cannot exceed
991 -- Index_Type'Last. In each branch below, we calculate the maximum
992 -- length (computed from the range of values in Index_Type), and then
993 -- compare the new length to the maximum length. If the new length is
994 -- acceptable, then we compute the new last index from that.
996 if Index_Type'Base'Last
>= Count_Type_Last
then
998 -- We have to handle the case when there might be more values in the
999 -- range of Index_Type than in the range of Count_Type.
1001 if Index_Type
'First <= 0 then
1003 -- We know that No_Index (the same as Index_Type'First - 1) is
1004 -- less than 0, so it is safe to compute the following sum without
1005 -- fear of overflow.
1007 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
1009 if Index
<= Index_Type
'Last then
1011 -- We have determined that range of Index_Type has at least as
1012 -- many values as in Count_Type, so Count_Type'Last is the
1013 -- maximum number of items that are allowed.
1015 Max_Length
:= Count_Type
'Last;
1018 -- The range of Index_Type has fewer values than in Count_Type,
1019 -- so the maximum number of items is computed from the range of
1022 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1026 -- No_Index is equal or greater than 0, so we can safely compute
1027 -- the difference without fear of overflow (which we would have to
1028 -- worry about if No_Index were less than 0, but that case is
1031 if Index_Type
'Last - No_Index
>= Count_Type_Last
then
1032 -- We have determined that range of Index_Type has at least as
1033 -- many values as in Count_Type, so Count_Type'Last is the
1034 -- maximum number of items that are allowed.
1036 Max_Length
:= Count_Type
'Last;
1039 -- The range of Index_Type has fewer values than in Count_Type,
1040 -- so the maximum number of items is computed from the range of
1043 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1047 elsif Index_Type
'First <= 0 then
1049 -- We know that No_Index (the same as Index_Type'First - 1) is less
1050 -- than 0, so it is safe to compute the following sum without fear of
1053 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
1055 if J
<= Count_Type
'Base (Index_Type
'Last) then
1057 -- We have determined that range of Index_Type has at least as
1058 -- many values as in Count_Type, so Count_Type'Last is the maximum
1059 -- number of items that are allowed.
1061 Max_Length
:= Count_Type
'Last;
1064 -- The range of Index_Type has fewer values than Count_Type does,
1065 -- so the maximum number of items is computed from the range of
1069 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1073 -- No_Index is equal or greater than 0, so we can safely compute the
1074 -- difference without fear of overflow (which we would have to worry
1075 -- about if No_Index were less than 0, but that case is handled
1079 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1082 -- We have just computed the maximum length (number of items). We must
1083 -- now compare the requested length to the maximum length, as we do not
1084 -- allow a vector expand beyond the maximum (because that would create
1085 -- an internal array with a last index value greater than
1086 -- Index_Type'Last, with no way to index those elements).
1088 if Checks
and then New_Length
> Max_Length
then
1089 raise Constraint_Error
with "Count is out of range";
1092 -- New_Last is the last index value of the items in the container after
1093 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1094 -- compute its value from the New_Length.
1096 if Index_Type
'Base'Last >= Count_Type_Last then
1097 New_Last := No_Index + Index_Type'Base (New_Length);
1099 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1102 if Container.Elements = null then
1103 pragma Assert (Container.Last = No_Index);
1105 -- This is the simplest case, with which we must always begin: we're
1106 -- inserting items into an empty vector that hasn't allocated an
1107 -- internal array yet. Note that we don't need to check the busy bit
1108 -- here, because an empty container cannot be busy.
1110 -- In order to preserve container invariants, we allocate the new
1111 -- internal array first, before setting the Last index value, in case
1112 -- the allocation fails (which can happen either because there is no
1113 -- storage available, or because element initialization fails).
1115 Container.Elements := new Elements_Type'
1117 EA
=> (others => New_Item
));
1119 -- The allocation of the new, internal array succeeded, so it is now
1120 -- safe to update the Last index, restoring container invariants.
1122 Container
.Last
:= New_Last
;
1127 -- The tampering bits exist to prevent an item from being harmfully
1128 -- manipulated while it is being visited. Query, Update, and Iterate
1129 -- increment the busy count on entry, and decrement the count on
1130 -- exit. Insert checks the count to determine whether it is being called
1131 -- while the associated callback procedure is executing.
1133 TC_Check
(Container
.TC
);
1135 -- An internal array has already been allocated, so we must determine
1136 -- whether there is enough unused storage for the new items.
1138 if New_Length
<= Container
.Elements
.EA
'Length then
1140 -- In this case, we're inserting elements into a vector that has
1141 -- already allocated an internal array, and the existing array has
1142 -- enough unused storage for the new items.
1145 EA
: Elements_Array
renames Container
.Elements
.EA
;
1148 if Before
> Container
.Last
then
1150 -- The new items are being appended to the vector, so no
1151 -- sliding of existing elements is required.
1153 EA
(Before
.. New_Last
) := (others => New_Item
);
1156 -- The new items are being inserted before some existing
1157 -- elements, so we must slide the existing elements up to their
1158 -- new home. We use the wider of Index_Type'Base and
1159 -- Count_Type'Base as the type for intermediate index values.
1161 if Index_Type
'Base'Last >= Count_Type_Last then
1162 Index := Before + Index_Type'Base (Count);
1164 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1167 EA (Index .. New_Last) := EA (Before .. Container.Last);
1168 EA (Before .. Index - 1) := (others => New_Item);
1172 Container.Last := New_Last;
1176 -- In this case, we're inserting elements into a vector that has already
1177 -- allocated an internal array, but the existing array does not have
1178 -- enough storage, so we must allocate a new, longer array. In order to
1179 -- guarantee that the amortized insertion cost is O(1), we always
1180 -- allocate an array whose length is some power-of-two factor of the
1181 -- current array length. (The new array cannot have a length less than
1182 -- the New_Length of the container, but its last index value cannot be
1183 -- greater than Index_Type'Last.)
1185 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1186 while New_Capacity < New_Length loop
1187 if New_Capacity > Count_Type'Last / 2 then
1188 New_Capacity := Count_Type'Last;
1191 New_Capacity := 2 * New_Capacity;
1195 if New_Capacity > Max_Length then
1197 -- We have reached the limit of capacity, so no further expansion
1198 -- will occur. (This is not a problem, as there is never a need to
1199 -- have more capacity than the maximum container length.)
1201 New_Capacity := Max_Length;
1204 -- We have computed the length of the new internal array (and this is
1205 -- what "vector capacity" means), so use that to compute its last index.
1207 if Index_Type'Base'Last
>= Count_Type_Last
then
1208 Dst_Last
:= No_Index
+ Index_Type
'Base (New_Capacity
);
1211 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Capacity
);
1214 -- Now we allocate the new, longer internal array. If the allocation
1215 -- fails, we have not changed any container state, so no side-effect
1216 -- will occur as a result of propagating the exception.
1218 Dst
:= new Elements_Type
(Dst_Last
);
1220 -- We have our new internal array. All that needs to be done now is to
1221 -- copy the existing items (if any) from the old array (the "source"
1222 -- array, object SA below) to the new array (the "destination" array,
1223 -- object DA below), and then deallocate the old array.
1226 SA
: Elements_Array
renames Container
.Elements
.EA
; -- source
1227 DA
: Elements_Array
renames Dst
.EA
; -- destination
1230 DA
(Index_Type
'First .. Before
- 1) :=
1231 SA
(Index_Type
'First .. Before
- 1);
1233 if Before
> Container
.Last
then
1234 DA
(Before
.. New_Last
) := (others => New_Item
);
1237 -- The new items are being inserted before some existing elements,
1238 -- so we must slide the existing elements up to their new home.
1240 if Index_Type
'Base'Last >= Count_Type_Last then
1241 Index := Before + Index_Type'Base (Count);
1243 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1246 DA (Before .. Index - 1) := (others => New_Item);
1247 DA (Index .. New_Last) := SA (Before .. Container.Last);
1256 -- We have successfully copied the items onto the new array, so the
1257 -- final thing to do is deallocate the old array.
1260 X : Elements_Access := Container.Elements;
1263 -- We first isolate the old internal array, removing it from the
1264 -- container and replacing it with the new internal array, before we
1265 -- deallocate the old array (which can fail if finalization of
1266 -- elements propagates an exception).
1268 Container.Elements := Dst;
1269 Container.Last := New_Last;
1271 -- The container invariants have been restored, so it is now safe to
1272 -- attempt to deallocate the old array.
1279 (Container : in out Vector;
1280 Before : Extended_Index;
1283 N : constant Count_Type := Length (New_Item);
1284 J : Index_Type'Base;
1287 -- Use Insert_Space to create the "hole" (the destination slice) into
1288 -- which we copy the source items.
1290 Insert_Space (Container, Before, Count => N);
1294 -- There's nothing else to do here (vetting of parameters was
1295 -- performed already in Insert_Space), so we simply return.
1300 -- We calculate the last index value of the destination slice using the
1301 -- wider of Index_Type'Base and count_Type'Base.
1303 if Index_Type'Base'Last
>= Count_Type_Last
then
1304 J
:= (Before
- 1) + Index_Type
'Base (N
);
1306 J
:= Index_Type
'Base (Count_Type
'Base (Before
- 1) + N
);
1309 if Container
'Address /= New_Item
'Address then
1311 -- This is the simple case. New_Item denotes an object different
1312 -- from Container, so there's nothing special we need to do to copy
1313 -- the source items to their destination, because all of the source
1314 -- items are contiguous.
1316 Container
.Elements
.EA
(Before
.. J
) :=
1317 New_Item
.Elements
.EA
(Index_Type
'First .. New_Item
.Last
);
1322 -- New_Item denotes the same object as Container, so an insertion has
1323 -- potentially split the source items. The destination is always the
1324 -- range [Before, J], but the source is [Index_Type'First, Before) and
1325 -- (J, Container.Last]. We perform the copy in two steps, using each of
1326 -- the two slices of the source items.
1329 L
: constant Index_Type
'Base := Before
- 1;
1331 subtype Src_Index_Subtype
is Index_Type
'Base range
1332 Index_Type
'First .. L
;
1334 Src
: Elements_Array
renames
1335 Container
.Elements
.EA
(Src_Index_Subtype
);
1337 K
: Index_Type
'Base;
1340 -- We first copy the source items that precede the space we
1341 -- inserted. Index value K is the last index of that portion
1342 -- destination that receives this slice of the source. (If Before
1343 -- equals Index_Type'First, then this first source slice will be
1344 -- empty, which is harmless.)
1346 if Index_Type
'Base'Last >= Count_Type_Last then
1347 K := L + Index_Type'Base (Src'Length);
1349 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1352 Container.Elements.EA (Before .. K) := Src;
1354 if Src'Length = N then
1356 -- The new items were effectively appended to the container, so we
1357 -- have already copied all of the items that need to be copied.
1358 -- We return early here, even though the source slice below is
1359 -- empty (so the assignment would be harmless), because we want to
1360 -- avoid computing J + 1, which will overflow if J equals
1361 -- Index_Type'Base'Last
.
1368 -- Note that we want to avoid computing J + 1 here, in case J equals
1369 -- Index_Type'Base'Last. We prevent that by returning early above,
1370 -- immediately after copying the first slice of the source, and
1371 -- determining that this second slice of the source is empty.
1373 F
: constant Index_Type
'Base := J
+ 1;
1375 subtype Src_Index_Subtype
is Index_Type
'Base range
1376 F
.. Container
.Last
;
1378 Src
: Elements_Array
renames
1379 Container
.Elements
.EA
(Src_Index_Subtype
);
1381 K
: Index_Type
'Base;
1384 -- We next copy the source items that follow the space we inserted.
1385 -- Index value K is the first index of that portion of the
1386 -- destination that receives this slice of the source. (For the
1387 -- reasons given above, this slice is guaranteed to be non-empty.)
1389 if Index_Type
'Base'Last >= Count_Type_Last then
1390 K := F - Index_Type'Base (Src'Length);
1392 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1395 Container.Elements.EA (K .. J) := Src;
1400 (Container : in out Vector;
1404 Index : Index_Type'Base;
1407 if Checks and then Before.Container /= null
1408 and then Before.Container /= Container'Unrestricted_Access
1410 raise Program_Error with "Before cursor denotes wrong container";
1413 if Is_Empty (New_Item) then
1417 if Before.Container = null or else Before.Index > Container.Last then
1418 if Checks and then Container.Last = Index_Type'Last then
1419 raise Constraint_Error with
1420 "vector is already at its maximum length";
1423 Index := Container.Last + 1;
1426 Index := Before.Index;
1429 Insert (Container, Index, New_Item);
1433 (Container : in out Vector;
1436 Position : out Cursor)
1438 Index : Index_Type'Base;
1441 if Checks and then Before.Container /= null
1442 and then Before.Container /= Container'Unrestricted_Access
1444 raise Program_Error with "Before cursor denotes wrong container";
1447 if Is_Empty (New_Item) then
1448 if Before.Container = null or else Before.Index > Container.Last then
1449 Position := No_Element;
1451 Position := (Container'Unrestricted_Access, Before.Index);
1457 if Before.Container = null or else Before.Index > Container.Last then
1458 if Checks and then Container.Last = Index_Type'Last then
1459 raise Constraint_Error with
1460 "vector is already at its maximum length";
1463 Index := Container.Last + 1;
1466 Index := Before.Index;
1469 Insert (Container, Index, New_Item);
1471 Position := (Container'Unrestricted_Access, Index);
1475 (Container : in out Vector;
1477 New_Item : Element_Type;
1478 Count : Count_Type := 1)
1480 Index : Index_Type'Base;
1483 if Checks and then Before.Container /= null
1484 and then Before.Container /= Container'Unrestricted_Access
1486 raise Program_Error with "Before cursor denotes wrong container";
1493 if Before.Container = null or else Before.Index > Container.Last then
1494 if Checks and then Container.Last = Index_Type'Last then
1495 raise Constraint_Error with
1496 "vector is already at its maximum length";
1498 Index := Container.Last + 1;
1502 Index := Before.Index;
1505 Insert (Container, Index, New_Item, Count);
1509 (Container : in out Vector;
1511 New_Item : Element_Type;
1512 Position : out Cursor;
1513 Count : Count_Type := 1)
1515 Index : Index_Type'Base;
1518 if Checks and then Before.Container /= null
1519 and then Before.Container /= Container'Unrestricted_Access
1521 raise Program_Error with "Before cursor denotes wrong container";
1525 if Before.Container = null or else Before.Index > Container.Last then
1526 Position := No_Element;
1528 Position := (Container'Unrestricted_Access, Before.Index);
1534 if Before.Container = null or else Before.Index > Container.Last then
1535 if Checks and then Container.Last = Index_Type'Last then
1536 raise Constraint_Error with
1537 "vector is already at its maximum length";
1540 Index := Container.Last + 1;
1543 Index := Before.Index;
1546 Insert (Container, Index, New_Item, Count);
1548 Position := (Container'Unrestricted_Access, Index);
1552 (Container : in out Vector;
1553 Before : Extended_Index;
1554 Count : Count_Type := 1)
1556 New_Item : Element_Type; -- Default-initialized value
1557 pragma Warnings (Off, New_Item);
1560 Insert (Container, Before, New_Item, Count);
1564 (Container : in out Vector;
1566 Position : out Cursor;
1567 Count : Count_Type := 1)
1569 New_Item : Element_Type; -- Default-initialized value
1570 pragma Warnings (Off, New_Item);
1572 Insert (Container, Before, New_Item, Position, Count);
1579 procedure Insert_Space
1580 (Container : in out Vector;
1581 Before : Extended_Index;
1582 Count : Count_Type := 1)
1584 Old_Length : constant Count_Type := Container.Length;
1586 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1587 New_Length : Count_Type'Base; -- sum of current length and Count
1588 New_Last : Index_Type'Base; -- last index of vector after insertion
1590 Index : Index_Type'Base; -- scratch for intermediate values
1591 J : Count_Type'Base; -- scratch
1593 New_Capacity : Count_Type'Base; -- length of new, expanded array
1594 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1595 Dst : Elements_Access; -- new, expanded internal array
1599 -- As a precondition on the generic actual Index_Type, the base type
1600 -- must include Index_Type'Pred (Index_Type'First); this is the value
1601 -- that Container.Last assumes when the vector is empty. However, we
1602 -- do not allow that as the value for Index when specifying where the
1603 -- new items should be inserted, so we must manually check. (That the
1604 -- user is allowed to specify the value at all here is a consequence
1605 -- of the declaration of the Extended_Index subtype, which includes
1606 -- the values in the base range that immediately precede and
1607 -- immediately follow the values in the Index_Type.)
1609 if Before < Index_Type'First then
1610 raise Constraint_Error with
1611 "Before index is out of range (too small)";
1614 -- We do allow a value greater than Container.Last to be specified as
1615 -- the Index, but only if it's immediately greater. This allows for
1616 -- the case of appending items to the back end of the vector. (It is
1617 -- assumed that specifying an index value greater than Last + 1
1618 -- indicates some deeper flaw in the caller's algorithm, so that case
1619 -- is treated as a proper error.)
1621 if Before > Container.Last + 1 then
1622 raise Constraint_Error with
1623 "Before index is out of range (too large)";
1627 -- We treat inserting 0 items into the container as a no-op, even when
1628 -- the container is busy, so we simply return.
1634 -- There are two constraints we need to satisfy. The first constraint is
1635 -- that a container cannot have more than Count_Type'Last elements, so
1636 -- we must check the sum of the current length and the insertion count.
1637 -- Note: we cannot simply add these values, because of the possibility
1640 if Checks and then Old_Length > Count_Type'Last - Count then
1641 raise Constraint_Error with "Count is out of range";
1644 -- It is now safe compute the length of the new vector, without fear of
1647 New_Length := Old_Length + Count;
1649 -- The second constraint is that the new Last index value cannot exceed
1650 -- Index_Type'Last. In each branch below, we calculate the maximum
1651 -- length (computed from the range of values in Index_Type), and then
1652 -- compare the new length to the maximum length. If the new length is
1653 -- acceptable, then we compute the new last index from that.
1655 if Index_Type'Base'Last
>= Count_Type_Last
then
1656 -- We have to handle the case when there might be more values in the
1657 -- range of Index_Type than in the range of Count_Type.
1659 if Index_Type
'First <= 0 then
1661 -- We know that No_Index (the same as Index_Type'First - 1) is
1662 -- less than 0, so it is safe to compute the following sum without
1663 -- fear of overflow.
1665 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
1667 if Index
<= Index_Type
'Last then
1669 -- We have determined that range of Index_Type has at least as
1670 -- many values as in Count_Type, so Count_Type'Last is the
1671 -- maximum number of items that are allowed.
1673 Max_Length
:= Count_Type
'Last;
1676 -- The range of Index_Type has fewer values than in Count_Type,
1677 -- so the maximum number of items is computed from the range of
1680 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1684 -- No_Index is equal or greater than 0, so we can safely compute
1685 -- the difference without fear of overflow (which we would have to
1686 -- worry about if No_Index were less than 0, but that case is
1689 if Index_Type
'Last - No_Index
>= Count_Type_Last
then
1690 -- We have determined that range of Index_Type has at least as
1691 -- many values as in Count_Type, so Count_Type'Last is the
1692 -- maximum number of items that are allowed.
1694 Max_Length
:= Count_Type
'Last;
1697 -- The range of Index_Type has fewer values than in Count_Type,
1698 -- so the maximum number of items is computed from the range of
1701 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1705 elsif Index_Type
'First <= 0 then
1707 -- We know that No_Index (the same as Index_Type'First - 1) is less
1708 -- than 0, so it is safe to compute the following sum without fear of
1711 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
1713 if J
<= Count_Type
'Base (Index_Type
'Last) then
1715 -- We have determined that range of Index_Type has at least as
1716 -- many values as in Count_Type, so Count_Type'Last is the maximum
1717 -- number of items that are allowed.
1719 Max_Length
:= Count_Type
'Last;
1722 -- The range of Index_Type has fewer values than Count_Type does,
1723 -- so the maximum number of items is computed from the range of
1727 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1731 -- No_Index is equal or greater than 0, so we can safely compute the
1732 -- difference without fear of overflow (which we would have to worry
1733 -- about if No_Index were less than 0, but that case is handled
1737 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1740 -- We have just computed the maximum length (number of items). We must
1741 -- now compare the requested length to the maximum length, as we do not
1742 -- allow a vector expand beyond the maximum (because that would create
1743 -- an internal array with a last index value greater than
1744 -- Index_Type'Last, with no way to index those elements).
1746 if Checks
and then New_Length
> Max_Length
then
1747 raise Constraint_Error
with "Count is out of range";
1750 -- New_Last is the last index value of the items in the container after
1751 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1752 -- compute its value from the New_Length.
1754 if Index_Type
'Base'Last >= Count_Type_Last then
1755 New_Last := No_Index + Index_Type'Base (New_Length);
1757 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1760 if Container.Elements = null then
1761 pragma Assert (Container.Last = No_Index);
1763 -- This is the simplest case, with which we must always begin: we're
1764 -- inserting items into an empty vector that hasn't allocated an
1765 -- internal array yet. Note that we don't need to check the busy bit
1766 -- here, because an empty container cannot be busy.
1768 -- In order to preserve container invariants, we allocate the new
1769 -- internal array first, before setting the Last index value, in case
1770 -- the allocation fails (which can happen either because there is no
1771 -- storage available, or because default-valued element
1772 -- initialization fails).
1774 Container.Elements := new Elements_Type (New_Last);
1776 -- The allocation of the new, internal array succeeded, so it is now
1777 -- safe to update the Last index, restoring container invariants.
1779 Container.Last := New_Last;
1784 -- The tampering bits exist to prevent an item from being harmfully
1785 -- manipulated while it is being visited. Query, Update, and Iterate
1786 -- increment the busy count on entry, and decrement the count on
1787 -- exit. Insert checks the count to determine whether it is being called
1788 -- while the associated callback procedure is executing.
1790 TC_Check (Container.TC);
1792 -- An internal array has already been allocated, so we must determine
1793 -- whether there is enough unused storage for the new items.
1795 if New_Last <= Container.Elements.Last then
1797 -- In this case, we're inserting space into a vector that has already
1798 -- allocated an internal array, and the existing array has enough
1799 -- unused storage for the new items.
1802 EA : Elements_Array renames Container.Elements.EA;
1805 if Before <= Container.Last then
1807 -- The space is being inserted before some existing elements,
1808 -- so we must slide the existing elements up to their new
1809 -- home. We use the wider of Index_Type'Base and
1810 -- Count_Type'Base as the type for intermediate index values.
1812 if Index_Type'Base'Last
>= Count_Type_Last
then
1813 Index
:= Before
+ Index_Type
'Base (Count
);
1816 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
1819 EA
(Index
.. New_Last
) := EA
(Before
.. Container
.Last
);
1823 Container
.Last
:= New_Last
;
1827 -- In this case, we're inserting space into a vector that has already
1828 -- allocated an internal array, but the existing array does not have
1829 -- enough storage, so we must allocate a new, longer array. In order to
1830 -- guarantee that the amortized insertion cost is O(1), we always
1831 -- allocate an array whose length is some power-of-two factor of the
1832 -- current array length. (The new array cannot have a length less than
1833 -- the New_Length of the container, but its last index value cannot be
1834 -- greater than Index_Type'Last.)
1836 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
1837 while New_Capacity
< New_Length
loop
1838 if New_Capacity
> Count_Type
'Last / 2 then
1839 New_Capacity
:= Count_Type
'Last;
1843 New_Capacity
:= 2 * New_Capacity
;
1846 if New_Capacity
> Max_Length
then
1848 -- We have reached the limit of capacity, so no further expansion
1849 -- will occur. (This is not a problem, as there is never a need to
1850 -- have more capacity than the maximum container length.)
1852 New_Capacity
:= Max_Length
;
1855 -- We have computed the length of the new internal array (and this is
1856 -- what "vector capacity" means), so use that to compute its last index.
1858 if Index_Type
'Base'Last >= Count_Type_Last then
1859 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1862 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1865 -- Now we allocate the new, longer internal array. If the allocation
1866 -- fails, we have not changed any container state, so no side-effect
1867 -- will occur as a result of propagating the exception.
1869 Dst := new Elements_Type (Dst_Last);
1871 -- We have our new internal array. All that needs to be done now is to
1872 -- copy the existing items (if any) from the old array (the "source"
1873 -- array, object SA below) to the new array (the "destination" array,
1874 -- object DA below), and then deallocate the old array.
1877 SA : Elements_Array renames Container.Elements.EA; -- source
1878 DA : Elements_Array renames Dst.EA; -- destination
1881 DA (Index_Type'First .. Before - 1) :=
1882 SA (Index_Type'First .. Before - 1);
1884 if Before <= Container.Last then
1886 -- The space is being inserted before some existing elements, so
1887 -- we must slide the existing elements up to their new home.
1889 if Index_Type'Base'Last
>= Count_Type_Last
then
1890 Index
:= Before
+ Index_Type
'Base (Count
);
1892 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
1895 DA
(Index
.. New_Last
) := SA
(Before
.. Container
.Last
);
1904 -- We have successfully copied the items onto the new array, so the
1905 -- final thing to do is restore invariants, and deallocate the old
1909 X
: Elements_Access
:= Container
.Elements
;
1912 -- We first isolate the old internal array, removing it from the
1913 -- container and replacing it with the new internal array, before we
1914 -- deallocate the old array (which can fail if finalization of
1915 -- elements propagates an exception).
1917 Container
.Elements
:= Dst
;
1918 Container
.Last
:= New_Last
;
1920 -- The container invariants have been restored, so it is now safe to
1921 -- attempt to deallocate the old array.
1927 procedure Insert_Space
1928 (Container
: in out Vector
;
1930 Position
: out Cursor
;
1931 Count
: Count_Type
:= 1)
1933 Index
: Index_Type
'Base;
1936 if Checks
and then Before
.Container
/= null
1937 and then Before
.Container
/= Container
'Unrestricted_Access
1939 raise Program_Error
with "Before cursor denotes wrong container";
1943 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
1944 Position
:= No_Element
;
1946 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
1952 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
1953 if Checks
and then Container
.Last
= Index_Type
'Last then
1954 raise Constraint_Error
with
1955 "vector is already at its maximum length";
1957 Index
:= Container
.Last
+ 1;
1961 Index
:= Before
.Index
;
1964 Insert_Space
(Container
, Index
, Count
);
1966 Position
:= (Container
'Unrestricted_Access, Index
);
1973 function Is_Empty
(Container
: Vector
) return Boolean is
1975 return Container
.Last
< Index_Type
'First;
1983 (Container
: Vector
;
1984 Process
: not null access procedure (Position
: Cursor
))
1986 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
1988 for Indx
in Index_Type
'First .. Container
.Last
loop
1989 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
1994 (Container : Vector)
1995 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
1997 V : constant Vector_Access := Container'Unrestricted_Access;
1999 -- The value of its Index component influences the behavior of the First
2000 -- and Last selector functions of the iterator object. When the Index
2001 -- component is No_Index (as is the case here), this means the iterator
2002 -- object was constructed without a start expression. This is a complete
2003 -- iterator, meaning that the iteration starts from the (logical)
2004 -- beginning of the sequence of items.
2006 -- Note: For a forward iterator, Container.First is the beginning, and
2007 -- for a reverse iterator, Container.Last is the beginning.
2009 return It : constant Iterator :=
2010 (Limited_Controlled with
2014 Busy (Container.TC'Unrestricted_Access.all);
2019 (Container : Vector;
2021 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2023 V : constant Vector_Access := Container'Unrestricted_Access;
2025 -- It was formerly the case that when Start = No_Element, the partial
2026 -- iterator was defined to behave the same as for a complete iterator,
2027 -- and iterate over the entire sequence of items. However, those
2028 -- semantics were unintuitive and arguably error-prone (it is too easy
2029 -- to accidentally create an endless loop), and so they were changed,
2030 -- per the ARG meeting in Denver on 2011/11. However, there was no
2031 -- consensus about what positive meaning this corner case should have,
2032 -- and so it was decided to simply raise an exception. This does imply,
2033 -- however, that it is not possible to use a partial iterator to specify
2034 -- an empty sequence of items.
2037 if Start.Container = null then
2038 raise Constraint_Error with
2039 "Start position for iterator equals No_Element";
2042 if Start.Container /= V then
2043 raise Program_Error with
2044 "Start cursor of Iterate designates wrong vector";
2047 if Start.Index > V.Last then
2048 raise Constraint_Error with
2049 "Start position for iterator equals No_Element";
2053 -- The value of its Index component influences the behavior of the First
2054 -- and Last selector functions of the iterator object. When the Index
2055 -- component is not No_Index (as is the case here), it means that this
2056 -- is a partial iteration, over a subset of the complete sequence of
2057 -- items. The iterator object was constructed with a start expression,
2058 -- indicating the position from which the iteration begins. Note that
2059 -- the start position has the same value irrespective of whether this
2060 -- is a forward or reverse iteration.
2062 return It : constant Iterator :=
2063 (Limited_Controlled with
2065 Index => Start.Index)
2067 Busy (Container.TC'Unrestricted_Access.all);
2075 function Last (Container : Vector) return Cursor is
2077 if Is_Empty (Container) then
2080 return (Container'Unrestricted_Access, Container.Last);
2084 function Last (Object : Iterator) return Cursor is
2086 -- The value of the iterator object's Index component influences the
2087 -- behavior of the Last (and First) selector function.
2089 -- When the Index component is No_Index, this means the iterator
2090 -- object was constructed without a start expression, in which case the
2091 -- (reverse) iteration starts from the (logical) beginning of the entire
2092 -- sequence (corresponding to Container.Last, for a reverse iterator).
2094 -- Otherwise, this is iteration over a partial sequence of items.
2095 -- When the Index component is not No_Index, the iterator object was
2096 -- constructed with a start expression, that specifies the position
2097 -- from which the (reverse) partial iteration begins.
2099 if Object.Index = No_Index then
2100 return Last (Object.Container.all);
2102 return Cursor'(Object
.Container
, Object
.Index
);
2110 function Last_Element
(Container
: Vector
) return Element_Type
is
2112 if Checks
and then Container
.Last
= No_Index
then
2113 raise Constraint_Error
with "Container is empty";
2115 return Container
.Elements
.EA
(Container
.Last
);
2123 function Last_Index
(Container
: Vector
) return Extended_Index
is
2125 return Container
.Last
;
2132 function Length
(Container
: Vector
) return Count_Type
is
2133 L
: constant Index_Type
'Base := Container
.Last
;
2134 F
: constant Index_Type
:= Index_Type
'First;
2137 -- The base range of the index type (Index_Type'Base) might not include
2138 -- all values for length (Count_Type). Contrariwise, the index type
2139 -- might include values outside the range of length. Hence we use
2140 -- whatever type is wider for intermediate values when calculating
2141 -- length. Note that no matter what the index type is, the maximum
2142 -- length to which a vector is allowed to grow is always the minimum
2143 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2145 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2146 -- to have a base range of -128 .. 127, but the corresponding vector
2147 -- would have lengths in the range 0 .. 255. In this case we would need
2148 -- to use Count_Type'Base for intermediate values.
2150 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2151 -- vector would have a maximum length of 10, but the index values lie
2152 -- outside the range of Count_Type (which is only 32 bits). In this
2153 -- case we would need to use Index_Type'Base for intermediate values.
2155 if Count_Type
'Base'Last >= Index_Type'Pos (Index_Type'Base'Last
) then
2156 return Count_Type
'Base (L
) - Count_Type
'Base (F
) + 1;
2158 return Count_Type
(L
- F
+ 1);
2167 (Target
: in out Vector
;
2168 Source
: in out Vector
)
2171 if Target
'Address = Source
'Address then
2175 TC_Check
(Target
.TC
);
2176 TC_Check
(Source
.TC
);
2179 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
2181 Target
.Elements
:= Source
.Elements
;
2182 Source
.Elements
:= Target_Elements
;
2185 Target
.Last
:= Source
.Last
;
2186 Source
.Last
:= No_Index
;
2193 function Next
(Position
: Cursor
) return Cursor
is
2195 if Position
.Container
= null then
2197 elsif Position
.Index
< Position
.Container
.Last
then
2198 return (Position
.Container
, Position
.Index
+ 1);
2204 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2206 if Position
.Container
= null then
2208 elsif Checks
and then Position
.Container
/= Object
.Container
then
2209 raise Program_Error
with
2210 "Position cursor of Next designates wrong vector";
2212 return Next
(Position
);
2216 procedure Next
(Position
: in out Cursor
) is
2218 if Position
.Container
= null then
2220 elsif Position
.Index
< Position
.Container
.Last
then
2221 Position
.Index
:= Position
.Index
+ 1;
2223 Position
:= No_Element
;
2231 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
2233 Insert
(Container
, Index_Type
'First, New_Item
);
2237 (Container
: in out Vector
;
2238 New_Item
: Element_Type
;
2239 Count
: Count_Type
:= 1)
2242 Insert
(Container
, Index_Type
'First, New_Item
, Count
);
2249 function Previous
(Position
: Cursor
) return Cursor
is
2251 if Position
.Container
= null then
2253 elsif Position
.Index
> Index_Type
'First then
2254 return (Position
.Container
, Position
.Index
- 1);
2260 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2262 if Position
.Container
= null then
2264 elsif Checks
and then Position
.Container
/= Object
.Container
then
2265 raise Program_Error
with
2266 "Position cursor of Previous designates wrong vector";
2268 return Previous
(Position
);
2272 procedure Previous
(Position
: in out Cursor
) is
2274 if Position
.Container
= null then
2276 elsif Position
.Index
> Index_Type
'First then
2277 Position
.Index
:= Position
.Index
- 1;
2279 Position
:= No_Element
;
2283 ----------------------
2284 -- Pseudo_Reference --
2285 ----------------------
2287 function Pseudo_Reference
2288 (Container
: aliased Vector
'Class) return Reference_Control_Type
2290 TC
: constant Tamper_Counts_Access
:= Container
.TC
'Unrestricted_Access;
2292 return R
: constant Reference_Control_Type
:= (Controlled
with TC
) do
2295 end Pseudo_Reference
;
2301 procedure Query_Element
2302 (Container
: Vector
;
2304 Process
: not null access procedure (Element
: Element_Type
))
2306 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
2307 V
: Vector
renames Container
'Unrestricted_Access.all;
2310 if Checks
and then Index
> Container
.Last
then
2311 raise Constraint_Error
with "Index is out of range";
2314 Process
(V
.Elements
.EA
(Index
));
2317 procedure Query_Element
2319 Process
: not null access procedure (Element
: Element_Type
))
2322 if Checks
and then Position
.Container
= null then
2323 raise Constraint_Error
with "Position cursor has no element";
2325 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
2334 (Stream
: not null access Root_Stream_Type
'Class;
2335 Container
: out Vector
)
2337 Length
: Count_Type
'Base;
2338 Last
: Index_Type
'Base := No_Index
;
2343 Count_Type
'Base'Read (Stream, Length);
2345 if Length > Capacity (Container) then
2346 Reserve_Capacity (Container, Capacity => Length);
2349 for J in Count_Type range 1 .. Length loop
2351 Element_Type'Read (Stream, Container.Elements.EA (Last));
2352 Container.Last := Last;
2357 (Stream : not null access Root_Stream_Type'Class;
2358 Position : out Cursor)
2361 raise Program_Error with "attempt to stream vector cursor";
2365 (Stream : not null access Root_Stream_Type'Class;
2366 Item : out Reference_Type)
2369 raise Program_Error with "attempt to stream reference";
2373 (Stream : not null access Root_Stream_Type'Class;
2374 Item : out Constant_Reference_Type)
2377 raise Program_Error with "attempt to stream reference";
2385 (Container : aliased in out Vector;
2386 Position : Cursor) return Reference_Type
2390 if Position.Container = null then
2391 raise Constraint_Error with "Position cursor has no element";
2394 if Position.Container /= Container'Unrestricted_Access then
2395 raise Program_Error with "Position cursor denotes wrong container";
2398 if Position.Index > Position.Container.Last then
2399 raise Constraint_Error with "Position cursor is out of range";
2404 TC : constant Tamper_Counts_Access :=
2405 Container.TC'Unrestricted_Access;
2407 return R : constant Reference_Type :=
2408 (Element => Container.Elements.EA (Position.Index)'Access,
2409 Control => (Controlled with TC))
2417 (Container : aliased in out Vector;
2418 Index : Index_Type) return Reference_Type
2421 if Checks and then Index > Container.Last then
2422 raise Constraint_Error with "Index is out of range";
2426 TC : constant Tamper_Counts_Access :=
2427 Container.TC'Unrestricted_Access;
2429 return R : constant Reference_Type :=
2430 (Element => Container.Elements.EA (Index)'Access,
2431 Control => (Controlled with TC))
2438 ---------------------
2439 -- Replace_Element --
2440 ---------------------
2442 procedure Replace_Element
2443 (Container : in out Vector;
2445 New_Item : Element_Type)
2448 if Checks and then Index > Container.Last then
2449 raise Constraint_Error with "Index is out of range";
2452 TE_Check (Container.TC);
2453 Container.Elements.EA (Index) := New_Item;
2454 end Replace_Element;
2456 procedure Replace_Element
2457 (Container : in out Vector;
2459 New_Item : Element_Type)
2463 if Position.Container = null then
2464 raise Constraint_Error with "Position cursor has no element";
2466 elsif Position.Container /= Container'Unrestricted_Access then
2467 raise Program_Error with "Position cursor denotes wrong container";
2469 elsif Position.Index > Container.Last then
2470 raise Constraint_Error with "Position cursor is out of range";
2474 TE_Check (Container.TC);
2475 Container.Elements.EA (Position.Index) := New_Item;
2476 end Replace_Element;
2478 ----------------------
2479 -- Reserve_Capacity --
2480 ----------------------
2482 procedure Reserve_Capacity
2483 (Container : in out Vector;
2484 Capacity : Count_Type)
2486 N : constant Count_Type := Length (Container);
2488 Index : Count_Type'Base;
2489 Last : Index_Type'Base;
2492 -- Reserve_Capacity can be used to either expand the storage available
2493 -- for elements (this would be its typical use, in anticipation of
2494 -- future insertion), or to trim back storage. In the latter case,
2495 -- storage can only be trimmed back to the limit of the container
2496 -- length. Note that Reserve_Capacity neither deletes (active) elements
2497 -- nor inserts elements; it only affects container capacity, never
2498 -- container length.
2500 if Capacity = 0 then
2502 -- This is a request to trim back storage, to the minimum amount
2503 -- possible given the current state of the container.
2507 -- The container is empty, so in this unique case we can
2508 -- deallocate the entire internal array. Note that an empty
2509 -- container can never be busy, so there's no need to check the
2513 X : Elements_Access := Container.Elements;
2516 -- First we remove the internal array from the container, to
2517 -- handle the case when the deallocation raises an exception.
2519 Container.Elements := null;
2521 -- Container invariants have been restored, so it is now safe
2522 -- to attempt to deallocate the internal array.
2527 elsif N < Container.Elements.EA'Length then
2529 -- The container is not empty, and the current length is less than
2530 -- the current capacity, so there's storage available to trim. In
2531 -- this case, we allocate a new internal array having a length
2532 -- that exactly matches the number of items in the
2533 -- container. (Reserve_Capacity does not delete active elements,
2534 -- so this is the best we can do with respect to minimizing
2537 TC_Check (Container.TC);
2540 subtype Src_Index_Subtype is Index_Type'Base range
2541 Index_Type'First .. Container.Last;
2543 Src : Elements_Array renames
2544 Container.Elements.EA (Src_Index_Subtype);
2546 X : Elements_Access := Container.Elements;
2549 -- Although we have isolated the old internal array that we're
2550 -- going to deallocate, we don't deallocate it until we have
2551 -- successfully allocated a new one. If there is an exception
2552 -- during allocation (either because there is not enough
2553 -- storage, or because initialization of the elements fails),
2554 -- we let it propagate without causing any side-effect.
2556 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
2558 -- We have successfully allocated a new internal array (with a
2559 -- smaller length than the old one, and containing a copy of
2560 -- just the active elements in the container), so it is now
2561 -- safe to attempt to deallocate the old array. The old array
2562 -- has been isolated, and container invariants have been
2563 -- restored, so if the deallocation fails (because finalization
2564 -- of the elements fails), we simply let it propagate.
2573 -- Reserve_Capacity can be used to expand the storage available for
2574 -- elements, but we do not let the capacity grow beyond the number of
2575 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2576 -- to refer to the elements with an index value greater than
2577 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2578 -- the Last index value of the new internal array, in a way that avoids
2579 -- any possibility of overflow.
2581 if Index_Type
'Base'Last >= Count_Type_Last then
2583 -- We perform a two-part test. First we determine whether the
2584 -- computed Last value lies in the base range of the type, and then
2585 -- determine whether it lies in the range of the index (sub)type.
2587 -- Last must satisfy this relation:
2588 -- First + Length - 1 <= Last
2589 -- We regroup terms:
2590 -- First - 1 <= Last - Length
2591 -- Which can rewrite as:
2592 -- No_Index <= Last - Length
2595 Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
2597 raise Constraint_Error
with "Capacity is out of range";
2600 -- We now know that the computed value of Last is within the base
2601 -- range of the type, so it is safe to compute its value:
2603 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
2605 -- Finally we test whether the value is within the range of the
2606 -- generic actual index subtype:
2608 if Checks
and then Last
> Index_Type
'Last then
2609 raise Constraint_Error
with "Capacity is out of range";
2612 elsif Index_Type
'First <= 0 then
2614 -- Here we can compute Last directly, in the normal way. We know that
2615 -- No_Index is less than 0, so there is no danger of overflow when
2616 -- adding the (positive) value of Capacity.
2618 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
2620 if Checks
and then Index
> Count_Type
'Base (Index_Type
'Last) then
2621 raise Constraint_Error
with "Capacity is out of range";
2624 -- We know that the computed value (having type Count_Type) of Last
2625 -- is within the range of the generic actual index subtype, so it is
2626 -- safe to convert to Index_Type:
2628 Last
:= Index_Type
'Base (Index
);
2631 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2632 -- must test the length indirectly (by working backwards from the
2633 -- largest possible value of Last), in order to prevent overflow.
2635 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
2637 if Checks
and then Index
< Count_Type
'Base (No_Index
) then
2638 raise Constraint_Error
with "Capacity is out of range";
2641 -- We have determined that the value of Capacity would not create a
2642 -- Last index value outside of the range of Index_Type, so we can now
2643 -- safely compute its value.
2645 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
2648 -- The requested capacity is non-zero, but we don't know yet whether
2649 -- this is a request for expansion or contraction of storage.
2651 if Container
.Elements
= null then
2653 -- The container is empty (it doesn't even have an internal array),
2654 -- so this represents a request to allocate (expand) storage having
2655 -- the given capacity.
2657 Container
.Elements
:= new Elements_Type
(Last
);
2661 if Capacity
<= N
then
2663 -- This is a request to trim back storage, but only to the limit of
2664 -- what's already in the container. (Reserve_Capacity never deletes
2665 -- active elements, it only reclaims excess storage.)
2667 if N
< Container
.Elements
.EA
'Length then
2669 -- The container is not empty (because the requested capacity is
2670 -- positive, and less than or equal to the container length), and
2671 -- the current length is less than the current capacity, so
2672 -- there's storage available to trim. In this case, we allocate a
2673 -- new internal array having a length that exactly matches the
2674 -- number of items in the container.
2676 TC_Check
(Container
.TC
);
2679 subtype Src_Index_Subtype
is Index_Type
'Base range
2680 Index_Type
'First .. Container
.Last
;
2682 Src
: Elements_Array
renames
2683 Container
.Elements
.EA
(Src_Index_Subtype
);
2685 X
: Elements_Access
:= Container
.Elements
;
2688 -- Although we have isolated the old internal array that we're
2689 -- going to deallocate, we don't deallocate it until we have
2690 -- successfully allocated a new one. If there is an exception
2691 -- during allocation (either because there is not enough
2692 -- storage, or because initialization of the elements fails),
2693 -- we let it propagate without causing any side-effect.
2695 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
2697 -- We have successfully allocated a new internal array (with a
2698 -- smaller length than the old one, and containing a copy of
2699 -- just the active elements in the container), so it is now
2700 -- safe to attempt to deallocate the old array. The old array
2701 -- has been isolated, and container invariants have been
2702 -- restored, so if the deallocation fails (because finalization
2703 -- of the elements fails), we simply let it propagate.
2712 -- The requested capacity is larger than the container length (the
2713 -- number of active elements). Whether this represents a request for
2714 -- expansion or contraction of the current capacity depends on what the
2715 -- current capacity is.
2717 if Capacity = Container.Elements.EA'Length then
2719 -- The requested capacity matches the existing capacity, so there's
2720 -- nothing to do here. We treat this case as a no-op, and simply
2721 -- return without checking the busy bit.
2726 -- There is a change in the capacity of a non-empty container, so a new
2727 -- internal array will be allocated. (The length of the new internal
2728 -- array could be less or greater than the old internal array. We know
2729 -- only that the length of the new internal array is greater than the
2730 -- number of active elements in the container.) We must check whether
2731 -- the container is busy before doing anything else.
2733 TC_Check (Container.TC);
2735 -- We now allocate a new internal array, having a length different from
2736 -- its current value.
2739 E : Elements_Access := new Elements_Type (Last);
2742 -- We have successfully allocated the new internal array. We first
2743 -- attempt to copy the existing elements from the old internal array
2744 -- ("src" elements) onto the new internal array ("tgt" elements).
2747 subtype Index_Subtype is Index_Type'Base range
2748 Index_Type'First .. Container.Last;
2750 Src : Elements_Array renames
2751 Container.Elements.EA (Index_Subtype);
2753 Tgt : Elements_Array renames E.EA (Index_Subtype);
2764 -- We have successfully copied the existing elements onto the new
2765 -- internal array, so now we can attempt to deallocate the old one.
2768 X : Elements_Access := Container.Elements;
2771 -- First we isolate the old internal array, and replace it in the
2772 -- container with the new internal array.
2774 Container.Elements := E;
2776 -- Container invariants have been restored, so it is now safe to
2777 -- attempt to deallocate the old internal array.
2782 end Reserve_Capacity;
2784 ----------------------
2785 -- Reverse_Elements --
2786 ----------------------
2788 procedure Reverse_Elements (Container : in out Vector) is
2790 if Container.Length <= 1 then
2794 -- The exception behavior for the vector container must match that for
2795 -- the list container, so we check for cursor tampering here (which will
2796 -- catch more things) instead of for element tampering (which will catch
2797 -- fewer things). It's true that the elements of this vector container
2798 -- could be safely moved around while (say) an iteration is taking place
2799 -- (iteration only increments the busy counter), and so technically
2800 -- all we would need here is a test for element tampering (indicated
2801 -- by the lock counter), that's simply an artifact of our array-based
2802 -- implementation. Logically Reverse_Elements requires a check for
2803 -- cursor tampering.
2805 TC_Check (Container.TC);
2810 E : Elements_Type renames Container.Elements.all;
2813 K := Index_Type'First;
2814 J := Container.Last;
2817 EK : constant Element_Type := E.EA (K);
2819 E.EA (K) := E.EA (J);
2827 end Reverse_Elements;
2833 function Reverse_Find
2834 (Container : Vector;
2835 Item : Element_Type;
2836 Position : Cursor := No_Element) return Cursor
2838 Last : Index_Type'Base;
2841 if Checks and then Position.Container /= null
2842 and then Position.Container /= Container'Unrestricted_Access
2844 raise Program_Error with "Position cursor denotes wrong container";
2848 (if Position.Container = null or else Position.Index > Container.Last
2850 else Position.Index);
2852 -- Per AI05-0022, the container implementation is required to detect
2853 -- element tampering by a generic actual subprogram.
2856 Lock : With_Lock (Container.TC'Unrestricted_Access);
2858 for Indx in reverse Index_Type'First .. Last loop
2859 if Container.Elements.EA (Indx) = Item then
2860 return Cursor'(Container
'Unrestricted_Access, Indx
);
2868 ------------------------
2869 -- Reverse_Find_Index --
2870 ------------------------
2872 function Reverse_Find_Index
2873 (Container
: Vector
;
2874 Item
: Element_Type
;
2875 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
2877 -- Per AI05-0022, the container implementation is required to detect
2878 -- element tampering by a generic actual subprogram.
2880 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
2882 Last
: constant Index_Type
'Base :=
2883 Index_Type
'Min (Container
.Last
, Index
);
2886 for Indx
in reverse Index_Type
'First .. Last
loop
2887 if Container
.Elements
.EA
(Indx
) = Item
then
2893 end Reverse_Find_Index
;
2895 ---------------------
2896 -- Reverse_Iterate --
2897 ---------------------
2899 procedure Reverse_Iterate
2900 (Container
: Vector
;
2901 Process
: not null access procedure (Position
: Cursor
))
2903 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
2905 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
2906 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
2908 end Reverse_Iterate;
2914 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2915 Count : constant Count_Type'Base := Container.Length - Length;
2918 -- Set_Length allows the user to set the length explicitly, instead
2919 -- of implicitly as a side-effect of deletion or insertion. If the
2920 -- requested length is less than the current length, this is equivalent
2921 -- to deleting items from the back end of the vector. If the requested
2922 -- length is greater than the current length, then this is equivalent
2923 -- to inserting "space" (nonce items) at the end.
2926 Container.Delete_Last (Count);
2928 elsif Checks and then Container.Last >= Index_Type'Last then
2929 raise Constraint_Error with "vector is already at its maximum length";
2932 Container.Insert_Space (Container.Last + 1, -Count);
2940 procedure Swap (Container : in out Vector; I, J : Index_Type) is
2943 if I > Container.Last then
2944 raise Constraint_Error with "I index is out of range";
2947 if J > Container.Last then
2948 raise Constraint_Error with "J index is out of range";
2956 TE_Check (Container.TC);
2959 EI_Copy : constant Element_Type := Container.Elements.EA (I);
2961 Container.Elements.EA (I) := Container.Elements.EA (J);
2962 Container.Elements.EA (J) := EI_Copy;
2966 procedure Swap (Container : in out Vector; I, J : Cursor) is
2969 if I.Container = null then
2970 raise Constraint_Error with "I cursor has no element";
2972 elsif J.Container = null then
2973 raise Constraint_Error with "J cursor has no element";
2975 elsif I.Container /= Container'Unrestricted_Access then
2976 raise Program_Error with "I cursor denotes wrong container";
2978 elsif J.Container /= Container'Unrestricted_Access then
2979 raise Program_Error with "J cursor denotes wrong container";
2983 Swap (Container, I.Index, J.Index);
2991 (Container : Vector;
2992 Index : Extended_Index) return Cursor
2995 if Index not in Index_Type'First .. Container.Last then
2998 return (Container'Unrestricted_Access, Index);
3006 function To_Index (Position : Cursor) return Extended_Index is
3008 if Position.Container = null then
3010 elsif Position.Index <= Position.Container.Last then
3011 return Position.Index;
3021 function To_Vector (Length : Count_Type) return Vector is
3022 Index : Count_Type'Base;
3023 Last : Index_Type'Base;
3024 Elements : Elements_Access;
3028 return Empty_Vector;
3031 -- We create a vector object with a capacity that matches the specified
3032 -- Length, but we do not allow the vector capacity (the length of the
3033 -- internal array) to exceed the number of values in Index_Type'Range
3034 -- (otherwise, there would be no way to refer to those components via an
3035 -- index). We must therefore check whether the specified Length would
3036 -- create a Last index value greater than Index_Type'Last.
3038 if Index_Type'Base'Last
>= Count_Type_Last
then
3040 -- We perform a two-part test. First we determine whether the
3041 -- computed Last value lies in the base range of the type, and then
3042 -- determine whether it lies in the range of the index (sub)type.
3044 -- Last must satisfy this relation:
3045 -- First + Length - 1 <= Last
3046 -- We regroup terms:
3047 -- First - 1 <= Last - Length
3048 -- Which can rewrite as:
3049 -- No_Index <= Last - Length
3052 Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index
3054 raise Constraint_Error with "Length is out of range";
3057 -- We now know that the computed value of Last is within the base
3058 -- range of the type, so it is safe to compute its value:
3060 Last := No_Index + Index_Type'Base (Length);
3062 -- Finally we test whether the value is within the range of the
3063 -- generic actual index subtype:
3065 if Checks and then Last > Index_Type'Last then
3066 raise Constraint_Error with "Length is out of range";
3069 elsif Index_Type'First <= 0 then
3071 -- Here we can compute Last directly, in the normal way. We know that
3072 -- No_Index is less than 0, so there is no danger of overflow when
3073 -- adding the (positive) value of Length.
3075 Index := Count_Type'Base (No_Index) + Length; -- Last
3077 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
3078 raise Constraint_Error with "Length is out of range";
3081 -- We know that the computed value (having type Count_Type) of Last
3082 -- is within the range of the generic actual index subtype, so it is
3083 -- safe to convert to Index_Type:
3085 Last := Index_Type'Base (Index);
3088 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3089 -- must test the length indirectly (by working backwards from the
3090 -- largest possible value of Last), in order to prevent overflow.
3092 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3094 if Checks and then Index < Count_Type'Base (No_Index) then
3095 raise Constraint_Error with "Length is out of range";
3098 -- We have determined that the value of Length would not create a
3099 -- Last index value outside of the range of Index_Type, so we can now
3100 -- safely compute its value.
3102 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3105 Elements := new Elements_Type (Last);
3107 return Vector'(Controlled
with Elements
, Last
, TC
=> <>);
3111 (New_Item
: Element_Type
;
3112 Length
: Count_Type
) return Vector
3114 Index
: Count_Type
'Base;
3115 Last
: Index_Type
'Base;
3116 Elements
: Elements_Access
;
3120 return Empty_Vector
;
3123 -- We create a vector object with a capacity that matches the specified
3124 -- Length, but we do not allow the vector capacity (the length of the
3125 -- internal array) to exceed the number of values in Index_Type'Range
3126 -- (otherwise, there would be no way to refer to those components via an
3127 -- index). We must therefore check whether the specified Length would
3128 -- create a Last index value greater than Index_Type'Last.
3130 if Index_Type
'Base'Last >= Count_Type_Last then
3132 -- We perform a two-part test. First we determine whether the
3133 -- computed Last value lies in the base range of the type, and then
3134 -- determine whether it lies in the range of the index (sub)type.
3136 -- Last must satisfy this relation:
3137 -- First + Length - 1 <= Last
3138 -- We regroup terms:
3139 -- First - 1 <= Last - Length
3140 -- Which can rewrite as:
3141 -- No_Index <= Last - Length
3144 Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
3146 raise Constraint_Error
with "Length is out of range";
3149 -- We now know that the computed value of Last is within the base
3150 -- range of the type, so it is safe to compute its value:
3152 Last
:= No_Index
+ Index_Type
'Base (Length
);
3154 -- Finally we test whether the value is within the range of the
3155 -- generic actual index subtype:
3157 if Checks
and then Last
> Index_Type
'Last then
3158 raise Constraint_Error
with "Length is out of range";
3161 elsif Index_Type
'First <= 0 then
3163 -- Here we can compute Last directly, in the normal way. We know that
3164 -- No_Index is less than 0, so there is no danger of overflow when
3165 -- adding the (positive) value of Length.
3167 Index
:= Count_Type
'Base (No_Index
) + Length
; -- same value as V.Last
3169 if Checks
and then Index
> Count_Type
'Base (Index_Type
'Last) then
3170 raise Constraint_Error
with "Length is out of range";
3173 -- We know that the computed value (having type Count_Type) of Last
3174 -- is within the range of the generic actual index subtype, so it is
3175 -- safe to convert to Index_Type:
3177 Last
:= Index_Type
'Base (Index
);
3180 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3181 -- must test the length indirectly (by working backwards from the
3182 -- largest possible value of Last), in order to prevent overflow.
3184 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
3186 if Checks
and then Index
< Count_Type
'Base (No_Index
) then
3187 raise Constraint_Error
with "Length is out of range";
3190 -- We have determined that the value of Length would not create a
3191 -- Last index value outside of the range of Index_Type, so we can now
3192 -- safely compute its value.
3194 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
3197 Elements
:= new Elements_Type
'(Last, EA => (others => New_Item));
3199 return (Controlled with Elements, Last, TC => <>);
3202 --------------------
3203 -- Update_Element --
3204 --------------------
3206 procedure Update_Element
3207 (Container : in out Vector;
3209 Process : not null access procedure (Element : in out Element_Type))
3211 Lock : With_Lock (Container.TC'Unchecked_Access);
3213 if Checks and then Index > Container.Last then
3214 raise Constraint_Error with "Index is out of range";
3217 Process (Container.Elements.EA (Index));
3220 procedure Update_Element
3221 (Container : in out Vector;
3223 Process : not null access procedure (Element : in out Element_Type))
3227 if Position.Container = null then
3228 raise Constraint_Error with "Position cursor has no element";
3229 elsif Position.Container /= Container'Unrestricted_Access then
3230 raise Program_Error with "Position cursor denotes wrong container";
3234 Update_Element (Container, Position.Index, Process);
3242 (Stream : not null access Root_Stream_Type'Class;
3246 Count_Type'Base'Write
(Stream
, Length
(Container
));
3248 for J
in Index_Type
'First .. Container
.Last
loop
3249 Element_Type
'Write (Stream
, Container
.Elements
.EA
(J
));
3254 (Stream
: not null access Root_Stream_Type
'Class;
3258 raise Program_Error
with "attempt to stream vector cursor";
3262 (Stream
: not null access Root_Stream_Type
'Class;
3263 Item
: Reference_Type
)
3266 raise Program_Error
with "attempt to stream reference";
3270 (Stream
: not null access Root_Stream_Type
'Class;
3271 Item
: Constant_Reference_Type
)
3274 raise Program_Error
with "attempt to stream reference";
3277 end Ada
.Containers
.Vectors
;