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-2024, 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
;
34 with System
.Put_Images
;
36 package body Ada
.Containers
.Vectors
with
40 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
41 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
42 -- See comment in Ada.Containers.Helpers
45 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
47 procedure Append_Slow_Path
48 (Container
: in out Vector
;
49 New_Item
: Element_Type
;
51 -- This is the slow path for Append. This is split out to minimize the size
52 -- of Append, because we have Inline (Append).
58 -- We decide that the capacity of the result of "&" is the minimum needed
59 -- -- the sum of the lengths of the vector parameters. We could decide to
60 -- make it larger, but we have no basis for knowing how much larger, so we
61 -- just allocate the minimum amount of storage.
63 function "&" (Left
, Right
: Vector
) return Vector
is
65 return Result
: Vector
do
66 Reserve_Capacity
(Result
, Length
(Left
) + Length
(Right
));
67 Append_Vector
(Result
, Left
);
68 Append_Vector
(Result
, Right
);
72 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
74 return Result
: Vector
do
75 Reserve_Capacity
(Result
, Length
(Left
) + 1);
76 Append_Vector
(Result
, Left
);
77 Append
(Result
, Right
);
81 function "&" (Left
: Element_Type
; Right
: Vector
) return Vector
is
83 return Result
: Vector
do
84 Reserve_Capacity
(Result
, 1 + Length
(Right
));
85 Append
(Result
, Left
);
86 Append_Vector
(Result
, Right
);
90 function "&" (Left
, Right
: Element_Type
) return Vector
is
92 return Result
: Vector
do
93 Reserve_Capacity
(Result
, 1 + 1);
94 Append
(Result
, Left
);
95 Append
(Result
, Right
);
103 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
105 if Left
.Last
/= Right
.Last
then
109 if Left
.Length
= 0 then
114 -- Per AI05-0022, the container implementation is required to detect
115 -- element tampering by a generic actual subprogram.
117 Lock_Left
: With_Lock
(Left
.TC
'Unrestricted_Access);
118 Lock_Right
: With_Lock
(Right
.TC
'Unrestricted_Access);
120 for J
in Index_Type
range Index_Type
'First .. Left
.Last
loop
121 if Left
.Elements
.EA
(J
) /= Right
.Elements
.EA
(J
) then
134 procedure Adjust
(Container
: in out Vector
) is
136 -- If the counts are nonzero, execution is technically erroneous, but
137 -- it seems friendly to allow things like concurrent "=" on shared
140 Zero_Counts
(Container
.TC
);
142 if Container
.Last
= No_Index
then
143 Container
.Elements
:= null;
148 L
: constant Index_Type
:= Container
.Last
;
149 EA
: Elements_Array
renames
150 Container
.Elements
.EA
(Index_Type
'First .. L
);
153 Container
.Elements
:= null;
155 -- Note: it may seem that the following assignment to Container.Last
156 -- is useless, since we assign it to L below. However this code is
157 -- used in case 'new Elements_Type' below raises an exception, to
158 -- keep Container in a consistent state.
160 Container
.Last
:= No_Index
;
161 Container
.Elements
:= new Elements_Type
'(L, EA);
171 (Container : in out Vector;
172 New_Item : Element_Type;
176 -- In the general case, we take the slow path; for efficiency,
177 -- we check for the common case where Count = 1 .
180 Append (Container, New_Item);
182 Append_Slow_Path (Container, New_Item, Count);
190 procedure Append_Vector (Container : in out Vector; New_Item : Vector) is
192 if Is_Empty (New_Item) then
194 elsif Checks and then Container.Last = Index_Type'Last then
195 raise Constraint_Error with "vector is already at its maximum length";
197 Insert_Vector (Container, Container.Last + 1, New_Item);
205 procedure Append (Container : in out Vector;
206 New_Item : Element_Type)
209 -- For performance, check for the common special case where the
210 -- container already has room for at least one more element.
211 -- In the general case, pass the buck to Insert.
213 if Container.Elements /= null
214 and then Container.Last /= Container.Elements.Last
216 TC_Check (Container.TC);
218 -- Increment Container.Last after assigning the New_Item, so we
219 -- leave the Container unmodified in case Finalize/Adjust raises
223 New_Last : constant Index_Type := Container.Last + 1;
225 Container.Elements.EA (New_Last) := New_Item;
226 Container.Last := New_Last;
229 Insert (Container, Last_Index (Container) + 1, New_Item, 1);
233 ----------------------
234 -- Append_Slow_Path --
235 ----------------------
237 procedure Append_Slow_Path
238 (Container : in out Vector;
239 New_Item : Element_Type;
245 elsif Checks and then Container.Last = Index_Type'Last then
246 raise Constraint_Error with "vector is already at its maximum length";
248 Insert (Container, Container.Last + 1, New_Item, Count);
250 end Append_Slow_Path;
256 procedure Assign (Target : in out Vector; Source : Vector) is
258 if Target'Address = Source'Address then
262 Target.Append_Vector (Source);
270 function Capacity (Container : Vector) return Count_Type is
272 if Container.Elements = null then
275 return Container.Elements.EA'Length;
283 procedure Clear (Container : in out Vector) is
285 TC_Check (Container.TC);
286 Container.Last := No_Index;
289 ------------------------
290 -- Constant_Reference --
291 ------------------------
293 function Constant_Reference
294 (Container : aliased Vector;
295 Position : Cursor) return Constant_Reference_Type
299 if Position.Container = null then
300 raise Constraint_Error with "Position cursor has no element";
303 if Position.Container /= Container'Unrestricted_Access then
304 raise Program_Error with "Position cursor denotes wrong container";
307 if Position.Index > Position.Container.Last then
308 raise Constraint_Error with "Position cursor is out of range";
313 TC : constant Tamper_Counts_Access :=
314 Container.TC'Unrestricted_Access;
316 return R : constant Constant_Reference_Type :=
317 (Element => Container.Elements.EA (Position.Index)'Access,
318 Control => (Controlled with TC))
323 end Constant_Reference;
325 function Constant_Reference
326 (Container : aliased Vector;
327 Index : Index_Type) return Constant_Reference_Type
330 if Checks and then Index > Container.Last then
331 raise Constraint_Error with "Index is out of range";
335 TC : constant Tamper_Counts_Access :=
336 Container.TC'Unrestricted_Access;
338 return R : constant Constant_Reference_Type :=
339 (Element => Container.Elements.EA (Index)'Access,
340 Control => (Controlled with TC))
345 end Constant_Reference;
353 Item : Element_Type) return Boolean
356 return Find_Index (Container, Item) /= No_Index;
365 Capacity : Count_Type := 0) return Vector
370 if Capacity >= Source.Length then
376 if Checks and then Capacity /= 0 then
377 raise Capacity_Error with
378 "Requested capacity is less than Source length";
382 return Target : Vector do
383 Target.Reserve_Capacity (C);
384 Target.Assign (Source);
393 (Container : in out Vector;
394 Index : Extended_Index;
395 Count : Count_Type := 1)
397 Old_Last : constant Index_Type'Base := Container.Last;
398 New_Last : Index_Type'Base;
399 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
400 J : Index_Type'Base; -- first index of items that slide down
403 -- The tampering bits exist to prevent an item from being deleted (or
404 -- otherwise harmfully manipulated) while it is being visited. Query,
405 -- Update, and Iterate increment the busy count on entry, and decrement
406 -- the count on exit. Delete checks the count to determine whether it is
407 -- being called while the associated callback procedure is executing.
409 TC_Check (Container.TC);
411 -- Delete removes items from the vector, the number of which is the
412 -- minimum of the specified Count and the items (if any) that exist from
413 -- Index to Container.Last. There are no constraints on the specified
414 -- value of Count (it can be larger than what's available at this
415 -- position in the vector, for example), but there are constraints on
416 -- the allowed values of the Index.
418 -- As a precondition on the generic actual Index_Type, the base type
419 -- must include Index_Type'Pred (Index_Type'First); this is the value
420 -- that Container.Last assumes when the vector is empty. However, we do
421 -- not allow that as the value for Index when specifying which items
422 -- should be deleted, so we must manually check. (That the user is
423 -- allowed to specify the value at all here is a consequence of the
424 -- declaration of the Extended_Index subtype, which includes the values
425 -- in the base range that immediately precede and immediately follow the
426 -- values in the Index_Type.)
428 if Checks and then Index < Index_Type'First then
429 raise Constraint_Error with "Index is out of range (too small)";
432 -- We do allow a value greater than Container.Last to be specified as
433 -- the Index, but only if it's immediately greater. This allows the
434 -- corner case of deleting no items from the back end of the vector to
435 -- be treated as a no-op. (It is assumed that specifying an index value
436 -- greater than Last + 1 indicates some deeper flaw in the caller's
437 -- algorithm, so that case is treated as a proper error.)
439 if Index > Old_Last then
440 if Checks and then Index > Old_Last + 1 then
441 raise Constraint_Error with "Index is out of range (too large)";
447 -- Here and elsewhere we treat deleting 0 items from the container as a
448 -- no-op, even when the container is busy, so we simply return.
454 -- We first calculate what's available for deletion starting at
455 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
456 -- Count_Type'Base as the type for intermediate values. (See function
457 -- Length for more information.)
459 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
460 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
462 Count2 := Count_Type'Base (Old_Last - Index + 1);
465 -- If more elements are requested (Count) for deletion than are
466 -- available (Count2) for deletion beginning at Index, then everything
467 -- from Index is deleted. There are no elements to slide down, and so
468 -- all we need to do is set the value of Container.Last.
470 if Count >= Count2 then
471 Container.Last := Index - 1;
475 -- There are some elements that aren't being deleted (the requested
476 -- count was less than the available count), so we must slide them down
477 -- to Index. We first calculate the index values of the respective array
478 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
479 -- type for intermediate calculations. For the elements that slide down,
480 -- index value New_Last is the last index value of their new home, and
481 -- index value J is the first index of their old home.
483 if Index_Type'Base'Last
>= Count_Type_Last
then
484 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
485 J
:= Index
+ Index_Type
'Base (Count
);
487 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
488 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
491 -- The internal elements array isn't guaranteed to exist unless we have
492 -- elements, but we have that guarantee here because we know we have
493 -- elements to slide. The array index values for each slice have
494 -- already been determined, so we just slide down to Index the elements
495 -- that weren't deleted.
498 EA
: Elements_Array
renames Container
.Elements
.EA
;
500 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
501 Container
.Last
:= New_Last
;
506 (Container
: in out Vector
;
507 Position
: in out Cursor
;
508 Count
: Count_Type
:= 1)
512 if Position
.Container
= null then
513 raise Constraint_Error
with "Position cursor has no element";
515 elsif Position
.Container
/= Container
'Unrestricted_Access then
516 raise Program_Error
with "Position cursor denotes wrong container";
518 elsif Position
.Index
> Container
.Last
then
519 raise Program_Error
with "Position index is out of range";
523 Delete
(Container
, Position
.Index
, Count
);
524 Position
:= No_Element
;
531 procedure Delete_First
532 (Container
: in out Vector
;
533 Count
: Count_Type
:= 1)
539 elsif Count
>= Length
(Container
) then
544 Delete
(Container
, Index_Type
'First, Count
);
552 procedure Delete_Last
553 (Container
: in out Vector
;
554 Count
: Count_Type
:= 1)
557 -- It is not permitted to delete items while the container is busy (for
558 -- example, we're in the middle of a passive iteration). However, we
559 -- always treat deleting 0 items as a no-op, even when we're busy, so we
560 -- simply return without checking.
566 -- The tampering bits exist to prevent an item from being deleted (or
567 -- otherwise harmfully manipulated) while it is being visited. Query,
568 -- Update, and Iterate increment the busy count on entry, and decrement
569 -- the count on exit. Delete_Last checks the count to determine whether
570 -- it is being called while the associated callback procedure is
573 TC_Check
(Container
.TC
);
575 -- There is no restriction on how large Count can be when deleting
576 -- items. If it is equal or greater than the current length, then this
577 -- is equivalent to clearing the vector. (In particular, there's no need
578 -- for us to actually calculate the new value for Last.)
580 -- If the requested count is less than the current length, then we must
581 -- calculate the new value for Last. For the type we use the widest of
582 -- Index_Type'Base and Count_Type'Base for the intermediate values of
583 -- our calculation. (See the comments in Length for more information.)
585 if Count
>= Container
.Length
then
586 Container
.Last
:= No_Index
;
588 elsif Index_Type
'Base'Last >= Count_Type_Last then
589 Container.Last := Container.Last - Index_Type'Base (Count);
593 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
603 Index : Index_Type) return Element_Type
606 if Checks and then Index > Container.Last then
607 raise Constraint_Error with "Index is out of range";
610 return Container.Elements.EA (Index);
613 function Element (Position : Cursor) return Element_Type is
616 if Position.Container = null then
617 raise Constraint_Error with "Position cursor has no element";
618 elsif Position.Index > Position.Container.Last then
619 raise Constraint_Error with "Position cursor is out of range";
623 return Position.Container.Elements.EA (Position.Index);
630 function Empty (Capacity : Count_Type := 10) return Vector is
632 return Result : Vector do
633 Reserve_Capacity (Result, Capacity);
641 procedure Finalize (Container : in out Vector) is
642 X : Elements_Access := Container.Elements;
645 Container.Elements := null;
646 Container.Last := No_Index;
650 TC_Check (Container.TC);
653 procedure Finalize (Object : in out Iterator) is
655 Unbusy (Object.Container.TC);
665 Position : Cursor := No_Element) return Cursor
668 if Checks and then Position.Container /= null then
669 if Position.Container /= Container'Unrestricted_Access then
670 raise Program_Error with "Position cursor denotes wrong container";
673 if Position.Index > Container.Last then
674 raise Program_Error with "Position index is out of range";
678 -- Per AI05-0022, the container implementation is required to detect
679 -- element tampering by a generic actual subprogram.
682 Lock : With_Lock (Container.TC'Unrestricted_Access);
684 for J in Position.Index .. Container.Last loop
685 if Container.Elements.EA (J) = Item then
686 return Cursor'(Container
'Unrestricted_Access, J
);
701 Index
: Index_Type
:= Index_Type
'First) return Extended_Index
703 -- Per AI05-0022, the container implementation is required to detect
704 -- element tampering by a generic actual subprogram.
706 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
708 for Indx
in Index
.. Container
.Last
loop
709 if Container
.Elements
.EA
(Indx
) = Item
then
721 function First
(Container
: Vector
) return Cursor
is
723 if Is_Empty
(Container
) then
727 return (Container
'Unrestricted_Access, Index_Type
'First);
730 function First
(Object
: Iterator
) return Cursor
is
732 -- The value of the iterator object's Index component influences the
733 -- behavior of the First (and Last) selector function.
735 -- When the Index component is No_Index, this means the iterator
736 -- object was constructed without a start expression, in which case the
737 -- (forward) iteration starts from the (logical) beginning of the entire
738 -- sequence of items (corresponding to Container.First, for a forward
741 -- Otherwise, this is iteration over a partial sequence of items.
742 -- When the Index component isn't No_Index, the iterator object was
743 -- constructed with a start expression, that specifies the position
744 -- from which the (forward) partial iteration begins.
746 if Object
.Index
= No_Index
then
747 return First
(Object
.Container
.all);
749 return Cursor
'(Object.Container, Object.Index);
757 function First_Element (Container : Vector) return Element_Type is
759 if Checks and then Container.Last = No_Index then
760 raise Constraint_Error with "Container is empty";
762 return Container.Elements.EA (Index_Type'First);
770 function First_Index (Container : Vector) return Index_Type is
771 pragma Unreferenced (Container);
773 return Index_Type'First;
780 function New_Vector (First, Last : Index_Type) return Vector
783 return (To_Vector (Count_Type (Last - First + 1)));
786 ---------------------
787 -- Generic_Sorting --
788 ---------------------
790 package body Generic_Sorting is
796 function Is_Sorted (Container : Vector) return Boolean is
798 if Container.Last <= Index_Type'First then
802 -- Per AI05-0022, the container implementation is required to detect
803 -- element tampering by a generic actual subprogram.
806 Lock : With_Lock (Container.TC'Unrestricted_Access);
807 EA : Elements_Array renames Container.Elements.EA;
809 for J in Index_Type'First .. Container.Last - 1 loop
810 if EA (J + 1) < EA (J) then
823 procedure Merge (Target, Source : in out Vector) is
824 I : Index_Type'Base := Target.Last;
828 TC_Check (Source.TC);
830 -- The semantics of Merge changed slightly per AI05-0021. It was
831 -- originally the case that if Target and Source denoted the same
832 -- container object, then the GNAT implementation of Merge did
833 -- nothing. However, it was argued that RM05 did not precisely
834 -- specify the semantics for this corner case. The decision of the
835 -- ARG was that if Target and Source denote the same non-empty
836 -- container object, then Program_Error is raised.
838 if Source.Last < Index_Type'First then -- Source is empty
842 if Checks and then Target'Address = Source'Address then
843 raise Program_Error with
844 "Target and Source denote same non-empty container";
847 if Target.Last < Index_Type'First then -- Target is empty
848 Move (Target => Target, Source => Source);
852 Target.Set_Length (Length (Target) + Length (Source));
854 -- Per AI05-0022, the container implementation is required to detect
855 -- element tampering by a generic actual subprogram.
858 TA : Elements_Array renames Target.Elements.EA;
859 SA : Elements_Array renames Source.Elements.EA;
861 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
862 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
865 while Source.Last >= Index_Type'First loop
866 pragma Assert (Source.Last <= Index_Type'First
867 or else not (SA (Source.Last) <
868 SA (Source.Last - 1)));
870 if I < Index_Type'First then
871 TA (Index_Type'First .. J) :=
872 SA (Index_Type'First .. Source.Last);
874 Source.Last := No_Index;
878 pragma Assert (I <= Index_Type'First
879 or else not (TA (I) < TA (I - 1)));
881 if SA (Source.Last) < TA (I) then
886 TA (J) := SA (Source.Last);
887 Source.Last := Source.Last - 1;
899 procedure Sort (Container : in out Vector) is
901 new Generic_Array_Sort
902 (Index_Type => Index_Type,
903 Element_Type => Element_Type,
904 Array_Type => Elements_Array,
908 -- The exception behavior for the vector container must match that
909 -- for the list container, so we check for cursor tampering here
910 -- (which will catch more things) instead of for element tampering
911 -- (which will catch fewer things). It's true that the elements of
912 -- this vector container could be safely moved around while (say) an
913 -- iteration is taking place (iteration only increments the busy
914 -- counter), and so technically all we would need here is a test for
915 -- element tampering (indicated by the lock counter), that's simply
916 -- an artifact of our array-based implementation. Logically Sort
917 -- requires a check for cursor tampering.
919 TC_Check (Container.TC);
921 if Container.Last <= Index_Type'First then
925 -- Per AI05-0022, the container implementation is required to detect
926 -- element tampering by a generic actual subprogram.
929 Lock : With_Lock (Container.TC'Unchecked_Access);
931 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
937 ------------------------
938 -- Get_Element_Access --
939 ------------------------
941 function Get_Element_Access
942 (Position : Cursor) return not null Element_Access is
944 return Position.Container.Elements.EA (Position.Index)'Access;
945 end Get_Element_Access;
951 function Has_Element (Position : Cursor) return Boolean is
953 return Position /= No_Element;
961 (Container : in out Vector;
962 Before : Extended_Index;
963 New_Item : Element_Type;
964 Count : Count_Type := 1)
966 Old_Length : constant Count_Type := Container.Length;
968 Max_Length : Count_Type'Base; -- determined from range of Index_Type
969 New_Length : Count_Type'Base; -- sum of current length and Count
970 New_Last : Index_Type'Base; -- last index of vector after insertion
972 Index : Index_Type'Base; -- scratch for intermediate values
973 J : Count_Type'Base; -- scratch
975 New_Capacity : Count_Type'Base; -- length of new, expanded array
976 Dst_Last : Index_Type'Base; -- last index of new, expanded array
977 Dst : Elements_Access; -- new, expanded internal array
980 -- The tampering bits exist to prevent an item from being harmfully
981 -- manipulated while it is being visited. Query, Update, and Iterate
982 -- increment the busy count on entry, and decrement the count on
983 -- exit. Insert checks the count to determine whether it is being called
984 -- while the associated callback procedure is executing.
986 TC_Check (Container.TC);
989 -- As a precondition on the generic actual Index_Type, the base type
990 -- must include Index_Type'Pred (Index_Type'First); this is the value
991 -- that Container.Last assumes when the vector is empty. However, we
992 -- do not allow that as the value for Index when specifying where the
993 -- new items should be inserted, so we must manually check. (That the
994 -- user is allowed to specify the value at all here is a consequence
995 -- of the declaration of the Extended_Index subtype, which includes
996 -- the values in the base range that immediately precede and
997 -- immediately follow the values in the Index_Type.)
999 if Before < Index_Type'First then
1000 raise Constraint_Error with
1001 "Before index is out of range (too small)";
1004 -- We do allow a value greater than Container.Last to be specified as
1005 -- the Index, but only if it's immediately greater. This allows for
1006 -- the case of appending items to the back end of the vector. (It is
1007 -- assumed that specifying an index value greater than Last + 1
1008 -- indicates some deeper flaw in the caller's algorithm, so that case
1009 -- is treated as a proper error.)
1011 if Before > Container.Last + 1 then
1012 raise Constraint_Error with
1013 "Before index is out of range (too large)";
1017 -- We treat inserting 0 items into the container as a no-op, even when
1018 -- the container is busy, so we simply return.
1024 -- There are two constraints we need to satisfy. The first constraint is
1025 -- that a container cannot have more than Count_Type'Last elements, so
1026 -- we must check the sum of the current length and the insertion count.
1027 -- Note: we cannot simply add these values, because of the possibility
1030 if Checks and then Old_Length > Count_Type'Last - Count then
1031 raise Constraint_Error with "Count is out of range";
1034 -- It is now safe compute the length of the new vector, without fear of
1037 New_Length := Old_Length + Count;
1039 -- The second constraint is that the new Last index value cannot exceed
1040 -- Index_Type'Last. In each branch below, we calculate the maximum
1041 -- length (computed from the range of values in Index_Type), and then
1042 -- compare the new length to the maximum length. If the new length is
1043 -- acceptable, then we compute the new last index from that.
1045 if Index_Type'Base'Last
>= Count_Type_Last
then
1047 -- We have to handle the case when there might be more values in the
1048 -- range of Index_Type than in the range of Count_Type.
1050 if Index_Type
'First <= 0 then
1052 -- We know that No_Index (the same as Index_Type'First - 1) is
1053 -- less than 0, so it is safe to compute the following sum without
1054 -- fear of overflow. We need to suppress warnings, because
1055 -- otherwise we get an error in -gnatwE mode.
1057 pragma Warnings
(Off
);
1058 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
1059 pragma Warnings
(On
);
1061 if Index
<= Index_Type
'Last then
1063 -- We have determined that range of Index_Type has at least as
1064 -- many values as in Count_Type, so Count_Type'Last is the
1065 -- maximum number of items that are allowed.
1067 Max_Length
:= Count_Type
'Last;
1070 -- The range of Index_Type has fewer values than in Count_Type,
1071 -- so the maximum number of items is computed from the range of
1074 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1078 -- No_Index is equal or greater than 0, so we can safely compute
1079 -- the difference without fear of overflow (which we would have to
1080 -- worry about if No_Index were less than 0, but that case is
1083 if Index_Type
'Last - No_Index
>= Count_Type_Last
then
1084 -- We have determined that range of Index_Type has at least as
1085 -- many values as in Count_Type, so Count_Type'Last is the
1086 -- maximum number of items that are allowed.
1088 Max_Length
:= Count_Type
'Last;
1091 -- The range of Index_Type has fewer values than in Count_Type,
1092 -- so the maximum number of items is computed from the range of
1095 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1099 elsif Index_Type
'First <= 0 then
1101 -- We know that No_Index (the same as Index_Type'First - 1) is less
1102 -- than 0, so it is safe to compute the following sum without fear of
1105 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
1107 if J
<= Count_Type
'Base (Index_Type
'Last) then
1109 -- We have determined that range of Index_Type has at least as
1110 -- many values as in Count_Type, so Count_Type'Last is the maximum
1111 -- number of items that are allowed.
1113 Max_Length
:= Count_Type
'Last;
1116 -- The range of Index_Type has fewer values than Count_Type does,
1117 -- so the maximum number of items is computed from the range of
1121 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1125 -- No_Index is equal or greater than 0, so we can safely compute the
1126 -- difference without fear of overflow (which we would have to worry
1127 -- about if No_Index were less than 0, but that case is handled
1131 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1134 -- We have just computed the maximum length (number of items). We must
1135 -- now compare the requested length to the maximum length, as we do not
1136 -- allow a vector expand beyond the maximum (because that would create
1137 -- an internal array with a last index value greater than
1138 -- Index_Type'Last, with no way to index those elements).
1140 if Checks
and then New_Length
> Max_Length
then
1141 raise Constraint_Error
with "Count is out of range";
1144 -- New_Last is the last index value of the items in the container after
1145 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1146 -- compute its value from the New_Length.
1148 if Index_Type
'Base'Last >= Count_Type_Last then
1149 New_Last := No_Index + Index_Type'Base (New_Length);
1151 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1154 if Container.Elements = null then
1155 pragma Assert (Container.Last = No_Index);
1157 -- This is the simplest case, with which we must always begin: we're
1158 -- inserting items into an empty vector that hasn't allocated an
1159 -- internal array yet. Note that we don't need to check the busy bit
1160 -- here, because an empty container cannot be busy.
1162 -- In order to preserve container invariants, we allocate the new
1163 -- internal array first, before setting the Last index value, in case
1164 -- the allocation fails (which can happen either because there is no
1165 -- storage available, or because element initialization fails).
1167 Container.Elements := new Elements_Type'
1169 EA
=> [others => New_Item
]);
1171 -- The allocation of the new, internal array succeeded, so it is now
1172 -- safe to update the Last index, restoring container invariants.
1174 Container
.Last
:= New_Last
;
1179 -- An internal array has already been allocated, so we must determine
1180 -- whether there is enough unused storage for the new items.
1182 if New_Length
<= Container
.Elements
.EA
'Length then
1184 -- In this case, we're inserting elements into a vector that has
1185 -- already allocated an internal array, and the existing array has
1186 -- enough unused storage for the new items.
1189 EA
: Elements_Array
renames Container
.Elements
.EA
;
1192 if Before
> Container
.Last
then
1194 -- The new items are being appended to the vector, so no
1195 -- sliding of existing elements is required.
1197 EA
(Before
.. New_Last
) := [others => New_Item
];
1200 -- The new items are being inserted before some existing
1201 -- elements, so we must slide the existing elements up to their
1202 -- new home. We use the wider of Index_Type'Base and
1203 -- Count_Type'Base as the type for intermediate index values.
1205 if Index_Type
'Base'Last >= Count_Type_Last then
1206 Index := Before + Index_Type'Base (Count);
1208 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1211 EA (Index .. New_Last) := EA (Before .. Container.Last);
1212 EA (Before .. Index - 1) := [others => New_Item];
1216 Container.Last := New_Last;
1220 -- In this case, we're inserting elements into a vector that has already
1221 -- allocated an internal array, but the existing array does not have
1222 -- enough storage, so we must allocate a new, longer array. In order to
1223 -- guarantee that the amortized insertion cost is O(1), we always
1224 -- allocate an array whose length is some power-of-two factor of the
1225 -- current array length. (The new array cannot have a length less than
1226 -- the New_Length of the container, but its last index value cannot be
1227 -- greater than Index_Type'Last.)
1229 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1230 while New_Capacity < New_Length loop
1231 if New_Capacity > Count_Type'Last / 2 then
1232 New_Capacity := Count_Type'Last;
1235 New_Capacity := 2 * New_Capacity;
1239 if New_Capacity > Max_Length then
1241 -- We have reached the limit of capacity, so no further expansion
1242 -- will occur. (This is not a problem, as there is never a need to
1243 -- have more capacity than the maximum container length.)
1245 New_Capacity := Max_Length;
1248 -- We have computed the length of the new internal array (and this is
1249 -- what "vector capacity" means), so use that to compute its last index.
1251 if Index_Type'Base'Last
>= Count_Type_Last
then
1252 Dst_Last
:= No_Index
+ Index_Type
'Base (New_Capacity
);
1255 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Capacity
);
1258 -- Now we allocate the new, longer internal array. If the allocation
1259 -- fails, we have not changed any container state, so no side-effect
1260 -- will occur as a result of propagating the exception.
1262 Dst
:= new Elements_Type
(Dst_Last
);
1264 -- We have our new internal array. All that needs to be done now is to
1265 -- copy the existing items (if any) from the old array (the "source"
1266 -- array, object SA below) to the new array (the "destination" array,
1267 -- object DA below), and then deallocate the old array.
1270 SA
: Elements_Array
renames Container
.Elements
.EA
; -- source
1271 DA
: Elements_Array
renames Dst
.EA
; -- destination
1272 pragma Unreferenced
(DA
);
1275 DA
(Index_Type
'First .. Before
- 1) :=
1276 SA
(Index_Type
'First .. Before
- 1);
1278 if Before
> Container
.Last
then
1279 DA
(Before
.. New_Last
) := [others => New_Item
];
1282 -- The new items are being inserted before some existing elements,
1283 -- so we must slide the existing elements up to their new home.
1285 if Index_Type
'Base'Last >= Count_Type_Last then
1286 Index := Before + Index_Type'Base (Count);
1288 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1291 DA (Before .. Index - 1) := [others => New_Item];
1292 DA (Index .. New_Last) := SA (Before .. Container.Last);
1301 -- We have successfully copied the items onto the new array, so the
1302 -- final thing to do is deallocate the old array.
1305 X : Elements_Access := Container.Elements;
1308 -- We first isolate the old internal array, removing it from the
1309 -- container and replacing it with the new internal array, before we
1310 -- deallocate the old array (which can fail if finalization of
1311 -- elements propagates an exception).
1313 Container.Elements := Dst;
1314 Container.Last := New_Last;
1316 -- The container invariants have been restored, so it is now safe to
1317 -- attempt to deallocate the old array.
1323 procedure Insert_Vector
1324 (Container : in out Vector;
1325 Before : Extended_Index;
1328 N : constant Count_Type := Length (New_Item);
1329 J : Index_Type'Base;
1332 -- Use Insert_Space to create the "hole" (the destination slice) into
1333 -- which we copy the source items.
1335 Insert_Space (Container, Before, Count => N);
1339 -- There's nothing else to do here (vetting of parameters was
1340 -- performed already in Insert_Space), so we simply return.
1345 -- We calculate the last index value of the destination slice using the
1346 -- wider of Index_Type'Base and count_Type'Base.
1348 if Index_Type'Base'Last
>= Count_Type_Last
then
1349 J
:= (Before
- 1) + Index_Type
'Base (N
);
1351 J
:= Index_Type
'Base (Count_Type
'Base (Before
- 1) + N
);
1354 if Container
'Address /= New_Item
'Address then
1356 -- This is the simple case. New_Item denotes an object different
1357 -- from Container, so there's nothing special we need to do to copy
1358 -- the source items to their destination, because all of the source
1359 -- items are contiguous.
1361 Container
.Elements
.EA
(Before
.. J
) :=
1362 New_Item
.Elements
.EA
(Index_Type
'First .. New_Item
.Last
);
1367 -- New_Item denotes the same object as Container, so an insertion has
1368 -- potentially split the source items. The destination is always the
1369 -- range [Before, J], but the source is [Index_Type'First, Before) and
1370 -- (J, Container.Last]. We perform the copy in two steps, using each of
1371 -- the two slices of the source items.
1374 L
: constant Index_Type
'Base := Before
- 1;
1376 subtype Src_Index_Subtype
is Index_Type
'Base range
1377 Index_Type
'First .. L
;
1379 Src
: Elements_Array
renames
1380 Container
.Elements
.EA
(Src_Index_Subtype
);
1382 K
: Index_Type
'Base;
1385 -- We first copy the source items that precede the space we
1386 -- inserted. Index value K is the last index of that portion
1387 -- destination that receives this slice of the source. (If Before
1388 -- equals Index_Type'First, then this first source slice will be
1389 -- empty, which is harmless.)
1391 if Index_Type
'Base'Last >= Count_Type_Last then
1392 K := L + Index_Type'Base (Src'Length);
1394 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1397 Container.Elements.EA (Before .. K) := Src;
1399 if Src'Length = N then
1401 -- The new items were effectively appended to the container, so we
1402 -- have already copied all of the items that need to be copied.
1403 -- We return early here, even though the source slice below is
1404 -- empty (so the assignment would be harmless), because we want to
1405 -- avoid computing J + 1, which will overflow if J equals
1406 -- Index_Type'Base'Last
.
1413 -- Note that we want to avoid computing J + 1 here, in case J equals
1414 -- Index_Type'Base'Last. We prevent that by returning early above,
1415 -- immediately after copying the first slice of the source, and
1416 -- determining that this second slice of the source is empty.
1418 F
: constant Index_Type
'Base := J
+ 1;
1420 subtype Src_Index_Subtype
is Index_Type
'Base range
1421 F
.. Container
.Last
;
1423 Src
: Elements_Array
renames
1424 Container
.Elements
.EA
(Src_Index_Subtype
);
1426 K
: Index_Type
'Base;
1429 -- We next copy the source items that follow the space we inserted.
1430 -- Index value K is the first index of that portion of the
1431 -- destination that receives this slice of the source. (For the
1432 -- reasons given above, this slice is guaranteed to be non-empty.)
1434 if Index_Type
'Base'Last >= Count_Type_Last then
1435 K := F - Index_Type'Base (Src'Length);
1437 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1440 Container.Elements.EA (K .. J) := Src;
1444 procedure Insert_Vector
1445 (Container : in out Vector;
1449 Index : Index_Type'Base;
1452 if Checks and then Before.Container /= null
1453 and then Before.Container /= Container'Unrestricted_Access
1455 raise Program_Error with "Before cursor denotes wrong container";
1458 if Is_Empty (New_Item) then
1462 if Before.Container = null or else Before.Index > Container.Last then
1463 if Checks and then Container.Last = Index_Type'Last then
1464 raise Constraint_Error with
1465 "vector is already at its maximum length";
1468 Index := Container.Last + 1;
1471 Index := Before.Index;
1474 Insert_Vector (Container, Index, New_Item);
1477 procedure Insert_Vector
1478 (Container : in out Vector;
1481 Position : out Cursor)
1483 Index : Index_Type'Base;
1486 if Checks and then Before.Container /= null
1487 and then Before.Container /= Container'Unrestricted_Access
1489 raise Program_Error with "Before cursor denotes wrong container";
1492 if Is_Empty (New_Item) then
1493 if Before.Container = null or else Before.Index > Container.Last then
1494 Position := No_Element;
1496 Position := (Container'Unrestricted_Access, Before.Index);
1502 if Before.Container = null or else Before.Index > Container.Last then
1503 if Checks and then Container.Last = Index_Type'Last then
1504 raise Constraint_Error with
1505 "vector is already at its maximum length";
1508 Index := Container.Last + 1;
1511 Index := Before.Index;
1514 Insert_Vector (Container, Index, New_Item);
1516 Position := (Container'Unrestricted_Access, Index);
1520 (Container : in out Vector;
1522 New_Item : Element_Type;
1523 Count : Count_Type := 1)
1525 Index : Index_Type'Base;
1528 if Checks and then Before.Container /= null
1529 and then Before.Container /= Container'Unrestricted_Access
1531 raise Program_Error with "Before cursor denotes wrong container";
1538 if Before.Container = null or else Before.Index > Container.Last then
1539 if Checks and then Container.Last = Index_Type'Last then
1540 raise Constraint_Error with
1541 "vector is already at its maximum length";
1543 Index := Container.Last + 1;
1547 Index := Before.Index;
1550 Insert (Container, Index, New_Item, Count);
1554 (Container : in out Vector;
1556 New_Item : Element_Type;
1557 Position : out Cursor;
1558 Count : Count_Type := 1)
1560 Index : Index_Type'Base;
1563 if Checks and then Before.Container /= null
1564 and then Before.Container /= Container'Unrestricted_Access
1566 raise Program_Error with "Before cursor denotes wrong container";
1570 if Before.Container = null or else Before.Index > Container.Last then
1571 Position := No_Element;
1573 Position := (Container'Unrestricted_Access, Before.Index);
1579 if Before.Container = null or else Before.Index > Container.Last then
1580 if Checks and then Container.Last = Index_Type'Last then
1581 raise Constraint_Error with
1582 "vector is already at its maximum length";
1585 Index := Container.Last + 1;
1588 Index := Before.Index;
1591 Insert (Container, Index, New_Item, Count);
1593 Position := (Container'Unrestricted_Access, Index);
1597 (Container : in out Vector;
1598 Before : Extended_Index;
1599 Count : Count_Type := 1)
1601 New_Item : Element_Type; -- Default-initialized value
1602 pragma Warnings (Off, New_Item);
1605 Insert (Container, Before, New_Item, Count);
1609 (Container : in out Vector;
1611 Position : out Cursor;
1612 Count : Count_Type := 1)
1614 New_Item : Element_Type; -- Default-initialized value
1615 pragma Warnings (Off, New_Item);
1617 Insert (Container, Before, New_Item, Position, Count);
1624 procedure Insert_Space
1625 (Container : in out Vector;
1626 Before : Extended_Index;
1627 Count : Count_Type := 1)
1629 Old_Length : constant Count_Type := Container.Length;
1631 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1632 New_Length : Count_Type'Base; -- sum of current length and Count
1633 New_Last : Index_Type'Base; -- last index of vector after insertion
1635 Index : Index_Type'Base; -- scratch for intermediate values
1636 J : Count_Type'Base; -- scratch
1638 New_Capacity : Count_Type'Base; -- length of new, expanded array
1639 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1640 Dst : Elements_Access; -- new, expanded internal array
1643 -- The tampering bits exist to prevent an item from being harmfully
1644 -- manipulated while it is being visited. Query, Update, and Iterate
1645 -- increment the busy count on entry, and decrement the count on
1646 -- exit. Insert checks the count to determine whether it is being called
1647 -- while the associated callback procedure is executing.
1649 TC_Check (Container.TC);
1652 -- As a precondition on the generic actual Index_Type, the base type
1653 -- must include Index_Type'Pred (Index_Type'First); this is the value
1654 -- that Container.Last assumes when the vector is empty. However, we
1655 -- do not allow that as the value for Index when specifying where the
1656 -- new items should be inserted, so we must manually check. (That the
1657 -- user is allowed to specify the value at all here is a consequence
1658 -- of the declaration of the Extended_Index subtype, which includes
1659 -- the values in the base range that immediately precede and
1660 -- immediately follow the values in the Index_Type.)
1662 if Before < Index_Type'First then
1663 raise Constraint_Error with
1664 "Before index is out of range (too small)";
1667 -- We do allow a value greater than Container.Last to be specified as
1668 -- the Index, but only if it's immediately greater. This allows for
1669 -- the case of appending items to the back end of the vector. (It is
1670 -- assumed that specifying an index value greater than Last + 1
1671 -- indicates some deeper flaw in the caller's algorithm, so that case
1672 -- is treated as a proper error.)
1674 if Before > Container.Last + 1 then
1675 raise Constraint_Error with
1676 "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: we cannot simply add these values, because of the possibility
1693 if Checks and then 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_Last
then
1709 -- We have to handle the case when there might be more values in the
1710 -- range of Index_Type than in the range of Count_Type.
1712 if Index_Type
'First <= 0 then
1714 -- We know that No_Index (the same as Index_Type'First - 1) is
1715 -- less than 0, so it is safe to compute the following sum without
1716 -- fear of overflow. We need to suppress warnings, because
1717 -- otherwise we get an error in -gnatwE mode.
1719 pragma Warnings
(Off
);
1720 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
1721 pragma Warnings
(On
);
1723 if Index
<= Index_Type
'Last then
1725 -- We have determined that range of Index_Type has at least as
1726 -- many values as in Count_Type, so Count_Type'Last is the
1727 -- maximum number of items that are allowed.
1729 Max_Length
:= Count_Type
'Last;
1732 -- The range of Index_Type has fewer values than in Count_Type,
1733 -- so the maximum number of items is computed from the range of
1736 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1740 -- No_Index is equal or greater than 0, so we can safely compute
1741 -- the difference without fear of overflow (which we would have to
1742 -- worry about if No_Index were less than 0, but that case is
1745 if Index_Type
'Last - No_Index
>= Count_Type_Last
then
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 Checks
and then 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_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 order to preserve container invariants, we allocate the new
1825 -- internal array first, before setting the Last index value, in case
1826 -- the allocation fails (which can happen either because there is no
1827 -- storage available, or because default-valued element
1828 -- initialization fails).
1830 Container.Elements := new Elements_Type (New_Last);
1832 -- The allocation of the new, internal array succeeded, so it is now
1833 -- safe to update the Last index, restoring container invariants.
1835 Container.Last := New_Last;
1840 -- An internal array has already been allocated, so we must determine
1841 -- whether there is enough unused storage for the new items.
1843 if New_Last <= Container.Elements.Last then
1845 -- In this case, we're inserting space into a vector that has already
1846 -- allocated an internal array, and the existing array has enough
1847 -- unused storage for the new items.
1850 EA : Elements_Array renames Container.Elements.EA;
1853 if Before <= Container.Last then
1855 -- The space is being inserted before some existing elements,
1856 -- so we must slide the existing elements up to their new
1857 -- home. We use the wider of Index_Type'Base and
1858 -- Count_Type'Base as the type for intermediate index values.
1860 if Index_Type'Base'Last
>= Count_Type_Last
then
1861 Index
:= Before
+ Index_Type
'Base (Count
);
1864 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
1867 EA
(Index
.. New_Last
) := EA
(Before
.. Container
.Last
);
1871 Container
.Last
:= New_Last
;
1875 -- In this case, we're inserting space into a vector that has already
1876 -- allocated an internal array, but the existing array does not have
1877 -- enough storage, so we must allocate a new, longer array. In order to
1878 -- guarantee that the amortized insertion cost is O(1), we always
1879 -- allocate an array whose length is some power-of-two factor of the
1880 -- current array length. (The new array cannot have a length less than
1881 -- the New_Length of the container, but its last index value cannot be
1882 -- greater than Index_Type'Last.)
1884 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
1885 while New_Capacity
< New_Length
loop
1886 if New_Capacity
> Count_Type
'Last / 2 then
1887 New_Capacity
:= Count_Type
'Last;
1891 New_Capacity
:= 2 * New_Capacity
;
1894 if New_Capacity
> Max_Length
then
1896 -- We have reached the limit of capacity, so no further expansion
1897 -- will occur. (This is not a problem, as there is never a need to
1898 -- have more capacity than the maximum container length.)
1900 New_Capacity
:= Max_Length
;
1903 -- We have computed the length of the new internal array (and this is
1904 -- what "vector capacity" means), so use that to compute its last index.
1906 if Index_Type
'Base'Last >= Count_Type_Last then
1907 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1910 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1913 -- Now we allocate the new, longer internal array. If the allocation
1914 -- fails, we have not changed any container state, so no side-effect
1915 -- will occur as a result of propagating the exception.
1917 Dst := new Elements_Type (Dst_Last);
1919 -- We have our new internal array. All that needs to be done now is to
1920 -- copy the existing items (if any) from the old array (the "source"
1921 -- array, object SA below) to the new array (the "destination" array,
1922 -- object DA below), and then deallocate the old array.
1925 SA : Elements_Array renames Container.Elements.EA; -- source
1926 DA : Elements_Array renames Dst.EA; -- destination
1927 pragma Unreferenced (DA);
1930 DA (Index_Type'First .. Before - 1) :=
1931 SA (Index_Type'First .. Before - 1);
1933 if Before <= Container.Last then
1935 -- The space is being inserted before some existing elements, so
1936 -- we must slide the existing elements up to their new home.
1938 if Index_Type'Base'Last
>= Count_Type_Last
then
1939 Index
:= Before
+ Index_Type
'Base (Count
);
1941 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
1944 DA
(Index
.. New_Last
) := SA
(Before
.. Container
.Last
);
1953 -- We have successfully copied the items onto the new array, so the
1954 -- final thing to do is restore invariants, and deallocate the old
1958 X
: Elements_Access
:= Container
.Elements
;
1961 -- We first isolate the old internal array, removing it from the
1962 -- container and replacing it with the new internal array, before we
1963 -- deallocate the old array (which can fail if finalization of
1964 -- elements propagates an exception).
1966 Container
.Elements
:= Dst
;
1967 Container
.Last
:= New_Last
;
1969 -- The container invariants have been restored, so it is now safe to
1970 -- attempt to deallocate the old array.
1976 procedure Insert_Space
1977 (Container
: in out Vector
;
1979 Position
: out Cursor
;
1980 Count
: Count_Type
:= 1)
1982 Index
: Index_Type
'Base;
1985 if Checks
and then Before
.Container
/= null
1986 and then Before
.Container
/= Container
'Unrestricted_Access
1988 raise Program_Error
with "Before cursor denotes wrong container";
1992 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
1993 Position
:= No_Element
;
1995 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2001 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2002 if Checks
and then Container
.Last
= Index_Type
'Last then
2003 raise Constraint_Error
with
2004 "vector is already at its maximum length";
2006 Index
:= Container
.Last
+ 1;
2010 Index
:= Before
.Index
;
2013 Insert_Space
(Container
, Index
, Count
);
2015 Position
:= (Container
'Unrestricted_Access, Index
);
2022 function Is_Empty
(Container
: Vector
) return Boolean is
2024 return Container
.Last
< Index_Type
'First;
2032 (Container
: Vector
;
2033 Process
: not null access procedure (Position
: Cursor
))
2035 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
2037 for Indx
in Index_Type
'First .. Container
.Last
loop
2038 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
2043 (Container : Vector)
2044 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2046 V : constant Vector_Access := Container'Unrestricted_Access;
2048 -- The value of its Index component influences the behavior of the First
2049 -- and Last selector functions of the iterator object. When the Index
2050 -- component is No_Index (as is the case here), this means the iterator
2051 -- object was constructed without a start expression. This is a complete
2052 -- iterator, meaning that the iteration starts from the (logical)
2053 -- beginning of the sequence of items.
2055 -- Note: For a forward iterator, Container.First is the beginning, and
2056 -- for a reverse iterator, Container.Last is the beginning.
2058 return It : constant Iterator :=
2059 (Limited_Controlled with
2063 Busy (Container.TC'Unrestricted_Access.all);
2068 (Container : Vector;
2070 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2072 V : constant Vector_Access := Container'Unrestricted_Access;
2074 -- It was formerly the case that when Start = No_Element, the partial
2075 -- iterator was defined to behave the same as for a complete iterator,
2076 -- and iterate over the entire sequence of items. However, those
2077 -- semantics were unintuitive and arguably error-prone (it is too easy
2078 -- to accidentally create an endless loop), and so they were changed,
2079 -- per the ARG meeting in Denver on 2011/11. However, there was no
2080 -- consensus about what positive meaning this corner case should have,
2081 -- and so it was decided to simply raise an exception. This does imply,
2082 -- however, that it is not possible to use a partial iterator to specify
2083 -- an empty sequence of items.
2086 if Start.Container = null then
2087 raise Constraint_Error with
2088 "Start position for iterator equals No_Element";
2091 if Start.Container /= V then
2092 raise Program_Error with
2093 "Start cursor of Iterate designates wrong vector";
2096 if Start.Index > V.Last then
2097 raise Constraint_Error with
2098 "Start position for iterator equals No_Element";
2102 -- The value of its Index component influences the behavior of the First
2103 -- and Last selector functions of the iterator object. When the Index
2104 -- component is not No_Index (as is the case here), it means that this
2105 -- is a partial iteration, over a subset of the complete sequence of
2106 -- items. The iterator object was constructed with a start expression,
2107 -- indicating the position from which the iteration begins. Note that
2108 -- the start position has the same value irrespective of whether this
2109 -- is a forward or reverse iteration.
2111 return It : constant Iterator :=
2112 (Limited_Controlled with
2114 Index => Start.Index)
2116 Busy (Container.TC'Unrestricted_Access.all);
2124 function Last (Container : Vector) return Cursor is
2126 if Is_Empty (Container) then
2129 return (Container'Unrestricted_Access, Container.Last);
2133 function Last (Object : Iterator) return Cursor is
2135 -- The value of the iterator object's Index component influences the
2136 -- behavior of the Last (and First) selector function.
2138 -- When the Index component is No_Index, this means the iterator
2139 -- object was constructed without a start expression, in which case the
2140 -- (reverse) iteration starts from the (logical) beginning of the entire
2141 -- sequence (corresponding to Container.Last, for a reverse iterator).
2143 -- Otherwise, this is iteration over a partial sequence of items.
2144 -- When the Index component is not No_Index, the iterator object was
2145 -- constructed with a start expression, that specifies the position
2146 -- from which the (reverse) partial iteration begins.
2148 if Object.Index = No_Index then
2149 return Last (Object.Container.all);
2151 return Cursor'(Object
.Container
, Object
.Index
);
2159 function Last_Element
(Container
: Vector
) return Element_Type
is
2161 if Checks
and then Container
.Last
= No_Index
then
2162 raise Constraint_Error
with "Container is empty";
2164 return Container
.Elements
.EA
(Container
.Last
);
2172 function Last_Index
(Container
: Vector
) return Extended_Index
is
2174 return Container
.Last
;
2181 function Length
(Container
: Vector
) return Count_Type
is
2182 L
: constant Index_Type
'Base := Container
.Last
;
2183 F
: constant Index_Type
:= Index_Type
'First;
2186 -- The base range of the index type (Index_Type'Base) might not include
2187 -- all values for length (Count_Type). Contrariwise, the index type
2188 -- might include values outside the range of length. Hence we use
2189 -- whatever type is wider for intermediate values when calculating
2190 -- length. Note that no matter what the index type is, the maximum
2191 -- length to which a vector is allowed to grow is always the minimum
2192 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2194 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2195 -- to have a base range of -128 .. 127, but the corresponding vector
2196 -- would have lengths in the range 0 .. 255. In this case we would need
2197 -- to use Count_Type'Base for intermediate values.
2199 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2200 -- vector would have a maximum length of 10, but the index values lie
2201 -- outside the range of Count_Type (which is only 32 bits). In this
2202 -- case we would need to use Index_Type'Base for intermediate values.
2204 if Count_Type
'Base'Last >= Index_Type'Pos (Index_Type'Base'Last
) then
2205 return Count_Type
'Base (L
) - Count_Type
'Base (F
) + 1;
2207 return Count_Type
(L
- F
+ 1);
2216 (Target
: in out Vector
;
2217 Source
: in out Vector
)
2220 if Target
'Address = Source
'Address then
2224 TC_Check
(Target
.TC
);
2225 TC_Check
(Source
.TC
);
2228 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
2230 Target
.Elements
:= Source
.Elements
;
2231 Source
.Elements
:= Target_Elements
;
2234 Target
.Last
:= Source
.Last
;
2235 Source
.Last
:= No_Index
;
2242 function Next
(Position
: Cursor
) return Cursor
is
2244 if Position
.Container
= null then
2246 elsif Position
.Index
< Position
.Container
.Last
then
2247 return (Position
.Container
, Position
.Index
+ 1);
2253 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2255 if Position
.Container
= null then
2257 elsif Checks
and then Position
.Container
/= Object
.Container
then
2258 raise Program_Error
with
2259 "Position cursor of Next designates wrong vector";
2261 return Next
(Position
);
2265 procedure Next
(Position
: in out Cursor
) is
2267 if Position
.Container
= null then
2269 elsif Position
.Index
< Position
.Container
.Last
then
2270 Position
.Index
:= Position
.Index
+ 1;
2272 Position
:= No_Element
;
2281 (Container
: in out Vector
;
2282 New_Item
: Element_Type
;
2283 Count
: Count_Type
:= 1)
2286 Insert
(Container
, Index_Type
'First, New_Item
, Count
);
2289 --------------------
2290 -- Prepend_Vector --
2291 --------------------
2293 procedure Prepend_Vector
(Container
: in out Vector
; New_Item
: Vector
) is
2295 Insert_Vector
(Container
, Index_Type
'First, New_Item
);
2302 function Previous
(Position
: Cursor
) return Cursor
is
2304 if Position
.Container
= null then
2306 elsif Position
.Index
> Index_Type
'First then
2307 return (Position
.Container
, Position
.Index
- 1);
2313 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2315 if Position
.Container
= null then
2317 elsif Checks
and then Position
.Container
/= Object
.Container
then
2318 raise Program_Error
with
2319 "Position cursor of Previous designates wrong vector";
2321 return Previous
(Position
);
2325 procedure Previous
(Position
: in out Cursor
) is
2327 if Position
.Container
= null then
2329 elsif Position
.Index
> Index_Type
'First then
2330 Position
.Index
:= Position
.Index
- 1;
2332 Position
:= No_Element
;
2336 ----------------------
2337 -- Pseudo_Reference --
2338 ----------------------
2340 function Pseudo_Reference
2341 (Container
: aliased Vector
'Class) return Reference_Control_Type
2343 TC
: constant Tamper_Counts_Access
:= Container
.TC
'Unrestricted_Access;
2345 return R
: constant Reference_Control_Type
:= (Controlled
with TC
) do
2348 end Pseudo_Reference
;
2355 (S
: in out Ada
.Strings
.Text_Buffers
.Root_Buffer_Type
'Class; V
: Vector
)
2357 First_Time
: Boolean := True;
2358 use System
.Put_Images
;
2364 First_Time
:= False;
2366 Simple_Array_Between
(S
);
2369 Element_Type
'Put_Image (S
, X
);
2379 procedure Query_Element
2380 (Container
: Vector
;
2382 Process
: not null access procedure (Element
: Element_Type
))
2384 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
2386 if Checks
and then Index
> Container
.Last
then
2387 raise Constraint_Error
with "Index is out of range";
2390 Process
(Container
.Elements
.EA
(Index
));
2393 procedure Query_Element
2395 Process
: not null access procedure (Element
: Element_Type
))
2398 if Checks
and then Position
.Container
= null then
2399 raise Constraint_Error
with "Position cursor has no element";
2401 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
2410 (Stream
: not null access Root_Stream_Type
'Class;
2411 Container
: out Vector
)
2413 Length
: Count_Type
'Base;
2414 Last
: Index_Type
'Base := No_Index
;
2419 Count_Type
'Base'Read (Stream, Length);
2421 if Length > Capacity (Container) then
2422 Reserve_Capacity (Container, Capacity => Length);
2425 for J in Count_Type range 1 .. Length loop
2427 Element_Type'Read (Stream, Container.Elements.EA (Last));
2428 Container.Last := Last;
2433 (Stream : not null access Root_Stream_Type'Class;
2434 Position : out Cursor)
2437 raise Program_Error with "attempt to stream vector cursor";
2441 (Stream : not null access Root_Stream_Type'Class;
2442 Item : out Reference_Type)
2445 raise Program_Error with "attempt to stream reference";
2449 (Stream : not null access Root_Stream_Type'Class;
2450 Item : out Constant_Reference_Type)
2453 raise Program_Error with "attempt to stream reference";
2461 (Container : aliased in out Vector;
2462 Position : Cursor) return Reference_Type
2466 if Position.Container = null then
2467 raise Constraint_Error with "Position cursor has no element";
2470 if Position.Container /= Container'Unrestricted_Access then
2471 raise Program_Error with "Position cursor denotes wrong container";
2474 if Position.Index > Position.Container.Last then
2475 raise Constraint_Error with "Position cursor is out of range";
2480 TC : constant Tamper_Counts_Access :=
2481 Container.TC'Unrestricted_Access;
2483 return R : constant Reference_Type :=
2484 (Element => Container.Elements.EA (Position.Index)'Access,
2485 Control => (Controlled with TC))
2493 (Container : aliased in out Vector;
2494 Index : Index_Type) return Reference_Type
2497 if Checks and then Index > Container.Last then
2498 raise Constraint_Error with "Index is out of range";
2502 TC : constant Tamper_Counts_Access :=
2503 Container.TC'Unrestricted_Access;
2505 return R : constant Reference_Type :=
2506 (Element => Container.Elements.EA (Index)'Access,
2507 Control => (Controlled with TC))
2514 ---------------------
2515 -- Replace_Element --
2516 ---------------------
2518 procedure Replace_Element
2519 (Container : in out Vector;
2521 New_Item : Element_Type)
2524 TE_Check (Container.TC);
2526 if Checks and then Index > Container.Last then
2527 raise Constraint_Error with "Index is out of range";
2530 Container.Elements.EA (Index) := New_Item;
2531 end Replace_Element;
2533 procedure Replace_Element
2534 (Container : in out Vector;
2536 New_Item : Element_Type)
2539 TE_Check (Container.TC);
2542 if Position.Container = null then
2543 raise Constraint_Error with "Position cursor has no element";
2545 elsif Position.Container /= Container'Unrestricted_Access then
2546 raise Program_Error with "Position cursor denotes wrong container";
2548 elsif Position.Index > Container.Last then
2549 raise Constraint_Error with "Position cursor is out of range";
2553 Container.Elements.EA (Position.Index) := New_Item;
2554 end Replace_Element;
2556 ----------------------
2557 -- Reserve_Capacity --
2558 ----------------------
2560 procedure Reserve_Capacity
2561 (Container : in out Vector;
2562 Capacity : Count_Type)
2564 N : constant Count_Type := Length (Container);
2566 Index : Count_Type'Base;
2567 Last : Index_Type'Base;
2570 -- Reserve_Capacity can be used to either expand the storage available
2571 -- for elements (this would be its typical use, in anticipation of
2572 -- future insertion), or to trim back storage. In the latter case,
2573 -- storage can only be trimmed back to the limit of the container
2574 -- length. Note that Reserve_Capacity neither deletes (active) elements
2575 -- nor inserts elements; it only affects container capacity, never
2576 -- container length.
2578 if Capacity = 0 then
2580 -- This is a request to trim back storage, to the minimum amount
2581 -- possible given the current state of the container.
2585 -- The container is empty, so in this unique case we can
2586 -- deallocate the entire internal array. Note that an empty
2587 -- container can never be busy, so there's no need to check the
2591 X : Elements_Access := Container.Elements;
2594 -- First we remove the internal array from the container, to
2595 -- handle the case when the deallocation raises an exception.
2597 Container.Elements := null;
2599 -- Container invariants have been restored, so it is now safe
2600 -- to attempt to deallocate the internal array.
2605 elsif N < Container.Elements.EA'Length then
2607 -- The container is not empty, and the current length is less than
2608 -- the current capacity, so there's storage available to trim. In
2609 -- this case, we allocate a new internal array having a length
2610 -- that exactly matches the number of items in the
2611 -- container. (Reserve_Capacity does not delete active elements,
2612 -- so this is the best we can do with respect to minimizing
2615 TC_Check (Container.TC);
2618 subtype Src_Index_Subtype is Index_Type'Base range
2619 Index_Type'First .. Container.Last;
2621 Src : Elements_Array renames
2622 Container.Elements.EA (Src_Index_Subtype);
2624 X : Elements_Access := Container.Elements;
2627 -- Although we have isolated the old internal array that we're
2628 -- going to deallocate, we don't deallocate it until we have
2629 -- successfully allocated a new one. If there is an exception
2630 -- during allocation (either because there is not enough
2631 -- storage, or because initialization of the elements fails),
2632 -- we let it propagate without causing any side-effect.
2634 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
2636 -- We have successfully allocated a new internal array (with a
2637 -- smaller length than the old one, and containing a copy of
2638 -- just the active elements in the container), so it is now
2639 -- safe to attempt to deallocate the old array. The old array
2640 -- has been isolated, and container invariants have been
2641 -- restored, so if the deallocation fails (because finalization
2642 -- of the elements fails), we simply let it propagate.
2651 -- Reserve_Capacity can be used to expand the storage available for
2652 -- elements, but we do not let the capacity grow beyond the number of
2653 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2654 -- to refer to the elements with an index value greater than
2655 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2656 -- the Last index value of the new internal array, in a way that avoids
2657 -- any possibility of overflow.
2659 if Index_Type
'Base'Last >= Count_Type_Last then
2661 -- We perform a two-part test. First we determine whether the
2662 -- computed Last value lies in the base range of the type, and then
2663 -- determine whether it lies in the range of the index (sub)type.
2665 -- Last must satisfy this relation:
2666 -- First + Length - 1 <= Last
2667 -- We regroup terms:
2668 -- First - 1 <= Last - Length
2669 -- Which can rewrite as:
2670 -- No_Index <= Last - Length
2673 Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
2675 raise Constraint_Error
with "Capacity is out of range";
2678 -- We now know that the computed value of Last is within the base
2679 -- range of the type, so it is safe to compute its value:
2681 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
2683 -- Finally we test whether the value is within the range of the
2684 -- generic actual index subtype:
2686 if Checks
and then Last
> Index_Type
'Last then
2687 raise Constraint_Error
with "Capacity is out of range";
2690 elsif Index_Type
'First <= 0 then
2692 -- Here we can compute Last directly, in the normal way. We know that
2693 -- No_Index is less than 0, so there is no danger of overflow when
2694 -- adding the (positive) value of Capacity.
2696 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
2698 if Checks
and then Index
> Count_Type
'Base (Index_Type
'Last) then
2699 raise Constraint_Error
with "Capacity is out of range";
2702 -- We know that the computed value (having type Count_Type) of Last
2703 -- is within the range of the generic actual index subtype, so it is
2704 -- safe to convert to Index_Type:
2706 Last
:= Index_Type
'Base (Index
);
2709 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2710 -- must test the length indirectly (by working backwards from the
2711 -- largest possible value of Last), in order to prevent overflow.
2713 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
2715 if Checks
and then Index
< Count_Type
'Base (No_Index
) then
2716 raise Constraint_Error
with "Capacity is out of range";
2719 -- We have determined that the value of Capacity would not create a
2720 -- Last index value outside of the range of Index_Type, so we can now
2721 -- safely compute its value.
2723 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
2726 -- The requested capacity is non-zero, but we don't know yet whether
2727 -- this is a request for expansion or contraction of storage.
2729 if Container
.Elements
= null then
2731 -- The container is empty (it doesn't even have an internal array),
2732 -- so this represents a request to allocate (expand) storage having
2733 -- the given capacity.
2735 Container
.Elements
:= new Elements_Type
(Last
);
2739 if Capacity
<= N
then
2741 -- This is a request to trim back storage, but only to the limit of
2742 -- what's already in the container. (Reserve_Capacity never deletes
2743 -- active elements, it only reclaims excess storage.)
2745 if N
< Container
.Elements
.EA
'Length then
2747 -- The container is not empty (because the requested capacity is
2748 -- positive, and less than or equal to the container length), and
2749 -- the current length is less than the current capacity, so
2750 -- there's storage available to trim. In this case, we allocate a
2751 -- new internal array having a length that exactly matches the
2752 -- number of items in the container.
2754 TC_Check
(Container
.TC
);
2757 subtype Src_Index_Subtype
is Index_Type
'Base range
2758 Index_Type
'First .. Container
.Last
;
2760 Src
: Elements_Array
renames
2761 Container
.Elements
.EA
(Src_Index_Subtype
);
2763 X
: Elements_Access
:= Container
.Elements
;
2766 -- Although we have isolated the old internal array that we're
2767 -- going to deallocate, we don't deallocate it until we have
2768 -- successfully allocated a new one. If there is an exception
2769 -- during allocation (either because there is not enough
2770 -- storage, or because initialization of the elements fails),
2771 -- we let it propagate without causing any side-effect.
2773 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
2775 -- We have successfully allocated a new internal array (with a
2776 -- smaller length than the old one, and containing a copy of
2777 -- just the active elements in the container), so it is now
2778 -- safe to attempt to deallocate the old array. The old array
2779 -- has been isolated, and container invariants have been
2780 -- restored, so if the deallocation fails (because finalization
2781 -- of the elements fails), we simply let it propagate.
2790 -- The requested capacity is larger than the container length (the
2791 -- number of active elements). Whether this represents a request for
2792 -- expansion or contraction of the current capacity depends on what the
2793 -- current capacity is.
2795 if Capacity = Container.Elements.EA'Length then
2797 -- The requested capacity matches the existing capacity, so there's
2798 -- nothing to do here. We treat this case as a no-op, and simply
2799 -- return without checking the busy bit.
2804 -- There is a change in the capacity of a non-empty container, so a new
2805 -- internal array will be allocated. (The length of the new internal
2806 -- array could be less or greater than the old internal array. We know
2807 -- only that the length of the new internal array is greater than the
2808 -- number of active elements in the container.) We must check whether
2809 -- the container is busy before doing anything else.
2811 TC_Check (Container.TC);
2813 -- We now allocate a new internal array, having a length different from
2814 -- its current value.
2817 E : Elements_Access := new Elements_Type (Last);
2820 -- We have successfully allocated the new internal array. We first
2821 -- attempt to copy the existing elements from the old internal array
2822 -- ("src" elements) onto the new internal array ("tgt" elements).
2825 subtype Index_Subtype is Index_Type'Base range
2826 Index_Type'First .. Container.Last;
2828 Src : Elements_Array renames
2829 Container.Elements.EA (Index_Subtype);
2831 Tgt : Elements_Array renames E.EA (Index_Subtype);
2842 -- We have successfully copied the existing elements onto the new
2843 -- internal array, so now we can attempt to deallocate the old one.
2846 X : Elements_Access := Container.Elements;
2849 -- First we isolate the old internal array, and replace it in the
2850 -- container with the new internal array.
2852 Container.Elements := E;
2854 -- Container invariants have been restored, so it is now safe to
2855 -- attempt to deallocate the old internal array.
2860 end Reserve_Capacity;
2862 ----------------------
2863 -- Reverse_Elements --
2864 ----------------------
2866 procedure Reverse_Elements (Container : in out Vector) is
2868 if Container.Length <= 1 then
2872 -- The exception behavior for the vector container must match that for
2873 -- the list container, so we check for cursor tampering here (which will
2874 -- catch more things) instead of for element tampering (which will catch
2875 -- fewer things). It's true that the elements of this vector container
2876 -- could be safely moved around while (say) an iteration is taking place
2877 -- (iteration only increments the busy counter), and so technically
2878 -- all we would need here is a test for element tampering (indicated
2879 -- by the lock counter), that's simply an artifact of our array-based
2880 -- implementation. Logically Reverse_Elements requires a check for
2881 -- cursor tampering.
2883 TC_Check (Container.TC);
2888 E : Elements_Type renames Container.Elements.all;
2891 K := Index_Type'First;
2892 J := Container.Last;
2895 EK : constant Element_Type := E.EA (K);
2897 E.EA (K) := E.EA (J);
2905 end Reverse_Elements;
2911 function Reverse_Find
2912 (Container : Vector;
2913 Item : Element_Type;
2914 Position : Cursor := No_Element) return Cursor
2916 Last : Index_Type'Base;
2919 if Checks and then Position.Container /= null
2920 and then Position.Container /= Container'Unrestricted_Access
2922 raise Program_Error with "Position cursor denotes wrong container";
2926 (if Position.Container = null or else Position.Index > Container.Last
2928 else Position.Index);
2930 -- Per AI05-0022, the container implementation is required to detect
2931 -- element tampering by a generic actual subprogram.
2934 Lock : With_Lock (Container.TC'Unrestricted_Access);
2936 for Indx in reverse Index_Type'First .. Last loop
2937 if Container.Elements.EA (Indx) = Item then
2938 return Cursor'(Container
'Unrestricted_Access, Indx
);
2946 ------------------------
2947 -- Reverse_Find_Index --
2948 ------------------------
2950 function Reverse_Find_Index
2951 (Container
: Vector
;
2952 Item
: Element_Type
;
2953 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
2955 -- Per AI05-0022, the container implementation is required to detect
2956 -- element tampering by a generic actual subprogram.
2958 Lock
: With_Lock
(Container
.TC
'Unrestricted_Access);
2960 Last
: constant Index_Type
'Base :=
2961 Index_Type
'Min (Container
.Last
, Index
);
2964 for Indx
in reverse Index_Type
'First .. Last
loop
2965 if Container
.Elements
.EA
(Indx
) = Item
then
2971 end Reverse_Find_Index
;
2973 ---------------------
2974 -- Reverse_Iterate --
2975 ---------------------
2977 procedure Reverse_Iterate
2978 (Container
: Vector
;
2979 Process
: not null access procedure (Position
: Cursor
))
2981 Busy
: With_Busy
(Container
.TC
'Unrestricted_Access);
2983 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
2984 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
2986 end Reverse_Iterate;
2992 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2993 Count : constant Count_Type'Base := Container.Length - Length;
2996 -- Set_Length allows the user to set the length explicitly, instead
2997 -- of implicitly as a side-effect of deletion or insertion. If the
2998 -- requested length is less than the current length, this is equivalent
2999 -- to deleting items from the back end of the vector. If the requested
3000 -- length is greater than the current length, then this is equivalent
3001 -- to inserting "space" (nonce items) at the end.
3004 Container.Delete_Last (Count);
3006 elsif Checks and then Container.Last >= Index_Type'Last then
3007 raise Constraint_Error with "vector is already at its maximum length";
3010 Container.Insert_Space (Container.Last + 1, -Count);
3018 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3020 TE_Check (Container.TC);
3023 if I > Container.Last then
3024 raise Constraint_Error with "I index is out of range";
3027 if J > Container.Last then
3028 raise Constraint_Error with "J index is out of range";
3037 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3039 Container.Elements.EA (I) := Container.Elements.EA (J);
3040 Container.Elements.EA (J) := EI_Copy;
3044 procedure Swap (Container : in out Vector; I, J : Cursor) is
3047 if I.Container = null then
3048 raise Constraint_Error with "I cursor has no element";
3050 elsif J.Container = null then
3051 raise Constraint_Error with "J cursor has no element";
3053 elsif I.Container /= Container'Unrestricted_Access then
3054 raise Program_Error with "I cursor denotes wrong container";
3056 elsif J.Container /= Container'Unrestricted_Access then
3057 raise Program_Error with "J cursor denotes wrong container";
3061 Swap (Container, I.Index, J.Index);
3069 (Container : Vector;
3070 Index : Extended_Index) return Cursor
3073 if Index not in Index_Type'First .. Container.Last then
3076 return (Container'Unrestricted_Access, Index);
3084 function To_Index (Position : Cursor) return Extended_Index is
3086 if Position.Container = null then
3088 elsif Position.Index <= Position.Container.Last then
3089 return Position.Index;
3099 function To_Vector (Length : Count_Type) return Vector is
3100 Index : Count_Type'Base;
3101 Last : Index_Type'Base;
3102 Elements : Elements_Access;
3106 return Empty_Vector;
3109 -- We create a vector object with a capacity that matches the specified
3110 -- Length, but we do not allow the vector capacity (the length of the
3111 -- internal array) to exceed the number of values in Index_Type'Range
3112 -- (otherwise, there would be no way to refer to those components via an
3113 -- index). We must therefore check whether the specified Length would
3114 -- create a Last index value greater than Index_Type'Last.
3116 if Index_Type'Base'Last
>= Count_Type_Last
then
3118 -- We perform a two-part test. First we determine whether the
3119 -- computed Last value lies in the base range of the type, and then
3120 -- determine whether it lies in the range of the index (sub)type.
3122 -- Last must satisfy this relation:
3123 -- First + Length - 1 <= Last
3124 -- We regroup terms:
3125 -- First - 1 <= Last - Length
3126 -- Which can rewrite as:
3127 -- No_Index <= Last - Length
3130 Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index
3132 raise Constraint_Error with "Length is out of range";
3135 -- We now know that the computed value of Last is within the base
3136 -- range of the type, so it is safe to compute its value:
3138 Last := No_Index + Index_Type'Base (Length);
3140 -- Finally we test whether the value is within the range of the
3141 -- generic actual index subtype:
3143 if Checks and then Last > Index_Type'Last then
3144 raise Constraint_Error with "Length is out of range";
3147 elsif Index_Type'First <= 0 then
3149 -- Here we can compute Last directly, in the normal way. We know that
3150 -- No_Index is less than 0, so there is no danger of overflow when
3151 -- adding the (positive) value of Length.
3153 Index := Count_Type'Base (No_Index) + Length; -- Last
3155 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
3156 raise Constraint_Error with "Length is out of range";
3159 -- We know that the computed value (having type Count_Type) of Last
3160 -- is within the range of the generic actual index subtype, so it is
3161 -- safe to convert to Index_Type:
3163 Last := Index_Type'Base (Index);
3166 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3167 -- must test the length indirectly (by working backwards from the
3168 -- largest possible value of Last), in order to prevent overflow.
3170 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3172 if Checks and then Index < Count_Type'Base (No_Index) then
3173 raise Constraint_Error with "Length is out of range";
3176 -- We have determined that the value of Length would not create a
3177 -- Last index value outside of the range of Index_Type, so we can now
3178 -- safely compute its value.
3180 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3183 Elements := new Elements_Type (Last);
3185 return Vector'(Controlled
with Elements
, Last
, TC
=> <>);
3189 (New_Item
: Element_Type
;
3190 Length
: Count_Type
) return Vector
3192 Index
: Count_Type
'Base;
3193 Last
: Index_Type
'Base;
3194 Elements
: Elements_Access
;
3198 return Empty_Vector
;
3201 -- We create a vector object with a capacity that matches the specified
3202 -- Length, but we do not allow the vector capacity (the length of the
3203 -- internal array) to exceed the number of values in Index_Type'Range
3204 -- (otherwise, there would be no way to refer to those components via an
3205 -- index). We must therefore check whether the specified Length would
3206 -- create a Last index value greater than Index_Type'Last.
3208 if Index_Type
'Base'Last >= Count_Type_Last then
3210 -- We perform a two-part test. First we determine whether the
3211 -- computed Last value lies in the base range of the type, and then
3212 -- determine whether it lies in the range of the index (sub)type.
3214 -- Last must satisfy this relation:
3215 -- First + Length - 1 <= Last
3216 -- We regroup terms:
3217 -- First - 1 <= Last - Length
3218 -- Which can rewrite as:
3219 -- No_Index <= Last - Length
3222 Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
3224 raise Constraint_Error
with "Length is out of range";
3227 -- We now know that the computed value of Last is within the base
3228 -- range of the type, so it is safe to compute its value:
3230 Last
:= No_Index
+ Index_Type
'Base (Length
);
3232 -- Finally we test whether the value is within the range of the
3233 -- generic actual index subtype:
3235 if Checks
and then Last
> Index_Type
'Last then
3236 raise Constraint_Error
with "Length is out of range";
3239 elsif Index_Type
'First <= 0 then
3241 -- Here we can compute Last directly, in the normal way. We know that
3242 -- No_Index is less than 0, so there is no danger of overflow when
3243 -- adding the (positive) value of Length.
3245 Index
:= Count_Type
'Base (No_Index
) + Length
; -- same value as V.Last
3247 if Checks
and then Index
> Count_Type
'Base (Index_Type
'Last) then
3248 raise Constraint_Error
with "Length is out of range";
3251 -- We know that the computed value (having type Count_Type) of Last
3252 -- is within the range of the generic actual index subtype, so it is
3253 -- safe to convert to Index_Type:
3255 Last
:= Index_Type
'Base (Index
);
3258 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3259 -- must test the length indirectly (by working backwards from the
3260 -- largest possible value of Last), in order to prevent overflow.
3262 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
3264 if Checks
and then Index
< Count_Type
'Base (No_Index
) then
3265 raise Constraint_Error
with "Length is out of range";
3268 -- We have determined that the value of Length would not create a
3269 -- Last index value outside of the range of Index_Type, so we can now
3270 -- safely compute its value.
3272 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
3275 Elements
:= new Elements_Type
'(Last, EA => [others => New_Item]);
3277 return (Controlled with Elements, Last, TC => <>);
3280 --------------------
3281 -- Update_Element --
3282 --------------------
3284 procedure Update_Element
3285 (Container : in out Vector;
3287 Process : not null access procedure (Element : in out Element_Type))
3289 Lock : With_Lock (Container.TC'Unchecked_Access);
3291 if Checks and then Index > Container.Last then
3292 raise Constraint_Error with "Index is out of range";
3295 Process (Container.Elements.EA (Index));
3298 procedure Update_Element
3299 (Container : in out Vector;
3301 Process : not null access procedure (Element : in out Element_Type))
3305 if Position.Container = null then
3306 raise Constraint_Error with "Position cursor has no element";
3307 elsif Position.Container /= Container'Unrestricted_Access then
3308 raise Program_Error with "Position cursor denotes wrong container";
3312 Update_Element (Container, Position.Index, Process);
3320 (Stream : not null access Root_Stream_Type'Class;
3324 Count_Type'Base'Write
(Stream
, Length
(Container
));
3326 for J
in Index_Type
'First .. Container
.Last
loop
3327 Element_Type
'Write (Stream
, Container
.Elements
.EA
(J
));
3332 (Stream
: not null access Root_Stream_Type
'Class;
3336 raise Program_Error
with "attempt to stream vector cursor";
3340 (Stream
: not null access Root_Stream_Type
'Class;
3341 Item
: Reference_Type
)
3344 raise Program_Error
with "attempt to stream reference";
3348 (Stream
: not null access Root_Stream_Type
'Class;
3349 Item
: Constant_Reference_Type
)
3352 raise Program_Error
with "attempt to stream reference";
3355 end Ada
.Containers
.Vectors
;