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-2020, 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
621 Unbusy (Object.Container.TC);
631 Position : Cursor := No_Element) return Cursor
634 if Checks and then Position.Container /= null then
635 if Position.Container /= Container'Unrestricted_Access then
636 raise Program_Error with "Position cursor denotes wrong container";
639 if Position.Index > Container.Last then
640 raise Program_Error with "Position index is out of range";
644 -- Per AI05-0022, the container implementation is required to detect
645 -- element tampering by a generic actual subprogram.
648 Lock : With_Lock (Container.TC'Unrestricted_Access);
650 for J in Position.Index .. Container.Last loop
651 if Container.Elements.EA (J) = Item then
652 return Cursor'(Container'Unrestricted_Access, J);
667 Index : Index_Type := Index_Type'First) return Extended_Index
669 -- Per AI05-0022, the container implementation is required to detect
670 -- element tampering by a generic actual subprogram.
672 Lock : With_Lock (Container.TC'Unrestricted_Access);
674 for Indx in Index .. Container.Last loop
675 if Container.Elements.EA (Indx) = Item then
687 function First (Container : Vector) return Cursor is
689 if Is_Empty (Container) then
693 return (Container'Unrestricted_Access, Index_Type'First);
696 function First (Object : Iterator) return Cursor is
698 -- The value of the iterator object's Index component influences the
699 -- behavior of the First (and Last) selector function.
701 -- When the Index component is No_Index, this means the iterator
702 -- object was constructed without a start expression, in which case the
703 -- (forward) iteration starts from the (logical) beginning of the entire
704 -- sequence of items (corresponding to Container.First, for a forward
707 -- Otherwise, this is iteration over a partial sequence of items.
708 -- When the Index component isn't No_Index, the iterator object was
709 -- constructed with a start expression, that specifies the position
710 -- from which the (forward) partial iteration begins.
712 if Object.Index = No_Index then
713 return First (Object.Container.all);
715 return Cursor'(Object.Container, Object.Index);
723 function First_Element (Container : Vector) return Element_Type is
725 if Checks and then Container.Last = No_Index then
726 raise Constraint_Error with "Container is empty";
728 return Container.Elements.EA (Index_Type'First);
736 function First_Index (Container : Vector) return Index_Type is
737 pragma Unreferenced (Container);
739 return Index_Type'First;
742 ---------------------
743 -- Generic_Sorting --
744 ---------------------
746 package body Generic_Sorting is
752 function Is_Sorted (Container : Vector) return Boolean is
754 if Container.Last <= Index_Type'First then
758 -- Per AI05-0022, the container implementation is required to detect
759 -- element tampering by a generic actual subprogram.
762 Lock : With_Lock (Container.TC'Unrestricted_Access);
763 EA : Elements_Array renames Container.Elements.EA;
765 for J in Index_Type'First .. Container.Last - 1 loop
766 if EA (J + 1) < EA (J) then
779 procedure Merge (Target, Source : in out Vector) is
780 I : Index_Type'Base := Target.Last;
784 -- The semantics of Merge changed slightly per AI05-0021. It was
785 -- originally the case that if Target and Source denoted the same
786 -- container object, then the GNAT implementation of Merge did
787 -- nothing. However, it was argued that RM05 did not precisely
788 -- specify the semantics for this corner case. The decision of the
789 -- ARG was that if Target and Source denote the same non-empty
790 -- container object, then Program_Error is raised.
792 if Source.Last < Index_Type'First then -- Source is empty
796 if Checks and then Target'Address = Source'Address then
797 raise Program_Error with
798 "Target and Source denote same non-empty container";
801 if Target.Last < Index_Type'First then -- Target is empty
802 Move (Target => Target, Source => Source);
806 TC_Check (Source.TC);
808 Target.Set_Length (Length (Target) + Length (Source));
810 -- Per AI05-0022, the container implementation is required to detect
811 -- element tampering by a generic actual subprogram.
814 TA : Elements_Array renames Target.Elements.EA;
815 SA : Elements_Array renames Source.Elements.EA;
817 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
818 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
821 while Source.Last >= Index_Type'First loop
822 pragma Assert (Source.Last <= Index_Type'First
823 or else not (SA (Source.Last) <
824 SA (Source.Last - 1)));
826 if I < Index_Type'First then
827 TA (Index_Type'First .. J) :=
828 SA (Index_Type'First .. Source.Last);
830 Source.Last := No_Index;
834 pragma Assert (I <= Index_Type'First
835 or else not (TA (I) < TA (I - 1)));
837 if SA (Source.Last) < TA (I) then
842 TA (J) := SA (Source.Last);
843 Source.Last := Source.Last - 1;
855 procedure Sort (Container : in out Vector) is
857 new Generic_Array_Sort
858 (Index_Type => Index_Type,
859 Element_Type => Element_Type,
860 Array_Type => Elements_Array,
864 if Container.Last <= Index_Type'First then
868 -- The exception behavior for the vector container must match that
869 -- for the list container, so we check for cursor tampering here
870 -- (which will catch more things) instead of for element tampering
871 -- (which will catch fewer things). It's true that the elements of
872 -- this vector container could be safely moved around while (say) an
873 -- iteration is taking place (iteration only increments the busy
874 -- counter), and so technically all we would need here is a test for
875 -- element tampering (indicated by the lock counter), that's simply
876 -- an artifact of our array-based implementation. Logically Sort
877 -- requires a check for cursor tampering.
879 TC_Check (Container.TC);
881 -- Per AI05-0022, the container implementation is required to detect
882 -- element tampering by a generic actual subprogram.
885 Lock : With_Lock (Container.TC'Unchecked_Access);
887 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
893 ------------------------
894 -- Get_Element_Access --
895 ------------------------
897 function Get_Element_Access
898 (Position : Cursor) return not null Element_Access is
900 return Position.Container.Elements.EA (Position.Index)'Access;
901 end Get_Element_Access;
907 function Has_Element (Position : Cursor) return Boolean is
909 return Position /= No_Element;
917 (Container : in out Vector;
918 Before : Extended_Index;
919 New_Item : Element_Type;
920 Count : Count_Type := 1)
922 Old_Length : constant Count_Type := Container.Length;
924 Max_Length : Count_Type'Base; -- determined from range of Index_Type
925 New_Length : Count_Type'Base; -- sum of current length and Count
926 New_Last : Index_Type'Base; -- last index of vector after insertion
928 Index : Index_Type'Base; -- scratch for intermediate values
929 J : Count_Type'Base; -- scratch
931 New_Capacity : Count_Type'Base; -- length of new, expanded array
932 Dst_Last : Index_Type'Base; -- last index of new, expanded array
933 Dst : Elements_Access; -- new, expanded internal array
937 -- As a precondition on the generic actual Index_Type, the base type
938 -- must include Index_Type'Pred (Index_Type'First); this is the value
939 -- that Container.Last assumes when the vector is empty. However, we
940 -- do not allow that as the value for Index when specifying where the
941 -- new items should be inserted, so we must manually check. (That the
942 -- user is allowed to specify the value at all here is a consequence
943 -- of the declaration of the Extended_Index subtype, which includes
944 -- the values in the base range that immediately precede and
945 -- immediately follow the values in the Index_Type.)
947 if Before < Index_Type'First then
948 raise Constraint_Error with
949 "Before index is out of range (too small)";
952 -- We do allow a value greater than Container.Last to be specified as
953 -- the Index, but only if it's immediately greater. This allows for
954 -- the case of appending items to the back end of the vector. (It is
955 -- assumed that specifying an index value greater than Last + 1
956 -- indicates some deeper flaw in the caller's algorithm, so that case
957 -- is treated as a proper error.)
959 if Before > Container.Last + 1 then
960 raise Constraint_Error with
961 "Before index is out of range (too large)";
965 -- We treat inserting 0 items into the container as a no-op, even when
966 -- the container is busy, so we simply return.
972 -- There are two constraints we need to satisfy. The first constraint is
973 -- that a container cannot have more than Count_Type'Last elements, so
974 -- we must check the sum of the current length and the insertion count.
975 -- Note: we cannot simply add these values, because of the possibility
978 if Checks and then Old_Length > Count_Type'Last - Count then
979 raise Constraint_Error with "Count is out of range";
982 -- It is now safe compute the length of the new vector, without fear of
985 New_Length := Old_Length + Count;
987 -- The second constraint is that the new Last index value cannot exceed
988 -- Index_Type'Last. In each branch below, we calculate the maximum
989 -- length (computed from the range of values in Index_Type), and then
990 -- compare the new length to the maximum length. If the new length is
991 -- acceptable, then we compute the new last index from that.
993 if Index_Type'Base'Last >= Count_Type_Last then
995 -- We have to handle the case when there might be more values in the
996 -- range of Index_Type than in the range of Count_Type.
998 if Index_Type'First <= 0 then
1000 -- We know that No_Index (the same as Index_Type'First - 1) is
1001 -- less than 0, so it is safe to compute the following sum without
1002 -- fear of overflow. We need to suppress warnings, because
1003 -- otherwise we get an error in -gnatwE mode.
1005 pragma Warnings (Off);
1006 Index := No_Index + Index_Type'Base (Count_Type'Last);
1007 pragma Warnings (On);
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. We need to suppress warnings, because
1664 -- otherwise we get an error in -gnatwE mode.
1666 pragma Warnings (Off);
1667 Index := No_Index + Index_Type'Base (Count_Type'Last);
1668 pragma Warnings (On);
1670 if Index <= Index_Type'Last then
1672 -- We have determined that range of Index_Type has at least as
1673 -- many values as in Count_Type, so Count_Type'Last is the
1674 -- maximum number of items that are allowed.
1676 Max_Length := Count_Type'Last;
1679 -- The range of Index_Type has fewer values than in Count_Type,
1680 -- so the maximum number of items is computed from the range of
1683 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1687 -- No_Index is equal or greater than 0, so we can safely compute
1688 -- the difference without fear of overflow (which we would have to
1689 -- worry about if No_Index were less than 0, but that case is
1692 if Index_Type'Last - No_Index >= Count_Type_Last then
1693 -- We have determined that range of Index_Type has at least as
1694 -- many values as in Count_Type, so Count_Type'Last is the
1695 -- maximum number of items that are allowed.
1697 Max_Length := Count_Type'Last;
1700 -- The range of Index_Type has fewer values than in Count_Type,
1701 -- so the maximum number of items is computed from the range of
1704 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1708 elsif Index_Type'First <= 0 then
1710 -- We know that No_Index (the same as Index_Type'First - 1) is less
1711 -- than 0, so it is safe to compute the following sum without fear of
1714 J := Count_Type'Base (No_Index) + Count_Type'Last;
1716 if J <= Count_Type'Base (Index_Type'Last) then
1718 -- We have determined that range of Index_Type has at least as
1719 -- many values as in Count_Type, so Count_Type'Last is the maximum
1720 -- number of items that are allowed.
1722 Max_Length := Count_Type'Last;
1725 -- The range of Index_Type has fewer values than Count_Type does,
1726 -- so the maximum number of items is computed from the range of
1730 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1734 -- No_Index is equal or greater than 0, so we can safely compute the
1735 -- difference without fear of overflow (which we would have to worry
1736 -- about if No_Index were less than 0, but that case is handled
1740 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1743 -- We have just computed the maximum length (number of items). We must
1744 -- now compare the requested length to the maximum length, as we do not
1745 -- allow a vector expand beyond the maximum (because that would create
1746 -- an internal array with a last index value greater than
1747 -- Index_Type'Last, with no way to index those elements).
1749 if Checks and then New_Length > Max_Length then
1750 raise Constraint_Error with "Count is out of range";
1753 -- New_Last is the last index value of the items in the container after
1754 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1755 -- compute its value from the New_Length.
1757 if Index_Type'Base'Last >= Count_Type_Last then
1758 New_Last := No_Index + Index_Type'Base (New_Length);
1760 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1763 if Container.Elements = null then
1764 pragma Assert (Container.Last = No_Index);
1766 -- This is the simplest case, with which we must always begin: we're
1767 -- inserting items into an empty vector that hasn't allocated an
1768 -- internal array yet. Note that we don't need to check the busy bit
1769 -- here, because an empty container cannot be busy.
1771 -- In order to preserve container invariants, we allocate the new
1772 -- internal array first, before setting the Last index value, in case
1773 -- the allocation fails (which can happen either because there is no
1774 -- storage available, or because default-valued element
1775 -- initialization fails).
1777 Container.Elements := new Elements_Type (New_Last);
1779 -- The allocation of the new, internal array succeeded, so it is now
1780 -- safe to update the Last index, restoring container invariants.
1782 Container.Last := New_Last;
1787 -- The tampering bits exist to prevent an item from being harmfully
1788 -- manipulated while it is being visited. Query, Update, and Iterate
1789 -- increment the busy count on entry, and decrement the count on
1790 -- exit. Insert checks the count to determine whether it is being called
1791 -- while the associated callback procedure is executing.
1793 TC_Check (Container.TC);
1795 -- An internal array has already been allocated, so we must determine
1796 -- whether there is enough unused storage for the new items.
1798 if New_Last <= Container.Elements.Last then
1800 -- In this case, we're inserting space into a vector that has already
1801 -- allocated an internal array, and the existing array has enough
1802 -- unused storage for the new items.
1805 EA : Elements_Array renames Container.Elements.EA;
1808 if Before <= Container.Last then
1810 -- The space is being inserted before some existing elements,
1811 -- so we must slide the existing elements up to their new
1812 -- home. We use the wider of Index_Type'Base and
1813 -- Count_Type'Base as the type for intermediate index values.
1815 if Index_Type'Base'Last >= Count_Type_Last then
1816 Index := Before + Index_Type'Base (Count);
1819 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1822 EA (Index .. New_Last) := EA (Before .. Container.Last);
1826 Container.Last := New_Last;
1830 -- In this case, we're inserting space into a vector that has already
1831 -- allocated an internal array, but the existing array does not have
1832 -- enough storage, so we must allocate a new, longer array. In order to
1833 -- guarantee that the amortized insertion cost is O(1), we always
1834 -- allocate an array whose length is some power-of-two factor of the
1835 -- current array length. (The new array cannot have a length less than
1836 -- the New_Length of the container, but its last index value cannot be
1837 -- greater than Index_Type'Last.)
1839 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1840 while New_Capacity < New_Length loop
1841 if New_Capacity > Count_Type'Last / 2 then
1842 New_Capacity := Count_Type'Last;
1846 New_Capacity := 2 * New_Capacity;
1849 if New_Capacity > Max_Length then
1851 -- We have reached the limit of capacity, so no further expansion
1852 -- will occur. (This is not a problem, as there is never a need to
1853 -- have more capacity than the maximum container length.)
1855 New_Capacity := Max_Length;
1858 -- We have computed the length of the new internal array (and this is
1859 -- what "vector capacity" means), so use that to compute its last index.
1861 if Index_Type'Base'Last >= Count_Type_Last then
1862 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1865 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1868 -- Now we allocate the new, longer internal array. If the allocation
1869 -- fails, we have not changed any container state, so no side-effect
1870 -- will occur as a result of propagating the exception.
1872 Dst := new Elements_Type (Dst_Last);
1874 -- We have our new internal array. All that needs to be done now is to
1875 -- copy the existing items (if any) from the old array (the "source"
1876 -- array, object SA below) to the new array (the "destination" array,
1877 -- object DA below), and then deallocate the old array.
1880 SA : Elements_Array renames Container.Elements.EA; -- source
1881 DA : Elements_Array renames Dst.EA; -- destination
1884 DA (Index_Type'First .. Before - 1) :=
1885 SA (Index_Type'First .. Before - 1);
1887 if Before <= Container.Last then
1889 -- The space is being inserted before some existing elements, so
1890 -- we must slide the existing elements up to their new home.
1892 if Index_Type'Base'Last >= Count_Type_Last then
1893 Index := Before + Index_Type'Base (Count);
1895 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1898 DA (Index .. New_Last) := SA (Before .. Container.Last);
1907 -- We have successfully copied the items onto the new array, so the
1908 -- final thing to do is restore invariants, and deallocate the old
1912 X : Elements_Access := Container.Elements;
1915 -- We first isolate the old internal array, removing it from the
1916 -- container and replacing it with the new internal array, before we
1917 -- deallocate the old array (which can fail if finalization of
1918 -- elements propagates an exception).
1920 Container.Elements := Dst;
1921 Container.Last := New_Last;
1923 -- The container invariants have been restored, so it is now safe to
1924 -- attempt to deallocate the old array.
1930 procedure Insert_Space
1931 (Container : in out Vector;
1933 Position : out Cursor;
1934 Count : Count_Type := 1)
1936 Index : Index_Type'Base;
1939 if Checks and then Before.Container /= null
1940 and then Before.Container /= Container'Unrestricted_Access
1942 raise Program_Error with "Before cursor denotes wrong container";
1946 if Before.Container = null or else Before.Index > Container.Last then
1947 Position := No_Element;
1949 Position := (Container'Unrestricted_Access, Before.Index);
1955 if Before.Container = null or else Before.Index > Container.Last then
1956 if Checks and then Container.Last = Index_Type'Last then
1957 raise Constraint_Error with
1958 "vector is already at its maximum length";
1960 Index := Container.Last + 1;
1964 Index := Before.Index;
1967 Insert_Space (Container, Index, Count);
1969 Position := (Container'Unrestricted_Access, Index);
1976 function Is_Empty (Container : Vector) return Boolean is
1978 return Container.Last < Index_Type'First;
1986 (Container : Vector;
1987 Process : not null access procedure (Position : Cursor))
1989 Busy : With_Busy (Container.TC'Unrestricted_Access);
1991 for Indx in Index_Type'First .. Container.Last loop
1992 Process (Cursor'(Container'Unrestricted_Access, Indx));
1997 (Container : Vector)
1998 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2000 V : constant Vector_Access := Container'Unrestricted_Access;
2002 -- The value of its Index component influences the behavior of the First
2003 -- and Last selector functions of the iterator object. When the Index
2004 -- component is No_Index (as is the case here), this means the iterator
2005 -- object was constructed without a start expression. This is a complete
2006 -- iterator, meaning that the iteration starts from the (logical)
2007 -- beginning of the sequence of items.
2009 -- Note: For a forward iterator, Container.First is the beginning, and
2010 -- for a reverse iterator, Container.Last is the beginning.
2012 return It : constant Iterator :=
2013 (Limited_Controlled with
2017 Busy (Container.TC'Unrestricted_Access.all);
2022 (Container : Vector;
2024 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2026 V : constant Vector_Access := Container'Unrestricted_Access;
2028 -- It was formerly the case that when Start = No_Element, the partial
2029 -- iterator was defined to behave the same as for a complete iterator,
2030 -- and iterate over the entire sequence of items. However, those
2031 -- semantics were unintuitive and arguably error-prone (it is too easy
2032 -- to accidentally create an endless loop), and so they were changed,
2033 -- per the ARG meeting in Denver on 2011/11. However, there was no
2034 -- consensus about what positive meaning this corner case should have,
2035 -- and so it was decided to simply raise an exception. This does imply,
2036 -- however, that it is not possible to use a partial iterator to specify
2037 -- an empty sequence of items.
2040 if Start.Container = null then
2041 raise Constraint_Error with
2042 "Start position for iterator equals No_Element";
2045 if Start.Container /= V then
2046 raise Program_Error with
2047 "Start cursor of Iterate designates wrong vector";
2050 if Start.Index > V.Last then
2051 raise Constraint_Error with
2052 "Start position for iterator equals No_Element";
2056 -- The value of its Index component influences the behavior of the First
2057 -- and Last selector functions of the iterator object. When the Index
2058 -- component is not No_Index (as is the case here), it means that this
2059 -- is a partial iteration, over a subset of the complete sequence of
2060 -- items. The iterator object was constructed with a start expression,
2061 -- indicating the position from which the iteration begins. Note that
2062 -- the start position has the same value irrespective of whether this
2063 -- is a forward or reverse iteration.
2065 return It : constant Iterator :=
2066 (Limited_Controlled with
2068 Index => Start.Index)
2070 Busy (Container.TC'Unrestricted_Access.all);
2078 function Last (Container : Vector) return Cursor is
2080 if Is_Empty (Container) then
2083 return (Container'Unrestricted_Access, Container.Last);
2087 function Last (Object : Iterator) return Cursor is
2089 -- The value of the iterator object's Index component influences the
2090 -- behavior of the Last (and First) selector function.
2092 -- When the Index component is No_Index, this means the iterator
2093 -- object was constructed without a start expression, in which case the
2094 -- (reverse) iteration starts from the (logical) beginning of the entire
2095 -- sequence (corresponding to Container.Last, for a reverse iterator).
2097 -- Otherwise, this is iteration over a partial sequence of items.
2098 -- When the Index component is not No_Index, the iterator object was
2099 -- constructed with a start expression, that specifies the position
2100 -- from which the (reverse) partial iteration begins.
2102 if Object.Index = No_Index then
2103 return Last (Object.Container.all);
2105 return Cursor'(Object.Container, Object.Index);
2113 function Last_Element (Container : Vector) return Element_Type is
2115 if Checks and then Container.Last = No_Index then
2116 raise Constraint_Error with "Container is empty";
2118 return Container.Elements.EA (Container.Last);
2126 function Last_Index (Container : Vector) return Extended_Index is
2128 return Container.Last;
2135 function Length (Container : Vector) return Count_Type is
2136 L : constant Index_Type'Base := Container.Last;
2137 F : constant Index_Type := Index_Type'First;
2140 -- The base range of the index type (Index_Type'Base) might not include
2141 -- all values for length (Count_Type). Contrariwise, the index type
2142 -- might include values outside the range of length. Hence we use
2143 -- whatever type is wider for intermediate values when calculating
2144 -- length. Note that no matter what the index type is, the maximum
2145 -- length to which a vector is allowed to grow is always the minimum
2146 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2148 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2149 -- to have a base range of -128 .. 127, but the corresponding vector
2150 -- would have lengths in the range 0 .. 255. In this case we would need
2151 -- to use Count_Type'Base for intermediate values.
2153 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2154 -- vector would have a maximum length of 10, but the index values lie
2155 -- outside the range of Count_Type (which is only 32 bits). In this
2156 -- case we would need to use Index_Type'Base for intermediate values.
2158 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2159 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2161 return Count_Type (L - F + 1);
2170 (Target : in out Vector;
2171 Source : in out Vector)
2174 if Target'Address = Source'Address then
2178 TC_Check (Target.TC);
2179 TC_Check (Source.TC);
2182 Target_Elements : constant Elements_Access := Target.Elements;
2184 Target.Elements := Source.Elements;
2185 Source.Elements := Target_Elements;
2188 Target.Last := Source.Last;
2189 Source.Last := No_Index;
2196 function Next (Position : Cursor) return Cursor is
2198 if Position.Container = null then
2200 elsif Position.Index < Position.Container.Last then
2201 return (Position.Container, Position.Index + 1);
2207 function Next (Object : Iterator; Position : Cursor) return Cursor is
2209 if Position.Container = null then
2211 elsif Checks and then Position.Container /= Object.Container then
2212 raise Program_Error with
2213 "Position cursor of Next designates wrong vector";
2215 return Next (Position);
2219 procedure Next (Position : in out Cursor) is
2221 if Position.Container = null then
2223 elsif Position.Index < Position.Container.Last then
2224 Position.Index := Position.Index + 1;
2226 Position := No_Element;
2234 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2236 Insert (Container, Index_Type'First, New_Item);
2240 (Container : in out Vector;
2241 New_Item : Element_Type;
2242 Count : Count_Type := 1)
2245 Insert (Container, Index_Type'First, New_Item, Count);
2252 function Previous (Position : Cursor) return Cursor is
2254 if Position.Container = null then
2256 elsif Position.Index > Index_Type'First then
2257 return (Position.Container, Position.Index - 1);
2263 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2265 if Position.Container = null then
2267 elsif Checks and then Position.Container /= Object.Container then
2268 raise Program_Error with
2269 "Position cursor of Previous designates wrong vector";
2271 return Previous (Position);
2275 procedure Previous (Position : in out Cursor) is
2277 if Position.Container = null then
2279 elsif Position.Index > Index_Type'First then
2280 Position.Index := Position.Index - 1;
2282 Position := No_Element;
2286 ----------------------
2287 -- Pseudo_Reference --
2288 ----------------------
2290 function Pseudo_Reference
2291 (Container : aliased Vector'Class) return Reference_Control_Type
2293 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
2295 return R : constant Reference_Control_Type := (Controlled with TC) do
2298 end Pseudo_Reference;
2304 procedure Query_Element
2305 (Container : Vector;
2307 Process : not null access procedure (Element : Element_Type))
2309 Lock : With_Lock (Container.TC'Unrestricted_Access);
2311 if Checks and then Index > Container.Last then
2312 raise Constraint_Error with "Index is out of range";
2315 Process (Container.Elements.EA (Index));
2318 procedure Query_Element
2320 Process : not null access procedure (Element : Element_Type))
2323 if Checks and then Position.Container = null then
2324 raise Constraint_Error with "Position cursor has no element";
2326 Query_Element (Position.Container.all, Position.Index, Process);
2335 (Stream : not null access Root_Stream_Type'Class;
2336 Container : out Vector)
2338 Length : Count_Type'Base;
2339 Last : Index_Type'Base := No_Index;
2344 Count_Type'Base'Read (Stream, Length);
2346 if Length > Capacity (Container) then
2347 Reserve_Capacity (Container, Capacity => Length);
2350 for J in Count_Type range 1 .. Length loop
2352 Element_Type'Read (Stream, Container.Elements.EA (Last));
2353 Container.Last := Last;
2358 (Stream : not null access Root_Stream_Type'Class;
2359 Position : out Cursor)
2362 raise Program_Error with "attempt to stream vector cursor";
2366 (Stream : not null access Root_Stream_Type'Class;
2367 Item : out Reference_Type)
2370 raise Program_Error with "attempt to stream reference";
2374 (Stream : not null access Root_Stream_Type'Class;
2375 Item : out Constant_Reference_Type)
2378 raise Program_Error with "attempt to stream reference";
2386 (Container : aliased in out Vector;
2387 Position : Cursor) return Reference_Type
2391 if Position.Container = null then
2392 raise Constraint_Error with "Position cursor has no element";
2395 if Position.Container /= Container'Unrestricted_Access then
2396 raise Program_Error with "Position cursor denotes wrong container";
2399 if Position.Index > Position.Container.Last then
2400 raise Constraint_Error with "Position cursor is out of range";
2405 TC : constant Tamper_Counts_Access :=
2406 Container.TC'Unrestricted_Access;
2408 return R : constant Reference_Type :=
2409 (Element => Container.Elements.EA (Position.Index)'Access,
2410 Control => (Controlled with TC))
2418 (Container : aliased in out Vector;
2419 Index : Index_Type) return Reference_Type
2422 if Checks and then Index > Container.Last then
2423 raise Constraint_Error with "Index is out of range";
2427 TC : constant Tamper_Counts_Access :=
2428 Container.TC'Unrestricted_Access;
2430 return R : constant Reference_Type :=
2431 (Element => Container.Elements.EA (Index)'Access,
2432 Control => (Controlled with TC))
2439 ---------------------
2440 -- Replace_Element --
2441 ---------------------
2443 procedure Replace_Element
2444 (Container : in out Vector;
2446 New_Item : Element_Type)
2449 if Checks and then Index > Container.Last then
2450 raise Constraint_Error with "Index is out of range";
2453 TE_Check (Container.TC);
2454 Container.Elements.EA (Index) := New_Item;
2455 end Replace_Element;
2457 procedure Replace_Element
2458 (Container : in out Vector;
2460 New_Item : Element_Type)
2464 if Position.Container = null then
2465 raise Constraint_Error with "Position cursor has no element";
2467 elsif Position.Container /= Container'Unrestricted_Access then
2468 raise Program_Error with "Position cursor denotes wrong container";
2470 elsif Position.Index > Container.Last then
2471 raise Constraint_Error with "Position cursor is out of range";
2475 TE_Check (Container.TC);
2476 Container.Elements.EA (Position.Index) := New_Item;
2477 end Replace_Element;
2479 ----------------------
2480 -- Reserve_Capacity --
2481 ----------------------
2483 procedure Reserve_Capacity
2484 (Container : in out Vector;
2485 Capacity : Count_Type)
2487 N : constant Count_Type := Length (Container);
2489 Index : Count_Type'Base;
2490 Last : Index_Type'Base;
2493 -- Reserve_Capacity can be used to either expand the storage available
2494 -- for elements (this would be its typical use, in anticipation of
2495 -- future insertion), or to trim back storage. In the latter case,
2496 -- storage can only be trimmed back to the limit of the container
2497 -- length. Note that Reserve_Capacity neither deletes (active) elements
2498 -- nor inserts elements; it only affects container capacity, never
2499 -- container length.
2501 if Capacity = 0 then
2503 -- This is a request to trim back storage, to the minimum amount
2504 -- possible given the current state of the container.
2508 -- The container is empty, so in this unique case we can
2509 -- deallocate the entire internal array. Note that an empty
2510 -- container can never be busy, so there's no need to check the
2514 X : Elements_Access := Container.Elements;
2517 -- First we remove the internal array from the container, to
2518 -- handle the case when the deallocation raises an exception.
2520 Container.Elements := null;
2522 -- Container invariants have been restored, so it is now safe
2523 -- to attempt to deallocate the internal array.
2528 elsif N < Container.Elements.EA'Length then
2530 -- The container is not empty, and the current length is less than
2531 -- the current capacity, so there's storage available to trim. In
2532 -- this case, we allocate a new internal array having a length
2533 -- that exactly matches the number of items in the
2534 -- container. (Reserve_Capacity does not delete active elements,
2535 -- so this is the best we can do with respect to minimizing
2538 TC_Check (Container.TC);
2541 subtype Src_Index_Subtype is Index_Type'Base range
2542 Index_Type'First .. Container.Last;
2544 Src : Elements_Array renames
2545 Container.Elements.EA (Src_Index_Subtype);
2547 X : Elements_Access := Container.Elements;
2550 -- Although we have isolated the old internal array that we're
2551 -- going to deallocate, we don't deallocate it until we have
2552 -- successfully allocated a new one. If there is an exception
2553 -- during allocation (either because there is not enough
2554 -- storage, or because initialization of the elements fails),
2555 -- we let it propagate without causing any side-effect.
2557 Container.Elements := new Elements_Type'(Container.Last, Src);
2559 -- We have successfully allocated a new internal array (with a
2560 -- smaller length than the old one, and containing a copy of
2561 -- just the active elements in the container), so it is now
2562 -- safe to attempt to deallocate the old array. The old array
2563 -- has been isolated, and container invariants have been
2564 -- restored, so if the deallocation fails (because finalization
2565 -- of the elements fails), we simply let it propagate.
2574 -- Reserve_Capacity can be used to expand the storage available for
2575 -- elements, but we do not let the capacity grow beyond the number of
2576 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2577 -- to refer to the elements with an index value greater than
2578 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2579 -- the Last index value of the new internal array, in a way that avoids
2580 -- any possibility of overflow.
2582 if Index_Type'Base'Last >= Count_Type_Last then
2584 -- We perform a two-part test. First we determine whether the
2585 -- computed Last value lies in the base range of the type, and then
2586 -- determine whether it lies in the range of the index (sub)type.
2588 -- Last must satisfy this relation:
2589 -- First + Length - 1 <= Last
2590 -- We regroup terms:
2591 -- First - 1 <= Last - Length
2592 -- Which can rewrite as:
2593 -- No_Index <= Last - Length
2596 Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index
2598 raise Constraint_Error with "Capacity is out of range";
2601 -- We now know that the computed value of Last is within the base
2602 -- range of the type, so it is safe to compute its value:
2604 Last := No_Index + Index_Type'Base (Capacity);
2606 -- Finally we test whether the value is within the range of the
2607 -- generic actual index subtype:
2609 if Checks and then Last > Index_Type'Last then
2610 raise Constraint_Error with "Capacity is out of range";
2613 elsif Index_Type'First <= 0 then
2615 -- Here we can compute Last directly, in the normal way. We know that
2616 -- No_Index is less than 0, so there is no danger of overflow when
2617 -- adding the (positive) value of Capacity.
2619 Index := Count_Type'Base (No_Index) + Capacity; -- Last
2621 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
2622 raise Constraint_Error with "Capacity is out of range";
2625 -- We know that the computed value (having type Count_Type) of Last
2626 -- is within the range of the generic actual index subtype, so it is
2627 -- safe to convert to Index_Type:
2629 Last := Index_Type'Base (Index);
2632 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2633 -- must test the length indirectly (by working backwards from the
2634 -- largest possible value of Last), in order to prevent overflow.
2636 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
2638 if Checks and then Index < Count_Type'Base (No_Index) then
2639 raise Constraint_Error with "Capacity is out of range";
2642 -- We have determined that the value of Capacity would not create a
2643 -- Last index value outside of the range of Index_Type, so we can now
2644 -- safely compute its value.
2646 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
2649 -- The requested capacity is non-zero, but we don't know yet whether
2650 -- this is a request for expansion or contraction of storage.
2652 if Container.Elements = null then
2654 -- The container is empty (it doesn't even have an internal array),
2655 -- so this represents a request to allocate (expand) storage having
2656 -- the given capacity.
2658 Container.Elements := new Elements_Type (Last);
2662 if Capacity <= N then
2664 -- This is a request to trim back storage, but only to the limit of
2665 -- what's already in the container. (Reserve_Capacity never deletes
2666 -- active elements, it only reclaims excess storage.)
2668 if N < Container.Elements.EA'Length then
2670 -- The container is not empty (because the requested capacity is
2671 -- positive, and less than or equal to the container length), and
2672 -- the current length is less than the current capacity, so
2673 -- there's storage available to trim. In this case, we allocate a
2674 -- new internal array having a length that exactly matches the
2675 -- number of items in the container.
2677 TC_Check (Container.TC);
2680 subtype Src_Index_Subtype is Index_Type'Base range
2681 Index_Type'First .. Container.Last;
2683 Src : Elements_Array renames
2684 Container.Elements.EA (Src_Index_Subtype);
2686 X : Elements_Access := Container.Elements;
2689 -- Although we have isolated the old internal array that we're
2690 -- going to deallocate, we don't deallocate it until we have
2691 -- successfully allocated a new one. If there is an exception
2692 -- during allocation (either because there is not enough
2693 -- storage, or because initialization of the elements fails),
2694 -- we let it propagate without causing any side-effect.
2696 Container.Elements := new Elements_Type'(Container.Last, Src);
2698 -- We have successfully allocated a new internal array (with a
2699 -- smaller length than the old one, and containing a copy of
2700 -- just the active elements in the container), so it is now
2701 -- safe to attempt to deallocate the old array. The old array
2702 -- has been isolated, and container invariants have been
2703 -- restored, so if the deallocation fails (because finalization
2704 -- of the elements fails), we simply let it propagate.
2713 -- The requested capacity is larger than the container length (the
2714 -- number of active elements). Whether this represents a request for
2715 -- expansion or contraction of the current capacity depends on what the
2716 -- current capacity is.
2718 if Capacity = Container.Elements.EA'Length then
2720 -- The requested capacity matches the existing capacity, so there's
2721 -- nothing to do here. We treat this case as a no-op, and simply
2722 -- return without checking the busy bit.
2727 -- There is a change in the capacity of a non-empty container, so a new
2728 -- internal array will be allocated. (The length of the new internal
2729 -- array could be less or greater than the old internal array. We know
2730 -- only that the length of the new internal array is greater than the
2731 -- number of active elements in the container.) We must check whether
2732 -- the container is busy before doing anything else.
2734 TC_Check (Container.TC);
2736 -- We now allocate a new internal array, having a length different from
2737 -- its current value.
2740 E : Elements_Access := new Elements_Type (Last);
2743 -- We have successfully allocated the new internal array. We first
2744 -- attempt to copy the existing elements from the old internal array
2745 -- ("src" elements) onto the new internal array ("tgt" elements).
2748 subtype Index_Subtype is Index_Type'Base range
2749 Index_Type'First .. Container.Last;
2751 Src : Elements_Array renames
2752 Container.Elements.EA (Index_Subtype);
2754 Tgt : Elements_Array renames E.EA (Index_Subtype);
2765 -- We have successfully copied the existing elements onto the new
2766 -- internal array, so now we can attempt to deallocate the old one.
2769 X : Elements_Access := Container.Elements;
2772 -- First we isolate the old internal array, and replace it in the
2773 -- container with the new internal array.
2775 Container.Elements := E;
2777 -- Container invariants have been restored, so it is now safe to
2778 -- attempt to deallocate the old internal array.
2783 end Reserve_Capacity;
2785 ----------------------
2786 -- Reverse_Elements --
2787 ----------------------
2789 procedure Reverse_Elements (Container : in out Vector) is
2791 if Container.Length <= 1 then
2795 -- The exception behavior for the vector container must match that for
2796 -- the list container, so we check for cursor tampering here (which will
2797 -- catch more things) instead of for element tampering (which will catch
2798 -- fewer things). It's true that the elements of this vector container
2799 -- could be safely moved around while (say) an iteration is taking place
2800 -- (iteration only increments the busy counter), and so technically
2801 -- all we would need here is a test for element tampering (indicated
2802 -- by the lock counter), that's simply an artifact of our array-based
2803 -- implementation. Logically Reverse_Elements requires a check for
2804 -- cursor tampering.
2806 TC_Check (Container.TC);
2811 E : Elements_Type renames Container.Elements.all;
2814 K := Index_Type'First;
2815 J := Container.Last;
2818 EK : constant Element_Type := E.EA (K);
2820 E.EA (K) := E.EA (J);
2828 end Reverse_Elements;
2834 function Reverse_Find
2835 (Container : Vector;
2836 Item : Element_Type;
2837 Position : Cursor := No_Element) return Cursor
2839 Last : Index_Type'Base;
2842 if Checks and then Position.Container /= null
2843 and then Position.Container /= Container'Unrestricted_Access
2845 raise Program_Error with "Position cursor denotes wrong container";
2849 (if Position.Container = null or else Position.Index > Container.Last
2851 else Position.Index);
2853 -- Per AI05-0022, the container implementation is required to detect
2854 -- element tampering by a generic actual subprogram.
2857 Lock : With_Lock (Container.TC'Unrestricted_Access);
2859 for Indx in reverse Index_Type'First .. Last loop
2860 if Container.Elements.EA (Indx) = Item then
2861 return Cursor'(Container'Unrestricted_Access, Indx);
2869 ------------------------
2870 -- Reverse_Find_Index --
2871 ------------------------
2873 function Reverse_Find_Index
2874 (Container : Vector;
2875 Item : Element_Type;
2876 Index : Index_Type := Index_Type'Last) return Extended_Index
2878 -- Per AI05-0022, the container implementation is required to detect
2879 -- element tampering by a generic actual subprogram.
2881 Lock : With_Lock (Container.TC'Unrestricted_Access);
2883 Last : constant Index_Type'Base :=
2884 Index_Type'Min (Container.Last, Index);
2887 for Indx in reverse Index_Type'First .. Last loop
2888 if Container.Elements.EA (Indx) = Item then
2894 end Reverse_Find_Index;
2896 ---------------------
2897 -- Reverse_Iterate --
2898 ---------------------
2900 procedure Reverse_Iterate
2901 (Container : Vector;
2902 Process : not null access procedure (Position : Cursor))
2904 Busy : With_Busy (Container.TC'Unrestricted_Access);
2906 for Indx in reverse Index_Type'First .. Container.Last loop
2907 Process (Cursor'(Container'Unrestricted_Access, Indx));
2909 end Reverse_Iterate;
2915 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2916 Count : constant Count_Type'Base := Container.Length - Length;
2919 -- Set_Length allows the user to set the length explicitly, instead
2920 -- of implicitly as a side-effect of deletion or insertion. If the
2921 -- requested length is less than the current length, this is equivalent
2922 -- to deleting items from the back end of the vector. If the requested
2923 -- length is greater than the current length, then this is equivalent
2924 -- to inserting "space" (nonce items) at the end.
2927 Container.Delete_Last (Count);
2929 elsif Checks and then Container.Last >= Index_Type'Last then
2930 raise Constraint_Error with "vector is already at its maximum length";
2933 Container.Insert_Space (Container.Last + 1, -Count);
2941 procedure Swap (Container : in out Vector; I, J : Index_Type) is
2944 if I > Container.Last then
2945 raise Constraint_Error with "I index is out of range";
2948 if J > Container.Last then
2949 raise Constraint_Error with "J index is out of range";
2957 TE_Check (Container.TC);
2960 EI_Copy : constant Element_Type := Container.Elements.EA (I);
2962 Container.Elements.EA (I) := Container.Elements.EA (J);
2963 Container.Elements.EA (J) := EI_Copy;
2967 procedure Swap (Container : in out Vector; I, J : Cursor) is
2970 if I.Container = null then
2971 raise Constraint_Error with "I cursor has no element";
2973 elsif J.Container = null then
2974 raise Constraint_Error with "J cursor has no element";
2976 elsif I.Container /= Container'Unrestricted_Access then
2977 raise Program_Error with "I cursor denotes wrong container";
2979 elsif J.Container /= Container'Unrestricted_Access then
2980 raise Program_Error with "J cursor denotes wrong container";
2984 Swap (Container, I.Index, J.Index);
2992 (Container : Vector;
2993 Index : Extended_Index) return Cursor
2996 if Index not in Index_Type'First .. Container.Last then
2999 return (Container'Unrestricted_Access, Index);
3007 function To_Index (Position : Cursor) return Extended_Index is
3009 if Position.Container = null then
3011 elsif Position.Index <= Position.Container.Last then
3012 return Position.Index;
3022 function To_Vector (Length : Count_Type) return Vector is
3023 Index : Count_Type'Base;
3024 Last : Index_Type'Base;
3025 Elements : Elements_Access;
3029 return Empty_Vector;
3032 -- We create a vector object with a capacity that matches the specified
3033 -- Length, but we do not allow the vector capacity (the length of the
3034 -- internal array) to exceed the number of values in Index_Type'Range
3035 -- (otherwise, there would be no way to refer to those components via an
3036 -- index). We must therefore check whether the specified Length would
3037 -- create a Last index value greater than Index_Type'Last.
3039 if Index_Type'Base'Last >= Count_Type_Last then
3041 -- We perform a two-part test. First we determine whether the
3042 -- computed Last value lies in the base range of the type, and then
3043 -- determine whether it lies in the range of the index (sub)type.
3045 -- Last must satisfy this relation:
3046 -- First + Length - 1 <= Last
3047 -- We regroup terms:
3048 -- First - 1 <= Last - Length
3049 -- Which can rewrite as:
3050 -- No_Index <= Last - Length
3053 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
3055 raise Constraint_Error with "Length is out of range";
3058 -- We now know that the computed value of Last is within the base
3059 -- range of the type, so it is safe to compute its value:
3061 Last := No_Index + Index_Type'Base (Length);
3063 -- Finally we test whether the value is within the range of the
3064 -- generic actual index subtype:
3066 if Checks and then Last > Index_Type'Last then
3067 raise Constraint_Error with "Length is out of range";
3070 elsif Index_Type'First <= 0 then
3072 -- Here we can compute Last directly, in the normal way. We know that
3073 -- No_Index is less than 0, so there is no danger of overflow when
3074 -- adding the (positive) value of Length.
3076 Index := Count_Type'Base (No_Index) + Length; -- Last
3078 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
3079 raise Constraint_Error with "Length is out of range";
3082 -- We know that the computed value (having type Count_Type) of Last
3083 -- is within the range of the generic actual index subtype, so it is
3084 -- safe to convert to Index_Type:
3086 Last := Index_Type'Base (Index);
3089 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3090 -- must test the length indirectly (by working backwards from the
3091 -- largest possible value of Last), in order to prevent overflow.
3093 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3095 if Checks and then Index < Count_Type'Base (No_Index) then
3096 raise Constraint_Error with "Length is out of range";
3099 -- We have determined that the value of Length would not create a
3100 -- Last index value outside of the range of Index_Type, so we can now
3101 -- safely compute its value.
3103 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3106 Elements := new Elements_Type (Last);
3108 return Vector'(Controlled with Elements, Last, TC => <>);
3112 (New_Item : Element_Type;
3113 Length : Count_Type) return Vector
3115 Index : Count_Type'Base;
3116 Last : Index_Type'Base;
3117 Elements : Elements_Access;
3121 return Empty_Vector;
3124 -- We create a vector object with a capacity that matches the specified
3125 -- Length, but we do not allow the vector capacity (the length of the
3126 -- internal array) to exceed the number of values in Index_Type'Range
3127 -- (otherwise, there would be no way to refer to those components via an
3128 -- index). We must therefore check whether the specified Length would
3129 -- create a Last index value greater than Index_Type'Last.
3131 if Index_Type'Base'Last >= Count_Type_Last then
3133 -- We perform a two-part test. First we determine whether the
3134 -- computed Last value lies in the base range of the type, and then
3135 -- determine whether it lies in the range of the index (sub)type.
3137 -- Last must satisfy this relation:
3138 -- First + Length - 1 <= Last
3139 -- We regroup terms:
3140 -- First - 1 <= Last - Length
3141 -- Which can rewrite as:
3142 -- No_Index <= Last - Length
3145 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
3147 raise Constraint_Error with "Length is out of range";
3150 -- We now know that the computed value of Last is within the base
3151 -- range of the type, so it is safe to compute its value:
3153 Last := No_Index + Index_Type'Base (Length);
3155 -- Finally we test whether the value is within the range of the
3156 -- generic actual index subtype:
3158 if Checks and then Last > Index_Type'Last then
3159 raise Constraint_Error with "Length is out of range";
3162 elsif Index_Type'First <= 0 then
3164 -- Here we can compute Last directly, in the normal way. We know that
3165 -- No_Index is less than 0, so there is no danger of overflow when
3166 -- adding the (positive) value of Length.
3168 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
3170 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
3171 raise Constraint_Error with "Length is out of range";
3174 -- We know that the computed value (having type Count_Type) of Last
3175 -- is within the range of the generic actual index subtype, so it is
3176 -- safe to convert to Index_Type:
3178 Last := Index_Type'Base (Index);
3181 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3182 -- must test the length indirectly (by working backwards from the
3183 -- largest possible value of Last), in order to prevent overflow.
3185 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3187 if Checks and then Index < Count_Type'Base (No_Index) then
3188 raise Constraint_Error with "Length is out of range";
3191 -- We have determined that the value of Length would not create a
3192 -- Last index value outside of the range of Index_Type, so we can now
3193 -- safely compute its value.
3195 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3198 Elements := new Elements_Type'(Last, EA => (others => New_Item));
3200 return (Controlled with Elements, Last, TC => <>);
3203 --------------------
3204 -- Update_Element --
3205 --------------------
3207 procedure Update_Element
3208 (Container : in out Vector;
3210 Process : not null access procedure (Element : in out Element_Type))
3212 Lock : With_Lock (Container.TC'Unchecked_Access);
3214 if Checks and then Index > Container.Last then
3215 raise Constraint_Error with "Index is out of range";
3218 Process (Container.Elements.EA (Index));
3221 procedure Update_Element
3222 (Container : in out Vector;
3224 Process : not null access procedure (Element : in out Element_Type))
3228 if Position.Container = null then
3229 raise Constraint_Error with "Position cursor has no element";
3230 elsif Position.Container /= Container'Unrestricted_Access then
3231 raise Program_Error with "Position cursor denotes wrong container";
3235 Update_Element (Container, Position.Index, Process);
3243 (Stream : not null access Root_Stream_Type'Class;
3247 Count_Type'Base'Write (Stream, Length (Container));
3249 for J in Index_Type'First .. Container.Last loop
3250 Element_Type'Write (Stream, Container.Elements.EA (J));
3255 (Stream : not null access Root_Stream_Type'Class;
3259 raise Program_Error with "attempt to stream vector cursor";
3263 (Stream : not null access Root_Stream_Type'Class;
3264 Item : Reference_Type)
3267 raise Program_Error with "attempt to stream reference";
3271 (Stream : not null access Root_Stream_Type'Class;
3272 Item : Constant_Reference_Type)
3275 raise Program_Error with "attempt to stream reference";
3278 end Ada.Containers.Vectors;