1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
9 -- Copyright (C) 2004-2011, 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;
32 with System; use type System.Address;
34 package body Ada.Containers.Indefinite_Vectors is
37 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
40 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
43 Vector_Iterator_Interfaces.Reversible_Iterator with record
44 Container : Vector_Access;
48 overriding function First (Object : Iterator) return Cursor;
50 overriding function Last (Object : Iterator) return Cursor;
52 overriding function Next
54 Position : Cursor) return Cursor;
56 overriding function Previous
58 Position : Cursor) return Cursor;
64 function "&" (Left, Right : Vector) return Vector is
65 LN : constant Count_Type := Length (Left);
66 RN : constant Count_Type := Length (Right);
67 N : Count_Type'Base; -- length of result
68 J : Count_Type'Base; -- for computing intermediate values
69 Last : Index_Type'Base; -- Last index of result
72 -- We decide that the capacity of the result is the sum of the lengths
73 -- of the vector parameters. We could decide to make it larger, but we
74 -- have no basis for knowing how much larger, so we just allocate the
75 -- minimum amount of storage.
77 -- Here we handle the easy cases first, when one of the vector
78 -- parameters is empty. (We say "easy" because there's nothing to
79 -- compute, that can potentially overflow.)
87 RE : Elements_Array renames
88 Right.Elements.EA (Index_Type'First .. Right.Last);
90 Elements : Elements_Access :=
91 new Elements_Type (Right.Last);
94 -- Elements of an indefinite vector are allocated, so we cannot
95 -- use simple slice assignment to give a value to our result.
96 -- Hence we must walk the array of the Right vector, and copy
97 -- each source element individually.
99 for I in Elements.EA'Range loop
101 if RE (I) /= null then
102 Elements.EA (I) := new Element_Type'(RE (I).all);
107 for J in Index_Type'First .. I - 1 loop
108 Free (Elements.EA (J));
116 return (Controlled with Elements, Right.Last, 0, 0);
123 LE : Elements_Array renames
124 Left.Elements.EA (Index_Type'First .. Left.Last);
126 Elements : Elements_Access :=
127 new Elements_Type (Left.Last);
130 -- Elements of an indefinite vector are allocated, so we cannot
131 -- use simple slice assignment to give a value to our result.
132 -- Hence we must walk the array of the Left vector, and copy
133 -- each source element individually.
135 for I in Elements.EA'Range loop
137 if LE (I) /= null then
138 Elements.EA (I) := new Element_Type'(LE (I).all);
143 for J in Index_Type'First .. I - 1 loop
144 Free (Elements.EA (J));
152 return (Controlled with Elements, Left.Last, 0, 0);
156 -- Neither of the vector parameters is empty, so we must compute the
157 -- length of the result vector and its last index. (This is the harder
158 -- case, because our computations must avoid overflow.)
160 -- There are two constraints we need to satisfy. The first constraint is
161 -- that a container cannot have more than Count_Type'Last elements, so
162 -- we must check the sum of the combined lengths. Note that we cannot
163 -- simply add the lengths, because of the possibility of overflow.
165 if LN > Count_Type'Last - RN then
166 raise Constraint_Error with "new length is out of range";
169 -- It is now safe compute the length of the new vector.
173 -- The second constraint is that the new Last index value cannot
174 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
175 -- Count_Type'Base as the type for intermediate values.
177 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
179 -- We perform a two-part test. First we determine whether the
180 -- computed Last value lies in the base range of the type, and then
181 -- determine whether it lies in the range of the index (sub)type.
183 -- Last must satisfy this relation:
184 -- First + Length - 1 <= Last
186 -- First - 1 <= Last - Length
187 -- Which can rewrite as:
188 -- No_Index <= Last - Length
190 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
191 raise Constraint_Error with "new length is out of range";
194 -- We now know that the computed value of Last is within the base
195 -- range of the type, so it is safe to compute its value:
197 Last := No_Index + Index_Type'Base (N);
199 -- Finally we test whether the value is within the range of the
200 -- generic actual index subtype:
202 if Last > Index_Type'Last then
203 raise Constraint_Error with "new length is out of range";
206 elsif Index_Type'First <= 0 then
208 -- Here we can compute Last directly, in the normal way. We know that
209 -- No_Index is less than 0, so there is no danger of overflow when
210 -- adding the (positive) value of length.
212 J := Count_Type'Base (No_Index) + N; -- Last
214 if J > Count_Type'Base (Index_Type'Last) then
215 raise Constraint_Error with "new length is out of range";
218 -- We know that the computed value (having type Count_Type) of Last
219 -- is within the range of the generic actual index subtype, so it is
220 -- safe to convert to Index_Type:
222 Last := Index_Type'Base (J);
225 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
226 -- must test the length indirectly (by working backwards from the
227 -- largest possible value of Last), in order to prevent overflow.
229 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
231 if J < Count_Type'Base (No_Index) then
232 raise Constraint_Error with "new length is out of range";
235 -- We have determined that the result length would not create a Last
236 -- index value outside of the range of Index_Type, so we can now
237 -- safely compute its value.
239 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
243 LE : Elements_Array renames
244 Left.Elements.EA (Index_Type'First .. Left.Last);
246 RE : Elements_Array renames
247 Right.Elements.EA (Index_Type'First .. Right.Last);
249 Elements : Elements_Access := new Elements_Type (Last);
251 I : Index_Type'Base := No_Index;
254 -- Elements of an indefinite vector are allocated, so we cannot use
255 -- simple slice assignment to give a value to our result. Hence we
256 -- must walk the array of each vector parameter, and copy each source
257 -- element individually.
259 for LI in LE'Range loop
263 if LE (LI) /= null then
264 Elements.EA (I) := new Element_Type'(LE (LI).all);
269 for J in Index_Type'First .. I - 1 loop
270 Free (Elements.EA (J));
278 for RI in RE'Range loop
282 if RE (RI) /= null then
283 Elements.EA (I) := new Element_Type'(RE (RI).all);
288 for J in Index_Type'First .. I - 1 loop
289 Free (Elements.EA (J));
297 return (Controlled with Elements, Last, 0, 0);
301 function "&" (Left : Vector; Right : Element_Type) return Vector is
303 -- We decide that the capacity of the result is the sum of the lengths
304 -- of the parameters. We could decide to make it larger, but we have no
305 -- basis for knowing how much larger, so we just allocate the minimum
306 -- amount of storage.
308 -- Here we handle the easy case first, when the vector parameter (Left)
311 if Left.Is_Empty then
313 Elements : Elements_Access := new Elements_Type (Index_Type'First);
317 Elements.EA (Index_Type'First) := new Element_Type'(Right);
324 return (Controlled with Elements, Index_Type'First, 0, 0);
328 -- The vector parameter is not empty, so we must compute the length of
329 -- the result vector and its last index, but in such a way that overflow
330 -- is avoided. We must satisfy two constraints: the new length cannot
331 -- exceed Count_Type'Last, and the new Last index cannot exceed
334 if Left.Length = Count_Type'Last then
335 raise Constraint_Error with "new length is out of range";
338 if Left.Last >= Index_Type'Last then
339 raise Constraint_Error with "new length is out of range";
343 Last : constant Index_Type := Left.Last + 1;
345 LE : Elements_Array renames
346 Left.Elements.EA (Index_Type'First .. Left.Last);
348 Elements : Elements_Access :=
349 new Elements_Type (Last);
352 for I in LE'Range loop
354 if LE (I) /= null then
355 Elements.EA (I) := new Element_Type'(LE (I).all);
360 for J in Index_Type'First .. I - 1 loop
361 Free (Elements.EA (J));
370 Elements.EA (Last) := new Element_Type'(Right);
374 for J in Index_Type'First .. Last - 1 loop
375 Free (Elements.EA (J));
382 return (Controlled with Elements, Last, 0, 0);
386 function "&" (Left : Element_Type; Right : Vector) return Vector is
388 -- We decide that the capacity of the result is the sum of the lengths
389 -- of the parameters. We could decide to make it larger, but we have no
390 -- basis for knowing how much larger, so we just allocate the minimum
391 -- amount of storage.
393 -- Here we handle the easy case first, when the vector parameter (Right)
396 if Right.Is_Empty then
398 Elements : Elements_Access := new Elements_Type (Index_Type'First);
402 Elements.EA (Index_Type'First) := new Element_Type'(Left);
409 return (Controlled with Elements, Index_Type'First, 0, 0);
413 -- The vector parameter is not empty, so we must compute the length of
414 -- the result vector and its last index, but in such a way that overflow
415 -- is avoided. We must satisfy two constraints: the new length cannot
416 -- exceed Count_Type'Last, and the new Last index cannot exceed
419 if Right.Length = Count_Type'Last then
420 raise Constraint_Error with "new length is out of range";
423 if Right.Last >= Index_Type'Last then
424 raise Constraint_Error with "new length is out of range";
428 Last : constant Index_Type := Right.Last + 1;
430 RE : Elements_Array renames
431 Right.Elements.EA (Index_Type'First .. Right.Last);
433 Elements : Elements_Access :=
434 new Elements_Type (Last);
436 I : Index_Type'Base := Index_Type'First;
440 Elements.EA (I) := new Element_Type'(Left);
447 for RI in RE'Range loop
451 if RE (RI) /= null then
452 Elements.EA (I) := new Element_Type'(RE (RI).all);
457 for J in Index_Type'First .. I - 1 loop
458 Free (Elements.EA (J));
466 return (Controlled with Elements, Last, 0, 0);
470 function "&" (Left, Right : Element_Type) return Vector is
472 -- We decide that the capacity of the result is the sum of the lengths
473 -- of the parameters. We could decide to make it larger, but we have no
474 -- basis for knowing how much larger, so we just allocate the minimum
475 -- amount of storage.
477 -- We must compute the length of the result vector and its last index,
478 -- but in such a way that overflow is avoided. We must satisfy two
479 -- constraints: the new length cannot exceed Count_Type'Last (here, we
480 -- know that that condition is satisfied), and the new Last index cannot
481 -- exceed Index_Type'Last.
483 if Index_Type'First >= Index_Type'Last then
484 raise Constraint_Error with "new length is out of range";
488 Last : constant Index_Type := Index_Type'First + 1;
489 Elements : Elements_Access := new Elements_Type (Last);
493 Elements.EA (Index_Type'First) := new Element_Type'(Left);
501 Elements.EA (Last) := new Element_Type'(Right);
504 Free (Elements.EA (Index_Type'First));
509 return (Controlled with Elements, Last, 0, 0);
517 overriding function "=" (Left, Right : Vector) return Boolean is
519 if Left'Address = Right'Address then
523 if Left.Last /= Right.Last then
527 for J in Index_Type'First .. Left.Last loop
528 if Left.Elements.EA (J) = null then
529 if Right.Elements.EA (J) /= null then
533 elsif Right.Elements.EA (J) = null then
536 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
548 procedure Adjust (Container : in out Vector) is
550 if Container.Last = No_Index then
551 Container.Elements := null;
556 L : constant Index_Type := Container.Last;
557 E : Elements_Array renames
558 Container.Elements.EA (Index_Type'First .. L);
561 Container.Elements := null;
562 Container.Last := No_Index;
566 Container.Elements := new Elements_Type (L);
568 for I in E'Range loop
569 if E (I) /= null then
570 Container.Elements.EA (I) := new Element_Type'(E (I).all);
582 procedure Append (Container : in out Vector; New_Item : Vector) is
584 if Is_Empty (New_Item) then
588 if Container.Last = Index_Type'Last then
589 raise Constraint_Error with "vector is already at its maximum length";
599 (Container : in out Vector;
600 New_Item : Element_Type;
601 Count : Count_Type := 1)
608 if Container.Last = Index_Type'Last then
609 raise Constraint_Error with "vector is already at its maximum length";
623 procedure Assign (Target : in out Vector; Source : Vector) is
625 if Target'Address = Source'Address then
630 Target.Append (Source);
637 function Capacity (Container : Vector) return Count_Type is
639 if Container.Elements = null then
643 return Container.Elements.EA'Length;
650 procedure Clear (Container : in out Vector) is
652 if Container.Busy > 0 then
653 raise Program_Error with
654 "attempt to tamper with cursors (vector is busy)";
657 while Container.Last >= Index_Type'First loop
659 X : Element_Access := Container.Elements.EA (Container.Last);
661 Container.Elements.EA (Container.Last) := null;
662 Container.Last := Container.Last - 1;
668 ------------------------
669 -- Constant_Reference --
670 ------------------------
672 function Constant_Reference
674 Position : Cursor) return Constant_Reference_Type
677 pragma Unreferenced (Container);
679 if Position.Container = null then
680 raise Constraint_Error with "Position cursor has no element";
683 if Position.Index > Position.Container.Last then
684 raise Constraint_Error with "Position cursor is out of range";
688 (Element => Position.Container.Elements.EA (Position.Index).all'Access);
689 end Constant_Reference;
691 function Constant_Reference
693 Position : Index_Type) return Constant_Reference_Type
696 if (Position) > Container.Last then
697 raise Constraint_Error with "Index is out of range";
700 return (Element => Container.Elements.EA (Position).all'Access);
701 end Constant_Reference;
709 Item : Element_Type) return Boolean
712 return Find_Index (Container, Item) /= No_Index;
721 Capacity : Count_Type := 0) return Vector
729 elsif Capacity >= Source.Length then
734 with "Requested capacity is less than Source length";
737 return Target : Vector do
738 Target.Reserve_Capacity (C);
739 Target.Assign (Source);
748 (Container : in out Vector;
749 Index : Extended_Index;
750 Count : Count_Type := 1)
752 Old_Last : constant Index_Type'Base := Container.Last;
753 New_Last : Index_Type'Base;
754 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
755 J : Index_Type'Base; -- first index of items that slide down
758 -- Delete removes items from the vector, the number of which is the
759 -- minimum of the specified Count and the items (if any) that exist from
760 -- Index to Container.Last. There are no constraints on the specified
761 -- value of Count (it can be larger than what's available at this
762 -- position in the vector, for example), but there are constraints on
763 -- the allowed values of the Index.
765 -- As a precondition on the generic actual Index_Type, the base type
766 -- must include Index_Type'Pred (Index_Type'First); this is the value
767 -- that Container.Last assumes when the vector is empty. However, we do
768 -- not allow that as the value for Index when specifying which items
769 -- should be deleted, so we must manually check. (That the user is
770 -- allowed to specify the value at all here is a consequence of the
771 -- declaration of the Extended_Index subtype, which includes the values
772 -- in the base range that immediately precede and immediately follow the
773 -- values in the Index_Type.)
775 if Index < Index_Type'First then
776 raise Constraint_Error with "Index is out of range (too small)";
779 -- We do allow a value greater than Container.Last to be specified as
780 -- the Index, but only if it's immediately greater. This allows the
781 -- corner case of deleting no items from the back end of the vector to
782 -- be treated as a no-op. (It is assumed that specifying an index value
783 -- greater than Last + 1 indicates some deeper flaw in the caller's
784 -- algorithm, so that case is treated as a proper error.)
786 if Index > Old_Last then
787 if Index > Old_Last + 1 then
788 raise Constraint_Error with "Index is out of range (too large)";
794 -- Here and elsewhere we treat deleting 0 items from the container as a
795 -- no-op, even when the container is busy, so we simply return.
801 -- The internal elements array isn't guaranteed to exist unless we have
802 -- elements, so we handle that case here in order to avoid having to
803 -- check it later. (Note that an empty vector can never be busy, so
804 -- there's no semantic harm in returning early.)
806 if Container.Is_Empty then
810 -- The tampering bits exist to prevent an item from being deleted (or
811 -- otherwise harmfully manipulated) while it is being visited. Query,
812 -- Update, and Iterate increment the busy count on entry, and decrement
813 -- the count on exit. Delete checks the count to determine whether it is
814 -- being called while the associated callback procedure is executing.
816 if Container.Busy > 0 then
817 raise Program_Error with
818 "attempt to tamper with cursors (vector is busy)";
821 -- We first calculate what's available for deletion starting at
822 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
823 -- Count_Type'Base as the type for intermediate values. (See function
824 -- Length for more information.)
826 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
827 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
830 Count2 := Count_Type'Base (Old_Last - Index + 1);
833 -- If the number of elements requested (Count) for deletion is equal to
834 -- (or greater than) the number of elements available (Count2) for
835 -- deletion beginning at Index, then everything from Index to
836 -- Container.Last is deleted (this is equivalent to Delete_Last).
838 if Count >= Count2 then
839 -- Elements in an indefinite vector are allocated, so we must iterate
840 -- over the loop and deallocate elements one-at-a-time. We work from
841 -- back to front, deleting the last element during each pass, in
842 -- order to gracefully handle deallocation failures.
845 EA : Elements_Array renames Container.Elements.EA;
848 while Container.Last >= Index loop
850 K : constant Index_Type := Container.Last;
851 X : Element_Access := EA (K);
854 -- We first isolate the element we're deleting, removing it
855 -- from the vector before we attempt to deallocate it, in
856 -- case the deallocation fails.
859 Container.Last := K - 1;
861 -- Container invariants have been restored, so it is now
862 -- safe to attempt to deallocate the element.
872 -- There are some elements that aren't being deleted (the requested
873 -- count was less than the available count), so we must slide them down
874 -- to Index. We first calculate the index values of the respective array
875 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
876 -- type for intermediate calculations. For the elements that slide down,
877 -- index value New_Last is the last index value of their new home, and
878 -- index value J is the first index of their old home.
880 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
881 New_Last := Old_Last - Index_Type'Base (Count);
882 J := Index + Index_Type'Base (Count);
885 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
886 J := Index_Type'Base (Count_Type'Base (Index) + Count);
889 -- The internal elements array isn't guaranteed to exist unless we have
890 -- elements, but we have that guarantee here because we know we have
891 -- elements to slide. The array index values for each slice have
892 -- already been determined, so what remains to be done is to first
893 -- deallocate the elements that are being deleted, and then slide down
894 -- to Index the elements that aren't being deleted.
897 EA : Elements_Array renames Container.Elements.EA;
900 -- Before we can slide down the elements that aren't being deleted,
901 -- we need to deallocate the elements that are being deleted.
903 for K in Index .. J - 1 loop
905 X : Element_Access := EA (K);
908 -- First we remove the element we're about to deallocate from
909 -- the vector, in case the deallocation fails, in order to
910 -- preserve representation invariants.
914 -- The element has been removed from the vector, so it is now
915 -- safe to attempt to deallocate it.
921 EA (Index .. New_Last) := EA (J .. Old_Last);
922 Container.Last := New_Last;
927 (Container : in out Vector;
928 Position : in out Cursor;
929 Count : Count_Type := 1)
931 pragma Warnings (Off, Position);
934 if Position.Container = null then
935 raise Constraint_Error with "Position cursor has no element";
938 if Position.Container /= Container'Unrestricted_Access then
939 raise Program_Error with "Position cursor denotes wrong container";
942 if Position.Index > Container.Last then
943 raise Program_Error with "Position index is out of range";
946 Delete (Container, Position.Index, Count);
948 Position := No_Element;
955 procedure Delete_First
956 (Container : in out Vector;
957 Count : Count_Type := 1)
964 if Count >= Length (Container) then
969 Delete (Container, Index_Type'First, Count);
976 procedure Delete_Last
977 (Container : in out Vector;
978 Count : Count_Type := 1)
981 -- It is not permitted to delete items while the container is busy (for
982 -- example, we're in the middle of a passive iteration). However, we
983 -- always treat deleting 0 items as a no-op, even when we're busy, so we
984 -- simply return without checking.
990 -- We cannot simply subsume the empty case into the loop below (the loop
991 -- would iterate 0 times), because we rename the internal array object
992 -- (which is allocated), but an empty vector isn't guaranteed to have
993 -- actually allocated an array. (Note that an empty vector can never be
994 -- busy, so there's no semantic harm in returning early here.)
996 if Container.Is_Empty then
1000 -- The tampering bits exist to prevent an item from being deleted (or
1001 -- otherwise harmfully manipulated) while it is being visited. Query,
1002 -- Update, and Iterate increment the busy count on entry, and decrement
1003 -- the count on exit. Delete_Last checks the count to determine whether
1004 -- it is being called while the associated callback procedure is
1007 if Container.Busy > 0 then
1008 raise Program_Error with
1009 "attempt to tamper with cursors (vector is busy)";
1012 -- Elements in an indefinite vector are allocated, so we must iterate
1013 -- over the loop and deallocate elements one-at-a-time. We work from
1014 -- back to front, deleting the last element during each pass, in order
1015 -- to gracefully handle deallocation failures.
1018 E : Elements_Array renames Container.Elements.EA;
1021 for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop
1023 J : constant Index_Type := Container.Last;
1024 X : Element_Access := E (J);
1027 -- Note that we first isolate the element we're deleting,
1028 -- removing it from the vector, before we actually deallocate
1029 -- it, in order to preserve representation invariants even if
1030 -- the deallocation fails.
1033 Container.Last := J - 1;
1035 -- Container invariants have been restored, so it is now safe
1036 -- to deallocate the element.
1049 (Container : Vector;
1050 Index : Index_Type) return Element_Type
1053 if Index > Container.Last then
1054 raise Constraint_Error with "Index is out of range";
1058 EA : constant Element_Access := Container.Elements.EA (Index);
1062 raise Constraint_Error with "element is empty";
1069 function Element (Position : Cursor) return Element_Type is
1071 if Position.Container = null then
1072 raise Constraint_Error with "Position cursor has no element";
1075 if Position.Index > Position.Container.Last then
1076 raise Constraint_Error with "Position cursor is out of range";
1080 EA : constant Element_Access :=
1081 Position.Container.Elements.EA (Position.Index);
1085 raise Constraint_Error with "element is empty";
1096 procedure Finalize (Container : in out Vector) is
1098 Clear (Container); -- Checks busy-bit
1101 X : Elements_Access := Container.Elements;
1103 Container.Elements := null;
1113 (Container : Vector;
1114 Item : Element_Type;
1115 Position : Cursor := No_Element) return Cursor
1118 if Position.Container /= null then
1119 if Position.Container /= Container'Unrestricted_Access then
1120 raise Program_Error with "Position cursor denotes wrong container";
1123 if Position.Index > Container.Last then
1124 raise Program_Error with "Position index is out of range";
1128 for J in Position.Index .. Container.Last loop
1129 if Container.Elements.EA (J) /= null
1130 and then Container.Elements.EA (J).all = Item
1132 return (Container'Unchecked_Access, J);
1144 (Container : Vector;
1145 Item : Element_Type;
1146 Index : Index_Type := Index_Type'First) return Extended_Index
1149 for Indx in Index .. Container.Last loop
1150 if Container.Elements.EA (Indx) /= null
1151 and then Container.Elements.EA (Indx).all = Item
1164 function First (Container : Vector) return Cursor is
1166 if Is_Empty (Container) then
1170 return (Container'Unchecked_Access, Index_Type'First);
1173 function First (Object : Iterator) return Cursor is
1174 C : constant Cursor := (Object.Container, Index_Type'First);
1183 function First_Element (Container : Vector) return Element_Type is
1185 if Container.Last = No_Index then
1186 raise Constraint_Error with "Container is empty";
1190 EA : constant Element_Access :=
1191 Container.Elements.EA (Index_Type'First);
1195 raise Constraint_Error with "first element is empty";
1206 function First_Index (Container : Vector) return Index_Type is
1207 pragma Unreferenced (Container);
1209 return Index_Type'First;
1212 ---------------------
1213 -- Generic_Sorting --
1214 ---------------------
1216 package body Generic_Sorting is
1218 -----------------------
1219 -- Local Subprograms --
1220 -----------------------
1222 function Is_Less (L, R : Element_Access) return Boolean;
1223 pragma Inline (Is_Less);
1229 function Is_Less (L, R : Element_Access) return Boolean is
1236 return L.all < R.all;
1244 function Is_Sorted (Container : Vector) return Boolean is
1246 if Container.Last <= Index_Type'First then
1251 E : Elements_Array renames Container.Elements.EA;
1253 for I in Index_Type'First .. Container.Last - 1 loop
1254 if Is_Less (E (I + 1), E (I)) then
1267 procedure Merge (Target, Source : in out Vector) is
1268 I, J : Index_Type'Base;
1271 if Target.Last < Index_Type'First then
1272 Move (Target => Target, Source => Source);
1276 if Target'Address = Source'Address then
1280 if Source.Last < Index_Type'First then
1284 if Source.Busy > 0 then
1285 raise Program_Error with
1286 "attempt to tamper with cursors (vector is busy)";
1289 I := Target.Last; -- original value (before Set_Length)
1290 Target.Set_Length (Length (Target) + Length (Source));
1292 J := Target.Last; -- new value (after Set_Length)
1293 while Source.Last >= Index_Type'First loop
1295 (Source.Last <= Index_Type'First
1296 or else not (Is_Less
1297 (Source.Elements.EA (Source.Last),
1298 Source.Elements.EA (Source.Last - 1))));
1300 if I < Index_Type'First then
1302 Src : Elements_Array renames
1303 Source.Elements.EA (Index_Type'First .. Source.Last);
1306 Target.Elements.EA (Index_Type'First .. J) := Src;
1307 Src := (others => null);
1310 Source.Last := No_Index;
1315 (I <= Index_Type'First
1316 or else not (Is_Less
1317 (Target.Elements.EA (I),
1318 Target.Elements.EA (I - 1))));
1321 Src : Element_Access renames Source.Elements.EA (Source.Last);
1322 Tgt : Element_Access renames Target.Elements.EA (I);
1325 if Is_Less (Src, Tgt) then
1326 Target.Elements.EA (J) := Tgt;
1331 Target.Elements.EA (J) := Src;
1333 Source.Last := Source.Last - 1;
1345 procedure Sort (Container : in out Vector) is
1347 procedure Sort is new Generic_Array_Sort
1348 (Index_Type => Index_Type,
1349 Element_Type => Element_Access,
1350 Array_Type => Elements_Array,
1353 -- Start of processing for Sort
1356 if Container.Last <= Index_Type'First then
1360 if Container.Lock > 0 then
1361 raise Program_Error with
1362 "attempt to tamper with elements (vector is locked)";
1365 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1368 end Generic_Sorting;
1374 function Has_Element (Position : Cursor) return Boolean is
1376 if Position.Container = null then
1380 return Position.Index <= Position.Container.Last;
1388 (Container : in out Vector;
1389 Before : Extended_Index;
1390 New_Item : Element_Type;
1391 Count : Count_Type := 1)
1393 Old_Length : constant Count_Type := Container.Length;
1395 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1396 New_Length : Count_Type'Base; -- sum of current length and Count
1397 New_Last : Index_Type'Base; -- last index of vector after insertion
1399 Index : Index_Type'Base; -- scratch for intermediate values
1400 J : Count_Type'Base; -- scratch
1402 New_Capacity : Count_Type'Base; -- length of new, expanded array
1403 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1404 Dst : Elements_Access; -- new, expanded internal array
1407 -- As a precondition on the generic actual Index_Type, the base type
1408 -- must include Index_Type'Pred (Index_Type'First); this is the value
1409 -- that Container.Last assumes when the vector is empty. However, we do
1410 -- not allow that as the value for Index when specifying where the new
1411 -- items should be inserted, so we must manually check. (That the user
1412 -- is allowed to specify the value at all here is a consequence of the
1413 -- declaration of the Extended_Index subtype, which includes the values
1414 -- in the base range that immediately precede and immediately follow the
1415 -- values in the Index_Type.)
1417 if Before < Index_Type'First then
1418 raise Constraint_Error with
1419 "Before index is out of range (too small)";
1422 -- We do allow a value greater than Container.Last to be specified as
1423 -- the Index, but only if it's immediately greater. This allows for the
1424 -- case of appending items to the back end of the vector. (It is assumed
1425 -- that specifying an index value greater than Last + 1 indicates some
1426 -- deeper flaw in the caller's algorithm, so that case is treated as a
1429 if Before > Container.Last
1430 and then Before > Container.Last + 1
1432 raise Constraint_Error with
1433 "Before index is out of range (too large)";
1436 -- We treat inserting 0 items into the container as a no-op, even when
1437 -- the container is busy, so we simply return.
1443 -- There are two constraints we need to satisfy. The first constraint is
1444 -- that a container cannot have more than Count_Type'Last elements, so
1445 -- we must check the sum of the current length and the insertion count.
1446 -- Note that we cannot simply add these values, because of the
1447 -- possibility of overflow.
1449 if Old_Length > Count_Type'Last - Count then
1450 raise Constraint_Error with "Count is out of range";
1453 -- It is now safe compute the length of the new vector, without fear of
1456 New_Length := Old_Length + Count;
1458 -- The second constraint is that the new Last index value cannot exceed
1459 -- Index_Type'Last. In each branch below, we calculate the maximum
1460 -- length (computed from the range of values in Index_Type), and then
1461 -- compare the new length to the maximum length. If the new length is
1462 -- acceptable, then we compute the new last index from that.
1464 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1466 -- We have to handle the case when there might be more values in the
1467 -- range of Index_Type than in the range of Count_Type.
1469 if Index_Type'First <= 0 then
1471 -- We know that No_Index (the same as Index_Type'First - 1) is
1472 -- less than 0, so it is safe to compute the following sum without
1473 -- fear of overflow.
1475 Index := No_Index + Index_Type'Base (Count_Type'Last);
1477 if Index <= Index_Type'Last then
1479 -- We have determined that range of Index_Type has at least as
1480 -- many values as in Count_Type, so Count_Type'Last is the
1481 -- maximum number of items that are allowed.
1483 Max_Length := Count_Type'Last;
1486 -- The range of Index_Type has fewer values than in Count_Type,
1487 -- so the maximum number of items is computed from the range of
1490 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1494 -- No_Index is equal or greater than 0, so we can safely compute
1495 -- the difference without fear of overflow (which we would have to
1496 -- worry about if No_Index were less than 0, but that case is
1499 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1502 elsif Index_Type'First <= 0 then
1504 -- We know that No_Index (the same as Index_Type'First - 1) is less
1505 -- than 0, so it is safe to compute the following sum without fear of
1508 J := Count_Type'Base (No_Index) + Count_Type'Last;
1510 if J <= Count_Type'Base (Index_Type'Last) then
1512 -- We have determined that range of Index_Type has at least as
1513 -- many values as in Count_Type, so Count_Type'Last is the maximum
1514 -- number of items that are allowed.
1516 Max_Length := Count_Type'Last;
1519 -- The range of Index_Type has fewer values than Count_Type does,
1520 -- so the maximum number of items is computed from the range of
1524 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1528 -- No_Index is equal or greater than 0, so we can safely compute the
1529 -- difference without fear of overflow (which we would have to worry
1530 -- about if No_Index were less than 0, but that case is handled
1534 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1537 -- We have just computed the maximum length (number of items). We must
1538 -- now compare the requested length to the maximum length, as we do not
1539 -- allow a vector expand beyond the maximum (because that would create
1540 -- an internal array with a last index value greater than
1541 -- Index_Type'Last, with no way to index those elements).
1543 if New_Length > Max_Length then
1544 raise Constraint_Error with "Count is out of range";
1547 -- New_Last is the last index value of the items in the container after
1548 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1549 -- compute its value from the New_Length.
1551 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1552 New_Last := No_Index + Index_Type'Base (New_Length);
1555 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1558 if Container.Elements = null then
1559 pragma Assert (Container.Last = No_Index);
1561 -- This is the simplest case, with which we must always begin: we're
1562 -- inserting items into an empty vector that hasn't allocated an
1563 -- internal array yet. Note that we don't need to check the busy bit
1564 -- here, because an empty container cannot be busy.
1566 -- In an indefinite vector, elements are allocated individually, and
1567 -- stored as access values on the internal array (the length of which
1568 -- represents the vector "capacity"), which is separately allocated.
1570 Container.Elements := new Elements_Type (New_Last);
1572 -- The element backbone has been successfully allocated, so now we
1573 -- allocate the elements.
1575 for Idx in Container.Elements.EA'Range loop
1577 -- In order to preserve container invariants, we always attempt
1578 -- the element allocation first, before setting the Last index
1579 -- value, in case the allocation fails (either because there is no
1580 -- storage available, or because element initialization fails).
1582 Container.Elements.EA (Idx) := new Element_Type'(New_Item);
1584 -- The allocation of the element succeeded, so it is now safe to
1585 -- update the Last index, restoring container invariants.
1587 Container.Last := Idx;
1593 -- The tampering bits exist to prevent an item from being harmfully
1594 -- manipulated while it is being visited. Query, Update, and Iterate
1595 -- increment the busy count on entry, and decrement the count on
1596 -- exit. Insert checks the count to determine whether it is being called
1597 -- while the associated callback procedure is executing.
1599 if Container.Busy > 0 then
1600 raise Program_Error with
1601 "attempt to tamper with cursors (vector is busy)";
1604 if New_Length <= Container.Elements.EA'Length then
1606 -- In this case, we're inserting elements into a vector that has
1607 -- already allocated an internal array, and the existing array has
1608 -- enough unused storage for the new items.
1611 E : Elements_Array renames Container.Elements.EA;
1612 K : Index_Type'Base;
1615 if Before > Container.Last then
1617 -- The new items are being appended to the vector, so no
1618 -- sliding of existing elements is required.
1620 for Idx in Before .. New_Last loop
1622 -- In order to preserve container invariants, we always
1623 -- attempt the element allocation first, before setting the
1624 -- Last index value, in case the allocation fails (either
1625 -- because there is no storage available, or because element
1626 -- initialization fails).
1628 E (Idx) := new Element_Type'(New_Item);
1630 -- The allocation of the element succeeded, so it is now
1631 -- safe to update the Last index, restoring container
1634 Container.Last := Idx;
1638 -- The new items are being inserted before some existing
1639 -- elements, so we must slide the existing elements up to their
1640 -- new home. We use the wider of Index_Type'Base and
1641 -- Count_Type'Base as the type for intermediate index values.
1643 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1644 Index := Before + Index_Type'Base (Count);
1646 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1649 -- The new items are being inserted in the middle of the array,
1650 -- in the range [Before, Index). Copy the existing elements to
1651 -- the end of the array, to make room for the new items.
1653 E (Index .. New_Last) := E (Before .. Container.Last);
1654 Container.Last := New_Last;
1656 -- We have copied the existing items up to the end of the
1657 -- array, to make room for the new items in the middle of
1658 -- the array. Now we actually allocate the new items.
1660 -- Note: initialize K outside loop to make it clear that
1661 -- K always has a value if the exception handler triggers.
1665 while K < Index loop
1666 E (K) := new Element_Type'(New_Item);
1673 -- Values in the range [Before, K) were successfully
1674 -- allocated, but values in the range [K, Index) are
1675 -- stale (these array positions contain copies of the
1676 -- old items, that did not get assigned a new item,
1677 -- because the allocation failed). We must finish what
1678 -- we started by clearing out all of the stale values,
1679 -- leaving a "hole" in the middle of the array.
1681 E (K .. Index - 1) := (others => null);
1690 -- In this case, we're inserting elements into a vector that has already
1691 -- allocated an internal array, but the existing array does not have
1692 -- enough storage, so we must allocate a new, longer array. In order to
1693 -- guarantee that the amortized insertion cost is O(1), we always
1694 -- allocate an array whose length is some power-of-two factor of the
1695 -- current array length. (The new array cannot have a length less than
1696 -- the New_Length of the container, but its last index value cannot be
1697 -- greater than Index_Type'Last.)
1699 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1700 while New_Capacity < New_Length loop
1701 if New_Capacity > Count_Type'Last / 2 then
1702 New_Capacity := Count_Type'Last;
1706 New_Capacity := 2 * New_Capacity;
1709 if New_Capacity > Max_Length then
1711 -- We have reached the limit of capacity, so no further expansion
1712 -- will occur. (This is not a problem, as there is never a need to
1713 -- have more capacity than the maximum container length.)
1715 New_Capacity := Max_Length;
1718 -- We have computed the length of the new internal array (and this is
1719 -- what "vector capacity" means), so use that to compute its last index.
1721 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1722 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1726 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1729 -- Now we allocate the new, longer internal array. If the allocation
1730 -- fails, we have not changed any container state, so no side-effect
1731 -- will occur as a result of propagating the exception.
1733 Dst := new Elements_Type (Dst_Last);
1735 -- We have our new internal array. All that needs to be done now is to
1736 -- copy the existing items (if any) from the old array (the "source"
1737 -- array) to the new array (the "destination" array), and then
1738 -- deallocate the old array.
1741 Src : Elements_Access := Container.Elements;
1744 Dst.EA (Index_Type'First .. Before - 1) :=
1745 Src.EA (Index_Type'First .. Before - 1);
1747 if Before > Container.Last then
1749 -- The new items are being appended to the vector, so no
1750 -- sliding of existing elements is required.
1752 -- We have copied the elements from to the old, source array to
1753 -- the new, destination array, so we can now deallocate the old
1756 Container.Elements := Dst;
1759 -- Now we append the new items.
1761 for Idx in Before .. New_Last loop
1763 -- In order to preserve container invariants, we always
1764 -- attempt the element allocation first, before setting the
1765 -- Last index value, in case the allocation fails (either
1766 -- because there is no storage available, or because element
1767 -- initialization fails).
1769 Dst.EA (Idx) := new Element_Type'(New_Item);
1771 -- The allocation of the element succeeded, so it is now safe
1772 -- to update the Last index, restoring container invariants.
1774 Container.Last := Idx;
1778 -- The new items are being inserted before some existing elements,
1779 -- so we must slide the existing elements up to their new home.
1781 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1782 Index := Before + Index_Type'Base (Count);
1785 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1788 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1790 -- We have copied the elements from to the old, source array to
1791 -- the new, destination array, so we can now deallocate the old
1794 Container.Elements := Dst;
1795 Container.Last := New_Last;
1798 -- The new array has a range in the middle containing null access
1799 -- values. We now fill in that partition of the array with the new
1802 for Idx in Before .. Index - 1 loop
1804 -- Note that container invariants have already been satisfied
1805 -- (in particular, the Last index value of the vector has
1806 -- already been updated), so if this allocation fails we simply
1807 -- let it propagate.
1809 Dst.EA (Idx) := new Element_Type'(New_Item);
1816 (Container : in out Vector;
1817 Before : Extended_Index;
1820 N : constant Count_Type := Length (New_Item);
1821 J : Index_Type'Base;
1824 -- Use Insert_Space to create the "hole" (the destination slice) into
1825 -- which we copy the source items.
1827 Insert_Space (Container, Before, Count => N);
1831 -- There's nothing else to do here (vetting of parameters was
1832 -- performed already in Insert_Space), so we simply return.
1837 if Container'Address /= New_Item'Address then
1839 -- This is the simple case. New_Item denotes an object different
1840 -- from Container, so there's nothing special we need to do to copy
1841 -- the source items to their destination, because all of the source
1842 -- items are contiguous.
1845 subtype Src_Index_Subtype is Index_Type'Base range
1846 Index_Type'First .. New_Item.Last;
1848 Src : Elements_Array renames
1849 New_Item.Elements.EA (Src_Index_Subtype);
1851 Dst : Elements_Array renames Container.Elements.EA;
1853 Dst_Index : Index_Type'Base;
1856 Dst_Index := Before - 1;
1857 for Src_Index in Src'Range loop
1858 Dst_Index := Dst_Index + 1;
1860 if Src (Src_Index) /= null then
1861 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1869 -- New_Item denotes the same object as Container, so an insertion has
1870 -- potentially split the source items. The first source slice is
1871 -- [Index_Type'First, Before), and the second source slice is
1872 -- [J, Container.Last], where index value J is the first index of the
1873 -- second slice. (J gets computed below, but only after we have
1874 -- determined that the second source slice is non-empty.) The
1875 -- destination slice is always the range [Before, J). We perform the
1876 -- copy in two steps, using each of the two slices of the source items.
1879 L : constant Index_Type'Base := Before - 1;
1881 subtype Src_Index_Subtype is Index_Type'Base range
1882 Index_Type'First .. L;
1884 Src : Elements_Array renames
1885 Container.Elements.EA (Src_Index_Subtype);
1887 Dst : Elements_Array renames Container.Elements.EA;
1889 Dst_Index : Index_Type'Base;
1892 -- We first copy the source items that precede the space we
1893 -- inserted. (If Before equals Index_Type'First, then this first
1894 -- source slice will be empty, which is harmless.)
1896 Dst_Index := Before - 1;
1897 for Src_Index in Src'Range loop
1898 Dst_Index := Dst_Index + 1;
1900 if Src (Src_Index) /= null then
1901 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1905 if Src'Length = N then
1907 -- The new items were effectively appended to the container, so we
1908 -- have already copied all of the items that need to be copied.
1909 -- We return early here, even though the source slice below is
1910 -- empty (so the assignment would be harmless), because we want to
1911 -- avoid computing J, which will overflow if J is greater than
1912 -- Index_Type'Base'Last.
1918 -- Index value J is the first index of the second source slice. (It is
1919 -- also 1 greater than the last index of the destination slice.) Note:
1920 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
1921 -- to avoid overflow. Prevent that by returning early above, immediately
1922 -- after copying the first slice of the source, and determining that
1923 -- this second slice of the source is empty.
1925 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1926 J := Before + Index_Type'Base (N);
1929 J := Index_Type'Base (Count_Type'Base (Before) + N);
1933 subtype Src_Index_Subtype is Index_Type'Base range
1934 J .. Container.Last;
1936 Src : Elements_Array renames
1937 Container.Elements.EA (Src_Index_Subtype);
1939 Dst : Elements_Array renames Container.Elements.EA;
1941 Dst_Index : Index_Type'Base;
1944 -- We next copy the source items that follow the space we inserted.
1945 -- Index value Dst_Index is the first index of that portion of the
1946 -- destination that receives this slice of the source. (For the
1947 -- reasons given above, this slice is guaranteed to be non-empty.)
1949 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1950 Dst_Index := J - Index_Type'Base (Src'Length);
1953 Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
1956 for Src_Index in Src'Range loop
1957 if Src (Src_Index) /= null then
1958 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1961 Dst_Index := Dst_Index + 1;
1967 (Container : in out Vector;
1971 Index : Index_Type'Base;
1974 if Before.Container /= null
1975 and then Before.Container /= Container'Unchecked_Access
1977 raise Program_Error with "Before cursor denotes wrong container";
1980 if Is_Empty (New_Item) then
1984 if Before.Container = null
1985 or else Before.Index > Container.Last
1987 if Container.Last = Index_Type'Last then
1988 raise Constraint_Error with
1989 "vector is already at its maximum length";
1992 Index := Container.Last + 1;
1995 Index := Before.Index;
1998 Insert (Container, Index, New_Item);
2002 (Container : in out Vector;
2005 Position : out Cursor)
2007 Index : Index_Type'Base;
2010 if Before.Container /= null
2011 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
2013 raise Program_Error with "Before cursor denotes wrong container";
2016 if Is_Empty (New_Item) then
2017 if Before.Container = null
2018 or else Before.Index > Container.Last
2020 Position := No_Element;
2022 Position := (Container'Unchecked_Access, Before.Index);
2028 if Before.Container = null
2029 or else Before.Index > Container.Last
2031 if Container.Last = Index_Type'Last then
2032 raise Constraint_Error with
2033 "vector is already at its maximum length";
2036 Index := Container.Last + 1;
2039 Index := Before.Index;
2042 Insert (Container, Index, New_Item);
2044 Position := Cursor'(Container'Unchecked_Access, Index);
2048 (Container : in out Vector;
2050 New_Item : Element_Type;
2051 Count : Count_Type := 1)
2053 Index : Index_Type'Base;
2056 if Before.Container /= null
2057 and then Before.Container /= Container'Unchecked_Access
2059 raise Program_Error with "Before cursor denotes wrong container";
2066 if Before.Container = null
2067 or else Before.Index > Container.Last
2069 if Container.Last = Index_Type'Last then
2070 raise Constraint_Error with
2071 "vector is already at its maximum length";
2074 Index := Container.Last + 1;
2077 Index := Before.Index;
2080 Insert (Container, Index, New_Item, Count);
2084 (Container : in out Vector;
2086 New_Item : Element_Type;
2087 Position : out Cursor;
2088 Count : Count_Type := 1)
2090 Index : Index_Type'Base;
2093 if Before.Container /= null
2094 and then Before.Container /= Container'Unchecked_Access
2096 raise Program_Error with "Before cursor denotes wrong container";
2100 if Before.Container = null
2101 or else Before.Index > Container.Last
2103 Position := No_Element;
2105 Position := (Container'Unchecked_Access, Before.Index);
2111 if Before.Container = null
2112 or else Before.Index > Container.Last
2114 if Container.Last = Index_Type'Last then
2115 raise Constraint_Error with
2116 "vector is already at its maximum length";
2119 Index := Container.Last + 1;
2122 Index := Before.Index;
2125 Insert (Container, Index, New_Item, Count);
2127 Position := (Container'Unchecked_Access, Index);
2134 procedure Insert_Space
2135 (Container : in out Vector;
2136 Before : Extended_Index;
2137 Count : Count_Type := 1)
2139 Old_Length : constant Count_Type := Container.Length;
2141 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2142 New_Length : Count_Type'Base; -- sum of current length and Count
2143 New_Last : Index_Type'Base; -- last index of vector after insertion
2145 Index : Index_Type'Base; -- scratch for intermediate values
2146 J : Count_Type'Base; -- scratch
2148 New_Capacity : Count_Type'Base; -- length of new, expanded array
2149 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2150 Dst : Elements_Access; -- new, expanded internal array
2153 -- As a precondition on the generic actual Index_Type, the base type
2154 -- must include Index_Type'Pred (Index_Type'First); this is the value
2155 -- that Container.Last assumes when the vector is empty. However, we do
2156 -- not allow that as the value for Index when specifying where the new
2157 -- items should be inserted, so we must manually check. (That the user
2158 -- is allowed to specify the value at all here is a consequence of the
2159 -- declaration of the Extended_Index subtype, which includes the values
2160 -- in the base range that immediately precede and immediately follow the
2161 -- values in the Index_Type.)
2163 if Before < Index_Type'First then
2164 raise Constraint_Error with
2165 "Before index is out of range (too small)";
2168 -- We do allow a value greater than Container.Last to be specified as
2169 -- the Index, but only if it's immediately greater. This allows for the
2170 -- case of appending items to the back end of the vector. (It is assumed
2171 -- that specifying an index value greater than Last + 1 indicates some
2172 -- deeper flaw in the caller's algorithm, so that case is treated as a
2175 if Before > Container.Last
2176 and then Before > Container.Last + 1
2178 raise Constraint_Error with
2179 "Before index is out of range (too large)";
2182 -- We treat inserting 0 items into the container as a no-op, even when
2183 -- the container is busy, so we simply return.
2189 -- There are two constraints we need to satisfy. The first constraint is
2190 -- that a container cannot have more than Count_Type'Last elements, so
2191 -- we must check the sum of the current length and the insertion
2192 -- count. Note that we cannot simply add these values, because of the
2193 -- possibility of overflow.
2195 if Old_Length > Count_Type'Last - Count then
2196 raise Constraint_Error with "Count is out of range";
2199 -- It is now safe compute the length of the new vector, without fear of
2202 New_Length := Old_Length + Count;
2204 -- The second constraint is that the new Last index value cannot exceed
2205 -- Index_Type'Last. In each branch below, we calculate the maximum
2206 -- length (computed from the range of values in Index_Type), and then
2207 -- compare the new length to the maximum length. If the new length is
2208 -- acceptable, then we compute the new last index from that.
2210 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2211 -- We have to handle the case when there might be more values in the
2212 -- range of Index_Type than in the range of Count_Type.
2214 if Index_Type'First <= 0 then
2216 -- We know that No_Index (the same as Index_Type'First - 1) is
2217 -- less than 0, so it is safe to compute the following sum without
2218 -- fear of overflow.
2220 Index := No_Index + Index_Type'Base (Count_Type'Last);
2222 if Index <= Index_Type'Last then
2224 -- We have determined that range of Index_Type has at least as
2225 -- many values as in Count_Type, so Count_Type'Last is the
2226 -- maximum number of items that are allowed.
2228 Max_Length := Count_Type'Last;
2231 -- The range of Index_Type has fewer values than in Count_Type,
2232 -- so the maximum number of items is computed from the range of
2235 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2239 -- No_Index is equal or greater than 0, so we can safely compute
2240 -- the difference without fear of overflow (which we would have to
2241 -- worry about if No_Index were less than 0, but that case is
2244 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2247 elsif Index_Type'First <= 0 then
2249 -- We know that No_Index (the same as Index_Type'First - 1) is less
2250 -- than 0, so it is safe to compute the following sum without fear of
2253 J := Count_Type'Base (No_Index) + Count_Type'Last;
2255 if J <= Count_Type'Base (Index_Type'Last) then
2257 -- We have determined that range of Index_Type has at least as
2258 -- many values as in Count_Type, so Count_Type'Last is the maximum
2259 -- number of items that are allowed.
2261 Max_Length := Count_Type'Last;
2264 -- The range of Index_Type has fewer values than Count_Type does,
2265 -- so the maximum number of items is computed from the range of
2269 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2273 -- No_Index is equal or greater than 0, so we can safely compute the
2274 -- difference without fear of overflow (which we would have to worry
2275 -- about if No_Index were less than 0, but that case is handled
2279 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2282 -- We have just computed the maximum length (number of items). We must
2283 -- now compare the requested length to the maximum length, as we do not
2284 -- allow a vector expand beyond the maximum (because that would create
2285 -- an internal array with a last index value greater than
2286 -- Index_Type'Last, with no way to index those elements).
2288 if New_Length > Max_Length then
2289 raise Constraint_Error with "Count is out of range";
2292 -- New_Last is the last index value of the items in the container after
2293 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2294 -- compute its value from the New_Length.
2296 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2297 New_Last := No_Index + Index_Type'Base (New_Length);
2300 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2303 if Container.Elements = null then
2304 pragma Assert (Container.Last = No_Index);
2306 -- This is the simplest case, with which we must always begin: we're
2307 -- inserting items into an empty vector that hasn't allocated an
2308 -- internal array yet. Note that we don't need to check the busy bit
2309 -- here, because an empty container cannot be busy.
2311 -- In an indefinite vector, elements are allocated individually, and
2312 -- stored as access values on the internal array (the length of which
2313 -- represents the vector "capacity"), which is separately allocated.
2314 -- We have no elements here (because we're inserting "space"), so all
2315 -- we need to do is allocate the backbone.
2317 Container.Elements := new Elements_Type (New_Last);
2318 Container.Last := New_Last;
2323 -- The tampering bits exist to prevent an item from being harmfully
2324 -- manipulated while it is being visited. Query, Update, and Iterate
2325 -- increment the busy count on entry, and decrement the count on exit.
2326 -- Insert checks the count to determine whether it is being called while
2327 -- the associated callback procedure is executing.
2329 if Container.Busy > 0 then
2330 raise Program_Error with
2331 "attempt to tamper with cursors (vector is busy)";
2334 if New_Length <= Container.Elements.EA'Length then
2335 -- In this case, we're inserting elements into a vector that has
2336 -- already allocated an internal array, and the existing array has
2337 -- enough unused storage for the new items.
2340 E : Elements_Array renames Container.Elements.EA;
2343 if Before <= Container.Last then
2345 -- The new space is being inserted before some existing
2346 -- elements, so we must slide the existing elements up to their
2347 -- new home. We use the wider of Index_Type'Base and
2348 -- Count_Type'Base as the type for intermediate index values.
2350 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2351 Index := Before + Index_Type'Base (Count);
2354 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2357 E (Index .. New_Last) := E (Before .. Container.Last);
2358 E (Before .. Index - 1) := (others => null);
2362 Container.Last := New_Last;
2366 -- In this case, we're inserting elements into a vector that has already
2367 -- allocated an internal array, but the existing array does not have
2368 -- enough storage, so we must allocate a new, longer array. In order to
2369 -- guarantee that the amortized insertion cost is O(1), we always
2370 -- allocate an array whose length is some power-of-two factor of the
2371 -- current array length. (The new array cannot have a length less than
2372 -- the New_Length of the container, but its last index value cannot be
2373 -- greater than Index_Type'Last.)
2375 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2376 while New_Capacity < New_Length loop
2377 if New_Capacity > Count_Type'Last / 2 then
2378 New_Capacity := Count_Type'Last;
2382 New_Capacity := 2 * New_Capacity;
2385 if New_Capacity > Max_Length then
2387 -- We have reached the limit of capacity, so no further expansion
2388 -- will occur. (This is not a problem, as there is never a need to
2389 -- have more capacity than the maximum container length.)
2391 New_Capacity := Max_Length;
2394 -- We have computed the length of the new internal array (and this is
2395 -- what "vector capacity" means), so use that to compute its last index.
2397 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2398 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2402 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2405 -- Now we allocate the new, longer internal array. If the allocation
2406 -- fails, we have not changed any container state, so no side-effect
2407 -- will occur as a result of propagating the exception.
2409 Dst := new Elements_Type (Dst_Last);
2411 -- We have our new internal array. All that needs to be done now is to
2412 -- copy the existing items (if any) from the old array (the "source"
2413 -- array) to the new array (the "destination" array), and then
2414 -- deallocate the old array.
2417 Src : Elements_Access := Container.Elements;
2420 Dst.EA (Index_Type'First .. Before - 1) :=
2421 Src.EA (Index_Type'First .. Before - 1);
2423 if Before <= Container.Last then
2425 -- The new items are being inserted before some existing elements,
2426 -- so we must slide the existing elements up to their new home.
2428 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2429 Index := Before + Index_Type'Base (Count);
2432 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2435 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
2438 -- We have copied the elements from to the old, source array to the
2439 -- new, destination array, so we can now restore invariants, and
2440 -- deallocate the old array.
2442 Container.Elements := Dst;
2443 Container.Last := New_Last;
2448 procedure Insert_Space
2449 (Container : in out Vector;
2451 Position : out Cursor;
2452 Count : Count_Type := 1)
2454 Index : Index_Type'Base;
2457 if Before.Container /= null
2458 and then Before.Container /= Container'Unchecked_Access
2460 raise Program_Error with "Before cursor denotes wrong container";
2464 if Before.Container = null
2465 or else Before.Index > Container.Last
2467 Position := No_Element;
2469 Position := (Container'Unchecked_Access, Before.Index);
2475 if Before.Container = null
2476 or else Before.Index > Container.Last
2478 if Container.Last = Index_Type'Last then
2479 raise Constraint_Error with
2480 "vector is already at its maximum length";
2483 Index := Container.Last + 1;
2486 Index := Before.Index;
2489 Insert_Space (Container, Index, Count);
2491 Position := Cursor'(Container'Unchecked_Access, Index);
2498 function Is_Empty (Container : Vector) return Boolean is
2500 return Container.Last < Index_Type'First;
2508 (Container : Vector;
2509 Process : not null access procedure (Position : Cursor))
2511 V : Vector renames Container'Unrestricted_Access.all;
2512 B : Natural renames V.Busy;
2518 for Indx in Index_Type'First .. Container.Last loop
2519 Process (Cursor'(Container'Unchecked_Access, Indx));
2530 function Iterate (Container : Vector)
2531 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2533 It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
2539 (Container : Vector;
2541 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2543 It : constant Iterator :=
2544 (Container'Unchecked_Access, Start.Index);
2553 function Last (Container : Vector) return Cursor is
2555 if Is_Empty (Container) then
2559 return (Container'Unchecked_Access, Container.Last);
2562 function Last (Object : Iterator) return Cursor is
2563 C : constant Cursor := (Object.Container, Object.Container.Last);
2572 function Last_Element (Container : Vector) return Element_Type is
2574 if Container.Last = No_Index then
2575 raise Constraint_Error with "Container is empty";
2579 EA : constant Element_Access :=
2580 Container.Elements.EA (Container.Last);
2584 raise Constraint_Error with "last element is empty";
2595 function Last_Index (Container : Vector) return Extended_Index is
2597 return Container.Last;
2604 function Length (Container : Vector) return Count_Type is
2605 L : constant Index_Type'Base := Container.Last;
2606 F : constant Index_Type := Index_Type'First;
2609 -- The base range of the index type (Index_Type'Base) might not include
2610 -- all values for length (Count_Type). Contrariwise, the index type
2611 -- might include values outside the range of length. Hence we use
2612 -- whatever type is wider for intermediate values when calculating
2613 -- length. Note that no matter what the index type is, the maximum
2614 -- length to which a vector is allowed to grow is always the minimum
2615 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2617 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2618 -- to have a base range of -128 .. 127, but the corresponding vector
2619 -- would have lengths in the range 0 .. 255. In this case we would need
2620 -- to use Count_Type'Base for intermediate values.
2622 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2623 -- vector would have a maximum length of 10, but the index values lie
2624 -- outside the range of Count_Type (which is only 32 bits). In this
2625 -- case we would need to use Index_Type'Base for intermediate values.
2627 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2628 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2630 return Count_Type (L - F + 1);
2639 (Target : in out Vector;
2640 Source : in out Vector)
2643 if Target'Address = Source'Address then
2647 if Source.Busy > 0 then
2648 raise Program_Error with
2649 "attempt to tamper with cursors (Source is busy)";
2652 Clear (Target); -- Checks busy-bit
2655 Target_Elements : constant Elements_Access := Target.Elements;
2657 Target.Elements := Source.Elements;
2658 Source.Elements := Target_Elements;
2661 Target.Last := Source.Last;
2662 Source.Last := No_Index;
2669 function Next (Position : Cursor) return Cursor is
2671 if Position.Container = null then
2675 if Position.Index < Position.Container.Last then
2676 return (Position.Container, Position.Index + 1);
2682 function Next (Object : Iterator; Position : Cursor) return Cursor is
2684 if Position.Index = Object.Container.Last then
2687 return (Object.Container, Position.Index + 1);
2691 procedure Next (Position : in out Cursor) is
2693 if Position.Container = null then
2697 if Position.Index < Position.Container.Last then
2698 Position.Index := Position.Index + 1;
2700 Position := No_Element;
2708 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2710 Insert (Container, Index_Type'First, New_Item);
2714 (Container : in out Vector;
2715 New_Item : Element_Type;
2716 Count : Count_Type := 1)
2729 procedure Previous (Position : in out Cursor) is
2731 if Position.Container = null then
2735 if Position.Index > Index_Type'First then
2736 Position.Index := Position.Index - 1;
2738 Position := No_Element;
2742 function Previous (Position : Cursor) return Cursor is
2744 if Position.Container = null then
2748 if Position.Index > Index_Type'First then
2749 return (Position.Container, Position.Index - 1);
2755 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2757 if Position.Index > Index_Type'First then
2758 return (Object.Container, Position.Index - 1);
2768 procedure Query_Element
2769 (Container : Vector;
2771 Process : not null access procedure (Element : Element_Type))
2773 V : Vector renames Container'Unrestricted_Access.all;
2774 B : Natural renames V.Busy;
2775 L : Natural renames V.Lock;
2778 if Index > Container.Last then
2779 raise Constraint_Error with "Index is out of range";
2782 if V.Elements.EA (Index) = null then
2783 raise Constraint_Error with "element is null";
2790 Process (V.Elements.EA (Index).all);
2802 procedure Query_Element
2804 Process : not null access procedure (Element : Element_Type))
2807 if Position.Container = null then
2808 raise Constraint_Error with "Position cursor has no element";
2811 Query_Element (Position.Container.all, Position.Index, Process);
2819 (Stream : not null access Root_Stream_Type'Class;
2820 Container : out Vector)
2822 Length : Count_Type'Base;
2823 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
2830 Count_Type'Base'Read (Stream, Length);
2832 if Length > Capacity (Container) then
2833 Reserve_Capacity (Container, Capacity => Length);
2836 for J in Count_Type range 1 .. Length loop
2839 Boolean'Read (Stream, B);
2842 Container.Elements.EA (Last) :=
2843 new Element_Type'(Element_Type'Input (Stream));
2846 Container.Last := Last;
2851 (Stream : not null access Root_Stream_Type'Class;
2852 Position : out Cursor)
2855 raise Program_Error with "attempt to stream vector cursor";
2859 (Stream : not null access Root_Stream_Type'Class;
2860 Item : out Reference_Type)
2863 raise Program_Error with "attempt to stream reference";
2867 (Stream : not null access Root_Stream_Type'Class;
2868 Item : out Constant_Reference_Type)
2871 raise Program_Error with "attempt to stream reference";
2879 (Container : Vector;
2880 Position : Cursor) return Reference_Type
2883 pragma Unreferenced (Container);
2885 if Position.Container = null then
2886 raise Constraint_Error with "Position cursor has no element";
2889 if Position.Index > Position.Container.Last then
2890 raise Constraint_Error with "Position cursor is out of range";
2895 Position.Container.Elements.EA (Position.Index).all'Access);
2899 (Container : Vector;
2900 Position : Index_Type) return Reference_Type
2903 if Position > Container.Last then
2904 raise Constraint_Error with "Index is out of range";
2907 return (Element => Container.Elements.EA (Position).all'Access);
2910 ---------------------
2911 -- Replace_Element --
2912 ---------------------
2914 procedure Replace_Element
2915 (Container : in out Vector;
2917 New_Item : Element_Type)
2920 if Index > Container.Last then
2921 raise Constraint_Error with "Index is out of range";
2924 if Container.Lock > 0 then
2925 raise Program_Error with
2926 "attempt to tamper with elements (vector is locked)";
2930 X : Element_Access := Container.Elements.EA (Index);
2932 Container.Elements.EA (Index) := new Element_Type'(New_Item);
2935 end Replace_Element;
2937 procedure Replace_Element
2938 (Container : in out Vector;
2940 New_Item : Element_Type)
2943 if Position.Container = null then
2944 raise Constraint_Error with "Position cursor has no element";
2947 if Position.Container /= Container'Unrestricted_Access then
2948 raise Program_Error with "Position cursor denotes wrong container";
2951 if Position.Index > Container.Last then
2952 raise Constraint_Error with "Position cursor is out of range";
2955 if Container.Lock > 0 then
2956 raise Program_Error with
2957 "attempt to tamper with elements (vector is locked)";
2961 X : Element_Access := Container.Elements.EA (Position.Index);
2963 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
2966 end Replace_Element;
2968 ----------------------
2969 -- Reserve_Capacity --
2970 ----------------------
2972 procedure Reserve_Capacity
2973 (Container : in out Vector;
2974 Capacity : Count_Type)
2976 N : constant Count_Type := Length (Container);
2978 Index : Count_Type'Base;
2979 Last : Index_Type'Base;
2982 -- Reserve_Capacity can be used to either expand the storage available
2983 -- for elements (this would be its typical use, in anticipation of
2984 -- future insertion), or to trim back storage. In the latter case,
2985 -- storage can only be trimmed back to the limit of the container
2986 -- length. Note that Reserve_Capacity neither deletes (active) elements
2987 -- nor inserts elements; it only affects container capacity, never
2988 -- container length.
2990 if Capacity = 0 then
2992 -- This is a request to trim back storage, to the minimum amount
2993 -- possible given the current state of the container.
2997 -- The container is empty, so in this unique case we can
2998 -- deallocate the entire internal array. Note that an empty
2999 -- container can never be busy, so there's no need to check the
3003 X : Elements_Access := Container.Elements;
3006 -- First we remove the internal array from the container, to
3007 -- handle the case when the deallocation raises an exception
3008 -- (although that's unlikely, since this is simply an array of
3009 -- access values, all of which are null).
3011 Container.Elements := null;
3013 -- Container invariants have been restored, so it is now safe
3014 -- to attempt to deallocate the internal array.
3019 elsif N < Container.Elements.EA'Length then
3021 -- The container is not empty, and the current length is less than
3022 -- the current capacity, so there's storage available to trim. In
3023 -- this case, we allocate a new internal array having a length
3024 -- that exactly matches the number of items in the
3025 -- container. (Reserve_Capacity does not delete active elements,
3026 -- so this is the best we can do with respect to minimizing
3029 if Container.Busy > 0 then
3030 raise Program_Error with
3031 "attempt to tamper with cursors (vector is busy)";
3035 subtype Array_Index_Subtype is Index_Type'Base range
3036 Index_Type'First .. Container.Last;
3038 Src : Elements_Array renames
3039 Container.Elements.EA (Array_Index_Subtype);
3041 X : Elements_Access := Container.Elements;
3044 -- Although we have isolated the old internal array that we're
3045 -- going to deallocate, we don't deallocate it until we have
3046 -- successfully allocated a new one. If there is an exception
3047 -- during allocation (because there is not enough storage), we
3048 -- let it propagate without causing any side-effect.
3050 Container.Elements := new Elements_Type'(Container.Last, Src);
3052 -- We have successfully allocated a new internal array (with a
3053 -- smaller length than the old one, and containing a copy of
3054 -- just the active elements in the container), so we can
3055 -- deallocate the old array.
3064 -- Reserve_Capacity can be used to expand the storage available for
3065 -- elements, but we do not let the capacity grow beyond the number of
3066 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3067 -- to refer to the elements with index values greater than
3068 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3069 -- the Last index value of the new internal array, in a way that avoids
3070 -- any possibility of overflow.
3072 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3074 -- We perform a two-part test. First we determine whether the
3075 -- computed Last value lies in the base range of the type, and then
3076 -- determine whether it lies in the range of the index (sub)type.
3078 -- Last must satisfy this relation:
3079 -- First + Length - 1 <= Last
3080 -- We regroup terms:
3081 -- First - 1 <= Last - Length
3082 -- Which can rewrite as:
3083 -- No_Index <= Last - Length
3085 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
3086 raise Constraint_Error with "Capacity is out of range";
3089 -- We now know that the computed value of Last is within the base
3090 -- range of the type, so it is safe to compute its value:
3092 Last := No_Index + Index_Type'Base (Capacity);
3094 -- Finally we test whether the value is within the range of the
3095 -- generic actual index subtype:
3097 if Last > Index_Type'Last then
3098 raise Constraint_Error with "Capacity is out of range";
3101 elsif Index_Type'First <= 0 then
3103 -- Here we can compute Last directly, in the normal way. We know that
3104 -- No_Index is less than 0, so there is no danger of overflow when
3105 -- adding the (positive) value of Capacity.
3107 Index := Count_Type'Base (No_Index) + Capacity; -- Last
3109 if Index > Count_Type'Base (Index_Type'Last) then
3110 raise Constraint_Error with "Capacity is out of range";
3113 -- We know that the computed value (having type Count_Type) of Last
3114 -- is within the range of the generic actual index subtype, so it is
3115 -- safe to convert to Index_Type:
3117 Last := Index_Type'Base (Index);
3120 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3121 -- must test the length indirectly (by working backwards from the
3122 -- largest possible value of Last), in order to prevent overflow.
3124 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
3126 if Index < Count_Type'Base (No_Index) then
3127 raise Constraint_Error with "Capacity is out of range";
3130 -- We have determined that the value of Capacity would not create a
3131 -- Last index value outside of the range of Index_Type, so we can now
3132 -- safely compute its value.
3134 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
3137 -- The requested capacity is non-zero, but we don't know yet whether
3138 -- this is a request for expansion or contraction of storage.
3140 if Container.Elements = null then
3142 -- The container is empty (it doesn't even have an internal array),
3143 -- so this represents a request to allocate storage having the given
3146 Container.Elements := new Elements_Type (Last);
3150 if Capacity <= N then
3152 -- This is a request to trim back storage, but only to the limit of
3153 -- what's already in the container. (Reserve_Capacity never deletes
3154 -- active elements, it only reclaims excess storage.)
3156 if N < Container.Elements.EA'Length then
3158 -- The container is not empty (because the requested capacity is
3159 -- positive, and less than or equal to the container length), and
3160 -- the current length is less than the current capacity, so there
3161 -- is storage available to trim. In this case, we allocate a new
3162 -- internal array having a length that exactly matches the number
3163 -- of items in the container.
3165 if Container.Busy > 0 then
3166 raise Program_Error with
3167 "attempt to tamper with cursors (vector is busy)";
3171 subtype Array_Index_Subtype is Index_Type'Base range
3172 Index_Type'First .. Container.Last;
3174 Src : Elements_Array renames
3175 Container.Elements.EA (Array_Index_Subtype);
3177 X : Elements_Access := Container.Elements;
3180 -- Although we have isolated the old internal array that we're
3181 -- going to deallocate, we don't deallocate it until we have
3182 -- successfully allocated a new one. If there is an exception
3183 -- during allocation (because there is not enough storage), we
3184 -- let it propagate without causing any side-effect.
3186 Container.Elements := new Elements_Type'(Container.Last, Src);
3188 -- We have successfully allocated a new internal array (with a
3189 -- smaller length than the old one, and containing a copy of
3190 -- just the active elements in the container), so it is now
3191 -- safe to deallocate the old array.
3200 -- The requested capacity is larger than the container length (the
3201 -- number of active elements). Whether this represents a request for
3202 -- expansion or contraction of the current capacity depends on what the
3203 -- current capacity is.
3205 if Capacity = Container.Elements.EA'Length then
3207 -- The requested capacity matches the existing capacity, so there's
3208 -- nothing to do here. We treat this case as a no-op, and simply
3209 -- return without checking the busy bit.
3214 -- There is a change in the capacity of a non-empty container, so a new
3215 -- internal array will be allocated. (The length of the new internal
3216 -- array could be less or greater than the old internal array. We know
3217 -- only that the length of the new internal array is greater than the
3218 -- number of active elements in the container.) We must check whether
3219 -- the container is busy before doing anything else.
3221 if Container.Busy > 0 then
3222 raise Program_Error with
3223 "attempt to tamper with cursors (vector is busy)";
3226 -- We now allocate a new internal array, having a length different from
3227 -- its current value.
3230 X : Elements_Access := Container.Elements;
3232 subtype Index_Subtype is Index_Type'Base range
3233 Index_Type'First .. Container.Last;
3236 -- We now allocate a new internal array, having a length different
3237 -- from its current value.
3239 Container.Elements := new Elements_Type (Last);
3241 -- We have successfully allocated the new internal array, so now we
3242 -- move the existing elements from the existing the old internal
3243 -- array onto the new one. Note that we're just copying access
3244 -- values, to this should not raise any exceptions.
3246 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3248 -- We have moved the elements from the old internal array, so now we
3249 -- can deallocate it.
3253 end Reserve_Capacity;
3255 ----------------------
3256 -- Reverse_Elements --
3257 ----------------------
3259 procedure Reverse_Elements (Container : in out Vector) is
3261 if Container.Length <= 1 then
3265 if Container.Lock > 0 then
3266 raise Program_Error with
3267 "attempt to tamper with elements (vector is locked)";
3273 E : Elements_Array renames Container.Elements.EA;
3276 I := Index_Type'First;
3277 J := Container.Last;
3280 EI : constant Element_Access := E (I);
3291 end Reverse_Elements;
3297 function Reverse_Find
3298 (Container : Vector;
3299 Item : Element_Type;
3300 Position : Cursor := No_Element) return Cursor
3302 Last : Index_Type'Base;
3305 if Position.Container /= null
3306 and then Position.Container /= Container'Unchecked_Access
3308 raise Program_Error with "Position cursor denotes wrong container";
3311 if Position.Container = null
3312 or else Position.Index > Container.Last
3314 Last := Container.Last;
3316 Last := Position.Index;
3319 for Indx in reverse Index_Type'First .. Last loop
3320 if Container.Elements.EA (Indx) /= null
3321 and then Container.Elements.EA (Indx).all = Item
3323 return (Container'Unchecked_Access, Indx);
3330 ------------------------
3331 -- Reverse_Find_Index --
3332 ------------------------
3334 function Reverse_Find_Index
3335 (Container : Vector;
3336 Item : Element_Type;
3337 Index : Index_Type := Index_Type'Last) return Extended_Index
3339 Last : constant Index_Type'Base :=
3340 (if Index > Container.Last then Container.Last else Index);
3342 for Indx in reverse Index_Type'First .. Last loop
3343 if Container.Elements.EA (Indx) /= null
3344 and then Container.Elements.EA (Indx).all = Item
3351 end Reverse_Find_Index;
3353 ---------------------
3354 -- Reverse_Iterate --
3355 ---------------------
3357 procedure Reverse_Iterate
3358 (Container : Vector;
3359 Process : not null access procedure (Position : Cursor))
3361 V : Vector renames Container'Unrestricted_Access.all;
3362 B : Natural renames V.Busy;
3368 for Indx in reverse Index_Type'First .. Container.Last loop
3369 Process (Cursor'(Container'Unchecked_Access, Indx));
3378 end Reverse_Iterate;
3384 procedure Set_Length
3385 (Container : in out Vector;
3386 Length : Count_Type)
3388 Count : constant Count_Type'Base := Container.Length - Length;
3391 -- Set_Length allows the user to set the length explicitly, instead of
3392 -- implicitly as a side-effect of deletion or insertion. If the
3393 -- requested length is less than the current length, this is equivalent
3394 -- to deleting items from the back end of the vector. If the requested
3395 -- length is greater than the current length, then this is equivalent to
3396 -- inserting "space" (nonce items) at the end.
3399 Container.Delete_Last (Count);
3401 elsif Container.Last >= Index_Type'Last then
3402 raise Constraint_Error with "vector is already at its maximum length";
3405 Container.Insert_Space (Container.Last + 1, -Count);
3414 (Container : in out Vector;
3418 if I > Container.Last then
3419 raise Constraint_Error with "I index is out of range";
3422 if J > Container.Last then
3423 raise Constraint_Error with "J index is out of range";
3430 if Container.Lock > 0 then
3431 raise Program_Error with
3432 "attempt to tamper with elements (vector is locked)";
3436 EI : Element_Access renames Container.Elements.EA (I);
3437 EJ : Element_Access renames Container.Elements.EA (J);
3439 EI_Copy : constant Element_Access := EI;
3448 (Container : in out Vector;
3452 if I.Container = null then
3453 raise Constraint_Error with "I cursor has no element";
3456 if J.Container = null then
3457 raise Constraint_Error with "J cursor has no element";
3460 if I.Container /= Container'Unrestricted_Access then
3461 raise Program_Error with "I cursor denotes wrong container";
3464 if J.Container /= Container'Unrestricted_Access then
3465 raise Program_Error with "J cursor denotes wrong container";
3468 Swap (Container, I.Index, J.Index);
3476 (Container : Vector;
3477 Index : Extended_Index) return Cursor
3480 if Index not in Index_Type'First .. Container.Last then
3484 return Cursor'(Container'Unchecked_Access, Index);
3491 function To_Index (Position : Cursor) return Extended_Index is
3493 if Position.Container = null then
3497 if Position.Index <= Position.Container.Last then
3498 return Position.Index;
3508 function To_Vector (Length : Count_Type) return Vector is
3509 Index : Count_Type'Base;
3510 Last : Index_Type'Base;
3511 Elements : Elements_Access;
3515 return Empty_Vector;
3518 -- We create a vector object with a capacity that matches the specified
3519 -- Length, but we do not allow the vector capacity (the length of the
3520 -- internal array) to exceed the number of values in Index_Type'Range
3521 -- (otherwise, there would be no way to refer to those components via an
3522 -- index). We must therefore check whether the specified Length would
3523 -- create a Last index value greater than Index_Type'Last.
3525 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3527 -- We perform a two-part test. First we determine whether the
3528 -- computed Last value lies in the base range of the type, and then
3529 -- determine whether it lies in the range of the index (sub)type.
3531 -- Last must satisfy this relation:
3532 -- First + Length - 1 <= Last
3533 -- We regroup terms:
3534 -- First - 1 <= Last - Length
3535 -- Which can rewrite as:
3536 -- No_Index <= Last - Length
3538 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3539 raise Constraint_Error with "Length is out of range";
3542 -- We now know that the computed value of Last is within the base
3543 -- range of the type, so it is safe to compute its value:
3545 Last := No_Index + Index_Type'Base (Length);
3547 -- Finally we test whether the value is within the range of the
3548 -- generic actual index subtype:
3550 if Last > Index_Type'Last then
3551 raise Constraint_Error with "Length is out of range";
3554 elsif Index_Type'First <= 0 then
3556 -- Here we can compute Last directly, in the normal way. We know that
3557 -- No_Index is less than 0, so there is no danger of overflow when
3558 -- adding the (positive) value of Length.
3560 Index := Count_Type'Base (No_Index) + Length; -- Last
3562 if Index > Count_Type'Base (Index_Type'Last) then
3563 raise Constraint_Error with "Length is out of range";
3566 -- We know that the computed value (having type Count_Type) of Last
3567 -- is within the range of the generic actual index subtype, so it is
3568 -- safe to convert to Index_Type:
3570 Last := Index_Type'Base (Index);
3573 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3574 -- must test the length indirectly (by working backwards from the
3575 -- largest possible value of Last), in order to prevent overflow.
3577 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3579 if Index < Count_Type'Base (No_Index) then
3580 raise Constraint_Error with "Length is out of range";
3583 -- We have determined that the value of Length would not create a
3584 -- Last index value outside of the range of Index_Type, so we can now
3585 -- safely compute its value.
3587 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3590 Elements := new Elements_Type (Last);
3592 return Vector'(Controlled with Elements, Last, 0, 0);
3596 (New_Item : Element_Type;
3597 Length : Count_Type) return Vector
3599 Index : Count_Type'Base;
3600 Last : Index_Type'Base;
3601 Elements : Elements_Access;
3605 return Empty_Vector;
3608 -- We create a vector object with a capacity that matches the specified
3609 -- Length, but we do not allow the vector capacity (the length of the
3610 -- internal array) to exceed the number of values in Index_Type'Range
3611 -- (otherwise, there would be no way to refer to those components via an
3612 -- index). We must therefore check whether the specified Length would
3613 -- create a Last index value greater than Index_Type'Last.
3615 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3617 -- We perform a two-part test. First we determine whether the
3618 -- computed Last value lies in the base range of the type, and then
3619 -- determine whether it lies in the range of the index (sub)type.
3621 -- Last must satisfy this relation:
3622 -- First + Length - 1 <= Last
3623 -- We regroup terms:
3624 -- First - 1 <= Last - Length
3625 -- Which can rewrite as:
3626 -- No_Index <= Last - Length
3628 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3629 raise Constraint_Error with "Length is out of range";
3632 -- We now know that the computed value of Last is within the base
3633 -- range of the type, so it is safe to compute its value:
3635 Last := No_Index + Index_Type'Base (Length);
3637 -- Finally we test whether the value is within the range of the
3638 -- generic actual index subtype:
3640 if Last > Index_Type'Last then
3641 raise Constraint_Error with "Length is out of range";
3644 elsif Index_Type'First <= 0 then
3646 -- Here we can compute Last directly, in the normal way. We know that
3647 -- No_Index is less than 0, so there is no danger of overflow when
3648 -- adding the (positive) value of Length.
3650 Index := Count_Type'Base (No_Index) + Length; -- Last
3652 if Index > Count_Type'Base (Index_Type'Last) then
3653 raise Constraint_Error with "Length is out of range";
3656 -- We know that the computed value (having type Count_Type) of Last
3657 -- is within the range of the generic actual index subtype, so it is
3658 -- safe to convert to Index_Type:
3660 Last := Index_Type'Base (Index);
3663 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3664 -- must test the length indirectly (by working backwards from the
3665 -- largest possible value of Last), in order to prevent overflow.
3667 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3669 if Index < Count_Type'Base (No_Index) then
3670 raise Constraint_Error with "Length is out of range";
3673 -- We have determined that the value of Length would not create a
3674 -- Last index value outside of the range of Index_Type, so we can now
3675 -- safely compute its value.
3677 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3680 Elements := new Elements_Type (Last);
3682 -- We use Last as the index of the loop used to populate the internal
3683 -- array with items. In general, we prefer to initialize the loop index
3684 -- immediately prior to entering the loop. However, Last is also used in
3685 -- the exception handler (to reclaim elements that have been allocated,
3686 -- before propagating the exception), and the initialization of Last
3687 -- after entering the block containing the handler confuses some static
3688 -- analysis tools, with respect to whether Last has been properly
3689 -- initialized when the handler executes. So here we initialize our loop
3690 -- variable earlier than we prefer, before entering the block, so there
3693 Last := Index_Type'First;
3697 Elements.EA (Last) := new Element_Type'(New_Item);
3698 exit when Last = Elements.Last;
3704 for J in Index_Type'First .. Last - 1 loop
3705 Free (Elements.EA (J));
3712 return (Controlled with Elements, Last, 0, 0);
3715 --------------------
3716 -- Update_Element --
3717 --------------------
3719 procedure Update_Element
3720 (Container : in out Vector;
3722 Process : not null access procedure (Element : in out Element_Type))
3724 B : Natural renames Container.Busy;
3725 L : Natural renames Container.Lock;
3728 if Index > Container.Last then
3729 raise Constraint_Error with "Index is out of range";
3732 if Container.Elements.EA (Index) = null then
3733 raise Constraint_Error with "element is null";
3740 Process (Container.Elements.EA (Index).all);
3752 procedure Update_Element
3753 (Container : in out Vector;
3755 Process : not null access procedure (Element : in out Element_Type))
3758 if Position.Container = null then
3759 raise Constraint_Error with "Position cursor has no element";
3762 if Position.Container /= Container'Unrestricted_Access then
3763 raise Program_Error with "Position cursor denotes wrong container";
3766 Update_Element (Container, Position.Index, Process);
3774 (Stream : not null access Root_Stream_Type'Class;
3777 N : constant Count_Type := Length (Container);
3780 Count_Type'Base'Write (Stream, N);
3787 E : Elements_Array renames Container.Elements.EA;
3790 for Indx in Index_Type'First .. Container.Last loop
3791 if E (Indx) = null then
3792 Boolean'Write (Stream, False);
3794 Boolean'Write (Stream, True);
3795 Element_Type'Output (Stream, E (Indx).all);
3802 (Stream : not null access Root_Stream_Type'Class;
3806 raise Program_Error with "attempt to stream vector cursor";
3810 (Stream : not null access Root_Stream_Type'Class;
3811 Item : Reference_Type)
3814 raise Program_Error with "attempt to stream reference";
3818 (Stream : not null access Root_Stream_Type'Class;
3819 Item : Constant_Reference_Type)
3822 raise Program_Error with "attempt to stream reference";
3825 end Ada.Containers.Indefinite_Vectors;