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-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Containers.Generic_Array_Sort;
31 with Ada.Unchecked_Deallocation;
33 with System; use type System.Address;
35 package body Ada.Containers.Indefinite_Vectors is
38 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
41 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
43 type Iterator is new Limited_Controlled and
44 Vector_Iterator_Interfaces.Reversible_Iterator with
46 Container : Vector_Access;
47 Index : Index_Type'Base;
50 overriding procedure Finalize (Object : in out Iterator);
52 overriding function First (Object : Iterator) return Cursor;
53 overriding function Last (Object : Iterator) return Cursor;
55 overriding function Next
57 Position : Cursor) return Cursor;
59 overriding function Previous
61 Position : Cursor) return Cursor;
67 function "&" (Left, Right : Vector) return Vector is
68 LN : constant Count_Type := Length (Left);
69 RN : constant Count_Type := Length (Right);
70 N : Count_Type'Base; -- length of result
71 J : Count_Type'Base; -- for computing intermediate values
72 Last : Index_Type'Base; -- Last index of result
75 -- We decide that the capacity of the result is the sum of the lengths
76 -- of the vector parameters. We could decide to make it larger, but we
77 -- have no basis for knowing how much larger, so we just allocate the
78 -- minimum amount of storage.
80 -- Here we handle the easy cases first, when one of the vector
81 -- parameters is empty. (We say "easy" because there's nothing to
82 -- compute, that can potentially overflow.)
90 RE : Elements_Array renames
91 Right.Elements.EA (Index_Type'First .. Right.Last);
93 Elements : Elements_Access :=
94 new Elements_Type (Right.Last);
97 -- Elements of an indefinite vector are allocated, so we cannot
98 -- use simple slice assignment to give a value to our result.
99 -- Hence we must walk the array of the Right vector, and copy
100 -- each source element individually.
102 for I in Elements.EA'Range loop
104 if RE (I) /= null then
105 Elements.EA (I) := new Element_Type'(RE (I).all);
110 for J in Index_Type'First .. I - 1 loop
111 Free (Elements.EA (J));
119 return (Controlled with Elements, Right.Last, 0, 0);
126 LE : Elements_Array renames
127 Left.Elements.EA (Index_Type'First .. Left.Last);
129 Elements : Elements_Access :=
130 new Elements_Type (Left.Last);
133 -- Elements of an indefinite vector are allocated, so we cannot
134 -- use simple slice assignment to give a value to our result.
135 -- Hence we must walk the array of the Left vector, and copy
136 -- each source element individually.
138 for I in Elements.EA'Range loop
140 if LE (I) /= null then
141 Elements.EA (I) := new Element_Type'(LE (I).all);
146 for J in Index_Type'First .. I - 1 loop
147 Free (Elements.EA (J));
155 return (Controlled with Elements, Left.Last, 0, 0);
159 -- Neither of the vector parameters is empty, so we must compute the
160 -- length of the result vector and its last index. (This is the harder
161 -- case, because our computations must avoid overflow.)
163 -- There are two constraints we need to satisfy. The first constraint is
164 -- that a container cannot have more than Count_Type'Last elements, so
165 -- we must check the sum of the combined lengths. Note that we cannot
166 -- simply add the lengths, because of the possibility of overflow.
168 if LN > Count_Type'Last - RN then
169 raise Constraint_Error with "new length is out of range";
172 -- It is now safe compute the length of the new vector.
176 -- The second constraint is that the new Last index value cannot
177 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
178 -- Count_Type'Base as the type for intermediate values.
180 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
182 -- We perform a two-part test. First we determine whether the
183 -- computed Last value lies in the base range of the type, and then
184 -- determine whether it lies in the range of the index (sub)type.
186 -- Last must satisfy this relation:
187 -- First + Length - 1 <= Last
189 -- First - 1 <= Last - Length
190 -- Which can rewrite as:
191 -- No_Index <= Last - Length
193 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
194 raise Constraint_Error with "new length is out of range";
197 -- We now know that the computed value of Last is within the base
198 -- range of the type, so it is safe to compute its value:
200 Last := No_Index + Index_Type'Base (N);
202 -- Finally we test whether the value is within the range of the
203 -- generic actual index subtype:
205 if Last > Index_Type'Last then
206 raise Constraint_Error with "new length is out of range";
209 elsif Index_Type'First <= 0 then
211 -- Here we can compute Last directly, in the normal way. We know that
212 -- No_Index is less than 0, so there is no danger of overflow when
213 -- adding the (positive) value of length.
215 J := Count_Type'Base (No_Index) + N; -- Last
217 if J > Count_Type'Base (Index_Type'Last) then
218 raise Constraint_Error with "new length is out of range";
221 -- We know that the computed value (having type Count_Type) of Last
222 -- is within the range of the generic actual index subtype, so it is
223 -- safe to convert to Index_Type:
225 Last := Index_Type'Base (J);
228 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
229 -- must test the length indirectly (by working backwards from the
230 -- largest possible value of Last), in order to prevent overflow.
232 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
234 if J < Count_Type'Base (No_Index) then
235 raise Constraint_Error with "new length is out of range";
238 -- We have determined that the result length would not create a Last
239 -- index value outside of the range of Index_Type, so we can now
240 -- safely compute its value.
242 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
246 LE : Elements_Array renames
247 Left.Elements.EA (Index_Type'First .. Left.Last);
249 RE : Elements_Array renames
250 Right.Elements.EA (Index_Type'First .. Right.Last);
252 Elements : Elements_Access := new Elements_Type (Last);
254 I : Index_Type'Base := No_Index;
257 -- Elements of an indefinite vector are allocated, so we cannot use
258 -- simple slice assignment to give a value to our result. Hence we
259 -- must walk the array of each vector parameter, and copy each source
260 -- element individually.
262 for LI in LE'Range loop
266 if LE (LI) /= null then
267 Elements.EA (I) := new Element_Type'(LE (LI).all);
272 for J in Index_Type'First .. I - 1 loop
273 Free (Elements.EA (J));
281 for RI in RE'Range loop
285 if RE (RI) /= null then
286 Elements.EA (I) := new Element_Type'(RE (RI).all);
291 for J in Index_Type'First .. I - 1 loop
292 Free (Elements.EA (J));
300 return (Controlled with Elements, Last, 0, 0);
304 function "&" (Left : Vector; Right : Element_Type) return Vector is
306 -- We decide that the capacity of the result is the sum of the lengths
307 -- of the parameters. We could decide to make it larger, but we have no
308 -- basis for knowing how much larger, so we just allocate the minimum
309 -- amount of storage.
311 -- Here we handle the easy case first, when the vector parameter (Left)
314 if Left.Is_Empty then
316 Elements : Elements_Access := new Elements_Type (Index_Type'First);
320 Elements.EA (Index_Type'First) := new Element_Type'(Right);
327 return (Controlled with Elements, Index_Type'First, 0, 0);
331 -- The vector parameter is not empty, so we must compute the length of
332 -- the result vector and its last index, but in such a way that overflow
333 -- is avoided. We must satisfy two constraints: the new length cannot
334 -- exceed Count_Type'Last, and the new Last index cannot exceed
337 if Left.Length = Count_Type'Last then
338 raise Constraint_Error with "new length is out of range";
341 if Left.Last >= Index_Type'Last then
342 raise Constraint_Error with "new length is out of range";
346 Last : constant Index_Type := Left.Last + 1;
348 LE : Elements_Array renames
349 Left.Elements.EA (Index_Type'First .. Left.Last);
351 Elements : Elements_Access :=
352 new Elements_Type (Last);
355 for I in LE'Range loop
357 if LE (I) /= null then
358 Elements.EA (I) := new Element_Type'(LE (I).all);
363 for J in Index_Type'First .. I - 1 loop
364 Free (Elements.EA (J));
373 Elements.EA (Last) := new Element_Type'(Right);
377 for J in Index_Type'First .. Last - 1 loop
378 Free (Elements.EA (J));
385 return (Controlled with Elements, Last, 0, 0);
389 function "&" (Left : Element_Type; Right : Vector) return Vector is
391 -- We decide that the capacity of the result is the sum of the lengths
392 -- of the parameters. We could decide to make it larger, but we have no
393 -- basis for knowing how much larger, so we just allocate the minimum
394 -- amount of storage.
396 -- Here we handle the easy case first, when the vector parameter (Right)
399 if Right.Is_Empty then
401 Elements : Elements_Access := new Elements_Type (Index_Type'First);
405 Elements.EA (Index_Type'First) := new Element_Type'(Left);
412 return (Controlled with Elements, Index_Type'First, 0, 0);
416 -- The vector parameter is not empty, so we must compute the length of
417 -- the result vector and its last index, but in such a way that overflow
418 -- is avoided. We must satisfy two constraints: the new length cannot
419 -- exceed Count_Type'Last, and the new Last index cannot exceed
422 if Right.Length = Count_Type'Last then
423 raise Constraint_Error with "new length is out of range";
426 if Right.Last >= Index_Type'Last then
427 raise Constraint_Error with "new length is out of range";
431 Last : constant Index_Type := Right.Last + 1;
433 RE : Elements_Array renames
434 Right.Elements.EA (Index_Type'First .. Right.Last);
436 Elements : Elements_Access :=
437 new Elements_Type (Last);
439 I : Index_Type'Base := Index_Type'First;
443 Elements.EA (I) := new Element_Type'(Left);
450 for RI in RE'Range loop
454 if RE (RI) /= null then
455 Elements.EA (I) := new Element_Type'(RE (RI).all);
460 for J in Index_Type'First .. I - 1 loop
461 Free (Elements.EA (J));
469 return (Controlled with Elements, Last, 0, 0);
473 function "&" (Left, Right : Element_Type) return Vector is
475 -- We decide that the capacity of the result is the sum of the lengths
476 -- of the parameters. We could decide to make it larger, but we have no
477 -- basis for knowing how much larger, so we just allocate the minimum
478 -- amount of storage.
480 -- We must compute the length of the result vector and its last index,
481 -- but in such a way that overflow is avoided. We must satisfy two
482 -- constraints: the new length cannot exceed Count_Type'Last (here, we
483 -- know that that condition is satisfied), and the new Last index cannot
484 -- exceed Index_Type'Last.
486 if Index_Type'First >= Index_Type'Last then
487 raise Constraint_Error with "new length is out of range";
491 Last : constant Index_Type := Index_Type'First + 1;
492 Elements : Elements_Access := new Elements_Type (Last);
496 Elements.EA (Index_Type'First) := new Element_Type'(Left);
504 Elements.EA (Last) := new Element_Type'(Right);
507 Free (Elements.EA (Index_Type'First));
512 return (Controlled with Elements, Last, 0, 0);
520 overriding function "=" (Left, Right : Vector) return Boolean is
522 if Left'Address = Right'Address then
526 if Left.Last /= Right.Last then
530 for J in Index_Type'First .. Left.Last loop
531 if Left.Elements.EA (J) = null then
532 if Right.Elements.EA (J) /= null then
536 elsif Right.Elements.EA (J) = null then
539 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
551 procedure Adjust (Container : in out Vector) is
553 if Container.Last = No_Index then
554 Container.Elements := null;
559 L : constant Index_Type := Container.Last;
560 E : Elements_Array renames
561 Container.Elements.EA (Index_Type'First .. L);
564 Container.Elements := null;
565 Container.Last := No_Index;
569 Container.Elements := new Elements_Type (L);
571 for I in E'Range loop
572 if E (I) /= null then
573 Container.Elements.EA (I) := new Element_Type'(E (I).all);
585 procedure Append (Container : in out Vector; New_Item : Vector) is
587 if Is_Empty (New_Item) then
591 if Container.Last = Index_Type'Last then
592 raise Constraint_Error with "vector is already at its maximum length";
602 (Container : in out Vector;
603 New_Item : Element_Type;
604 Count : Count_Type := 1)
611 if Container.Last = Index_Type'Last then
612 raise Constraint_Error with "vector is already at its maximum length";
626 procedure Assign (Target : in out Vector; Source : Vector) is
628 if Target'Address = Source'Address then
633 Target.Append (Source);
640 function Capacity (Container : Vector) return Count_Type is
642 if Container.Elements = null then
646 return Container.Elements.EA'Length;
653 procedure Clear (Container : in out Vector) is
655 if Container.Busy > 0 then
656 raise Program_Error with
657 "attempt to tamper with cursors (vector is busy)";
660 while Container.Last >= Index_Type'First loop
662 X : Element_Access := Container.Elements.EA (Container.Last);
664 Container.Elements.EA (Container.Last) := null;
665 Container.Last := Container.Last - 1;
671 ------------------------
672 -- Constant_Reference --
673 ------------------------
675 function Constant_Reference
676 (Container : aliased Vector;
677 Position : Cursor) return Constant_Reference_Type
682 if Position.Container = null then
683 raise Constraint_Error with "Position cursor has no element";
686 if Position.Container /= Container'Unrestricted_Access then
687 raise Program_Error with "Position cursor denotes wrong container";
690 if Position.Index > Position.Container.Last then
691 raise Constraint_Error with "Position cursor is out of range";
694 E := Container.Elements.EA (Position.Index);
697 raise Constraint_Error with "element at Position is empty";
700 return (Element => E.all'Access);
701 end Constant_Reference;
703 function Constant_Reference
704 (Container : aliased Vector;
705 Index : Index_Type) return Constant_Reference_Type
710 if Index > Container.Last then
711 raise Constraint_Error with "Index is out of range";
714 E := Container.Elements.EA (Index);
717 raise Constraint_Error with "element at Index is empty";
720 return (Element => E.all'Access);
721 end Constant_Reference;
729 Item : Element_Type) return Boolean
732 return Find_Index (Container, Item) /= No_Index;
741 Capacity : Count_Type := 0) return Vector
749 elsif Capacity >= Source.Length then
754 with "Requested capacity is less than Source length";
757 return Target : Vector do
758 Target.Reserve_Capacity (C);
759 Target.Assign (Source);
768 (Container : in out Vector;
769 Index : Extended_Index;
770 Count : Count_Type := 1)
772 Old_Last : constant Index_Type'Base := Container.Last;
773 New_Last : Index_Type'Base;
774 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
775 J : Index_Type'Base; -- first index of items that slide down
778 -- Delete removes items from the vector, the number of which is the
779 -- minimum of the specified Count and the items (if any) that exist from
780 -- Index to Container.Last. There are no constraints on the specified
781 -- value of Count (it can be larger than what's available at this
782 -- position in the vector, for example), but there are constraints on
783 -- the allowed values of the Index.
785 -- As a precondition on the generic actual Index_Type, the base type
786 -- must include Index_Type'Pred (Index_Type'First); this is the value
787 -- that Container.Last assumes when the vector is empty. However, we do
788 -- not allow that as the value for Index when specifying which items
789 -- should be deleted, so we must manually check. (That the user is
790 -- allowed to specify the value at all here is a consequence of the
791 -- declaration of the Extended_Index subtype, which includes the values
792 -- in the base range that immediately precede and immediately follow the
793 -- values in the Index_Type.)
795 if Index < Index_Type'First then
796 raise Constraint_Error with "Index is out of range (too small)";
799 -- We do allow a value greater than Container.Last to be specified as
800 -- the Index, but only if it's immediately greater. This allows the
801 -- corner case of deleting no items from the back end of the vector to
802 -- be treated as a no-op. (It is assumed that specifying an index value
803 -- greater than Last + 1 indicates some deeper flaw in the caller's
804 -- algorithm, so that case is treated as a proper error.)
806 if Index > Old_Last then
807 if Index > Old_Last + 1 then
808 raise Constraint_Error with "Index is out of range (too large)";
814 -- Here and elsewhere we treat deleting 0 items from the container as a
815 -- no-op, even when the container is busy, so we simply return.
821 -- The internal elements array isn't guaranteed to exist unless we have
822 -- elements, so we handle that case here in order to avoid having to
823 -- check it later. (Note that an empty vector can never be busy, so
824 -- there's no semantic harm in returning early.)
826 if Container.Is_Empty then
830 -- The tampering bits exist to prevent an item from being deleted (or
831 -- otherwise harmfully manipulated) while it is being visited. Query,
832 -- Update, and Iterate increment the busy count on entry, and decrement
833 -- the count on exit. Delete checks the count to determine whether it is
834 -- being called while the associated callback procedure is executing.
836 if Container.Busy > 0 then
837 raise Program_Error with
838 "attempt to tamper with cursors (vector is busy)";
841 -- We first calculate what's available for deletion starting at
842 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
843 -- Count_Type'Base as the type for intermediate values. (See function
844 -- Length for more information.)
846 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
847 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
850 Count2 := Count_Type'Base (Old_Last - Index + 1);
853 -- If the number of elements requested (Count) for deletion is equal to
854 -- (or greater than) the number of elements available (Count2) for
855 -- deletion beginning at Index, then everything from Index to
856 -- Container.Last is deleted (this is equivalent to Delete_Last).
858 if Count >= Count2 then
859 -- Elements in an indefinite vector are allocated, so we must iterate
860 -- over the loop and deallocate elements one-at-a-time. We work from
861 -- back to front, deleting the last element during each pass, in
862 -- order to gracefully handle deallocation failures.
865 EA : Elements_Array renames Container.Elements.EA;
868 while Container.Last >= Index loop
870 K : constant Index_Type := Container.Last;
871 X : Element_Access := EA (K);
874 -- We first isolate the element we're deleting, removing it
875 -- from the vector before we attempt to deallocate it, in
876 -- case the deallocation fails.
879 Container.Last := K - 1;
881 -- Container invariants have been restored, so it is now
882 -- safe to attempt to deallocate the element.
892 -- There are some elements that aren't being deleted (the requested
893 -- count was less than the available count), so we must slide them down
894 -- to Index. We first calculate the index values of the respective array
895 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
896 -- type for intermediate calculations. For the elements that slide down,
897 -- index value New_Last is the last index value of their new home, and
898 -- index value J is the first index of their old home.
900 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
901 New_Last := Old_Last - Index_Type'Base (Count);
902 J := Index + Index_Type'Base (Count);
905 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
906 J := Index_Type'Base (Count_Type'Base (Index) + Count);
909 -- The internal elements array isn't guaranteed to exist unless we have
910 -- elements, but we have that guarantee here because we know we have
911 -- elements to slide. The array index values for each slice have
912 -- already been determined, so what remains to be done is to first
913 -- deallocate the elements that are being deleted, and then slide down
914 -- to Index the elements that aren't being deleted.
917 EA : Elements_Array renames Container.Elements.EA;
920 -- Before we can slide down the elements that aren't being deleted,
921 -- we need to deallocate the elements that are being deleted.
923 for K in Index .. J - 1 loop
925 X : Element_Access := EA (K);
928 -- First we remove the element we're about to deallocate from
929 -- the vector, in case the deallocation fails, in order to
930 -- preserve representation invariants.
934 -- The element has been removed from the vector, so it is now
935 -- safe to attempt to deallocate it.
941 EA (Index .. New_Last) := EA (J .. Old_Last);
942 Container.Last := New_Last;
947 (Container : in out Vector;
948 Position : in out Cursor;
949 Count : Count_Type := 1)
951 pragma Warnings (Off, Position);
954 if Position.Container = null then
955 raise Constraint_Error with "Position cursor has no element";
958 if Position.Container /= Container'Unrestricted_Access then
959 raise Program_Error with "Position cursor denotes wrong container";
962 if Position.Index > Container.Last then
963 raise Program_Error with "Position index is out of range";
966 Delete (Container, Position.Index, Count);
968 Position := No_Element;
975 procedure Delete_First
976 (Container : in out Vector;
977 Count : Count_Type := 1)
984 if Count >= Length (Container) then
989 Delete (Container, Index_Type'First, Count);
996 procedure Delete_Last
997 (Container : in out Vector;
998 Count : Count_Type := 1)
1001 -- It is not permitted to delete items while the container is busy (for
1002 -- example, we're in the middle of a passive iteration). However, we
1003 -- always treat deleting 0 items as a no-op, even when we're busy, so we
1004 -- simply return without checking.
1010 -- We cannot simply subsume the empty case into the loop below (the loop
1011 -- would iterate 0 times), because we rename the internal array object
1012 -- (which is allocated), but an empty vector isn't guaranteed to have
1013 -- actually allocated an array. (Note that an empty vector can never be
1014 -- busy, so there's no semantic harm in returning early here.)
1016 if Container.Is_Empty then
1020 -- The tampering bits exist to prevent an item from being deleted (or
1021 -- otherwise harmfully manipulated) while it is being visited. Query,
1022 -- Update, and Iterate increment the busy count on entry, and decrement
1023 -- the count on exit. Delete_Last checks the count to determine whether
1024 -- it is being called while the associated callback procedure is
1027 if Container.Busy > 0 then
1028 raise Program_Error with
1029 "attempt to tamper with cursors (vector is busy)";
1032 -- Elements in an indefinite vector are allocated, so we must iterate
1033 -- over the loop and deallocate elements one-at-a-time. We work from
1034 -- back to front, deleting the last element during each pass, in order
1035 -- to gracefully handle deallocation failures.
1038 E : Elements_Array renames Container.Elements.EA;
1041 for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop
1043 J : constant Index_Type := Container.Last;
1044 X : Element_Access := E (J);
1047 -- Note that we first isolate the element we're deleting,
1048 -- removing it from the vector, before we actually deallocate
1049 -- it, in order to preserve representation invariants even if
1050 -- the deallocation fails.
1053 Container.Last := J - 1;
1055 -- Container invariants have been restored, so it is now safe
1056 -- to deallocate the element.
1069 (Container : Vector;
1070 Index : Index_Type) return Element_Type
1073 if Index > Container.Last then
1074 raise Constraint_Error with "Index is out of range";
1078 EA : constant Element_Access := Container.Elements.EA (Index);
1082 raise Constraint_Error with "element is empty";
1089 function Element (Position : Cursor) return Element_Type is
1091 if Position.Container = null then
1092 raise Constraint_Error with "Position cursor has no element";
1095 if Position.Index > Position.Container.Last then
1096 raise Constraint_Error with "Position cursor is out of range";
1100 EA : constant Element_Access :=
1101 Position.Container.Elements.EA (Position.Index);
1105 raise Constraint_Error with "element is empty";
1116 procedure Finalize (Container : in out Vector) is
1118 Clear (Container); -- Checks busy-bit
1121 X : Elements_Access := Container.Elements;
1123 Container.Elements := null;
1128 procedure Finalize (Object : in out Iterator) is
1129 B : Natural renames Object.Container.Busy;
1139 (Container : Vector;
1140 Item : Element_Type;
1141 Position : Cursor := No_Element) return Cursor
1144 if Position.Container /= null then
1145 if Position.Container /= Container'Unrestricted_Access then
1146 raise Program_Error with "Position cursor denotes wrong container";
1149 if Position.Index > Container.Last then
1150 raise Program_Error with "Position index is out of range";
1154 for J in Position.Index .. Container.Last loop
1155 if Container.Elements.EA (J) /= null
1156 and then Container.Elements.EA (J).all = Item
1158 return (Container'Unrestricted_Access, J);
1170 (Container : Vector;
1171 Item : Element_Type;
1172 Index : Index_Type := Index_Type'First) return Extended_Index
1175 for Indx in Index .. Container.Last loop
1176 if Container.Elements.EA (Indx) /= null
1177 and then Container.Elements.EA (Indx).all = Item
1190 function First (Container : Vector) return Cursor is
1192 if Is_Empty (Container) then
1196 return (Container'Unrestricted_Access, Index_Type'First);
1199 function First (Object : Iterator) return Cursor is
1201 -- The value of the iterator object's Index component influences the
1202 -- behavior of the First (and Last) selector function.
1204 -- When the Index component is No_Index, this means the iterator
1205 -- object was constructed without a start expression, in which case the
1206 -- (forward) iteration starts from the (logical) beginning of the entire
1207 -- sequence of items (corresponding to Container.First, for a forward
1210 -- Otherwise, this is iteration over a partial sequence of items.
1211 -- When the Index component isn't No_Index, the iterator object was
1212 -- constructed with a start expression, that specifies the position
1213 -- from which the (forward) partial iteration begins.
1215 if Object.Index = No_Index then
1216 return First (Object.Container.all);
1218 return Cursor'(Object.Container, Object.Index);
1226 function First_Element (Container : Vector) return Element_Type is
1228 if Container.Last = No_Index then
1229 raise Constraint_Error with "Container is empty";
1233 EA : constant Element_Access :=
1234 Container.Elements.EA (Index_Type'First);
1238 raise Constraint_Error with "first element is empty";
1249 function First_Index (Container : Vector) return Index_Type is
1250 pragma Unreferenced (Container);
1252 return Index_Type'First;
1255 ---------------------
1256 -- Generic_Sorting --
1257 ---------------------
1259 package body Generic_Sorting is
1261 -----------------------
1262 -- Local Subprograms --
1263 -----------------------
1265 function Is_Less (L, R : Element_Access) return Boolean;
1266 pragma Inline (Is_Less);
1272 function Is_Less (L, R : Element_Access) return Boolean is
1279 return L.all < R.all;
1287 function Is_Sorted (Container : Vector) return Boolean is
1289 if Container.Last <= Index_Type'First then
1294 E : Elements_Array renames Container.Elements.EA;
1296 for I in Index_Type'First .. Container.Last - 1 loop
1297 if Is_Less (E (I + 1), E (I)) then
1310 procedure Merge (Target, Source : in out Vector) is
1311 I, J : Index_Type'Base;
1315 -- The semantics of Merge changed slightly per AI05-0021. It was
1316 -- originally the case that if Target and Source denoted the same
1317 -- container object, then the GNAT implementation of Merge did
1318 -- nothing. However, it was argued that RM05 did not precisely
1319 -- specify the semantics for this corner case. The decision of the
1320 -- ARG was that if Target and Source denote the same non-empty
1321 -- container object, then Program_Error is raised.
1323 if Source.Last < Index_Type'First then -- Source is empty
1327 if Target'Address = Source'Address then
1328 raise Program_Error with
1329 "Target and Source denote same non-empty container";
1332 if Target.Last < Index_Type'First then -- Target is empty
1333 Move (Target => Target, Source => Source);
1337 if Source.Busy > 0 then
1338 raise Program_Error with
1339 "attempt to tamper with cursors (vector is busy)";
1342 I := Target.Last; -- original value (before Set_Length)
1343 Target.Set_Length (Length (Target) + Length (Source));
1345 J := Target.Last; -- new value (after Set_Length)
1346 while Source.Last >= Index_Type'First loop
1348 (Source.Last <= Index_Type'First
1349 or else not (Is_Less
1350 (Source.Elements.EA (Source.Last),
1351 Source.Elements.EA (Source.Last - 1))));
1353 if I < Index_Type'First then
1355 Src : Elements_Array renames
1356 Source.Elements.EA (Index_Type'First .. Source.Last);
1359 Target.Elements.EA (Index_Type'First .. J) := Src;
1360 Src := (others => null);
1363 Source.Last := No_Index;
1368 (I <= Index_Type'First
1369 or else not (Is_Less
1370 (Target.Elements.EA (I),
1371 Target.Elements.EA (I - 1))));
1374 Src : Element_Access renames Source.Elements.EA (Source.Last);
1375 Tgt : Element_Access renames Target.Elements.EA (I);
1378 if Is_Less (Src, Tgt) then
1379 Target.Elements.EA (J) := Tgt;
1384 Target.Elements.EA (J) := Src;
1386 Source.Last := Source.Last - 1;
1398 procedure Sort (Container : in out Vector) is
1399 procedure Sort is new Generic_Array_Sort
1400 (Index_Type => Index_Type,
1401 Element_Type => Element_Access,
1402 Array_Type => Elements_Array,
1406 if Container.Last <= Index_Type'First then
1410 -- The exception behavior for the vector container must match that
1411 -- for the list container, so we check for cursor tampering here
1412 -- (which will catch more things) instead of for element tampering
1413 -- (which will catch fewer things). It's true that the elements of
1414 -- this vector container could be safely moved around while (say) an
1415 -- iteration is taking place (iteration only increments the busy
1416 -- counter), and so technically all we would need here is a test for
1417 -- element tampering (indicated by the lock counter), that's simply
1418 -- an artifact of our array-based implementation. Logically Sort
1419 -- requires a check for cursor tampering.
1421 if Container.Busy > 0 then
1422 raise Program_Error with
1423 "attempt to tamper with cursors (vector is busy)";
1426 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1429 end Generic_Sorting;
1435 function Has_Element (Position : Cursor) return Boolean is
1437 if Position.Container = null then
1441 return Position.Index <= Position.Container.Last;
1449 (Container : in out Vector;
1450 Before : Extended_Index;
1451 New_Item : Element_Type;
1452 Count : Count_Type := 1)
1454 Old_Length : constant Count_Type := Container.Length;
1456 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1457 New_Length : Count_Type'Base; -- sum of current length and Count
1458 New_Last : Index_Type'Base; -- last index of vector after insertion
1460 Index : Index_Type'Base; -- scratch for intermediate values
1461 J : Count_Type'Base; -- scratch
1463 New_Capacity : Count_Type'Base; -- length of new, expanded array
1464 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1465 Dst : Elements_Access; -- new, expanded internal array
1468 -- As a precondition on the generic actual Index_Type, the base type
1469 -- must include Index_Type'Pred (Index_Type'First); this is the value
1470 -- that Container.Last assumes when the vector is empty. However, we do
1471 -- not allow that as the value for Index when specifying where the new
1472 -- items should be inserted, so we must manually check. (That the user
1473 -- is allowed to specify the value at all here is a consequence of the
1474 -- declaration of the Extended_Index subtype, which includes the values
1475 -- in the base range that immediately precede and immediately follow the
1476 -- values in the Index_Type.)
1478 if Before < Index_Type'First then
1479 raise Constraint_Error with
1480 "Before index is out of range (too small)";
1483 -- We do allow a value greater than Container.Last to be specified as
1484 -- the Index, but only if it's immediately greater. This allows for the
1485 -- case of appending items to the back end of the vector. (It is assumed
1486 -- that specifying an index value greater than Last + 1 indicates some
1487 -- deeper flaw in the caller's algorithm, so that case is treated as a
1490 if Before > Container.Last
1491 and then Before > Container.Last + 1
1493 raise Constraint_Error with
1494 "Before index is out of range (too large)";
1497 -- We treat inserting 0 items into the container as a no-op, even when
1498 -- the container is busy, so we simply return.
1504 -- There are two constraints we need to satisfy. The first constraint is
1505 -- that a container cannot have more than Count_Type'Last elements, so
1506 -- we must check the sum of the current length and the insertion count.
1507 -- Note that we cannot simply add these values, because of the
1508 -- possibility of overflow.
1510 if Old_Length > Count_Type'Last - Count then
1511 raise Constraint_Error with "Count is out of range";
1514 -- It is now safe compute the length of the new vector, without fear of
1517 New_Length := Old_Length + Count;
1519 -- The second constraint is that the new Last index value cannot exceed
1520 -- Index_Type'Last. In each branch below, we calculate the maximum
1521 -- length (computed from the range of values in Index_Type), and then
1522 -- compare the new length to the maximum length. If the new length is
1523 -- acceptable, then we compute the new last index from that.
1525 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1527 -- We have to handle the case when there might be more values in the
1528 -- range of Index_Type than in the range of Count_Type.
1530 if Index_Type'First <= 0 then
1532 -- We know that No_Index (the same as Index_Type'First - 1) is
1533 -- less than 0, so it is safe to compute the following sum without
1534 -- fear of overflow.
1536 Index := No_Index + Index_Type'Base (Count_Type'Last);
1538 if Index <= Index_Type'Last then
1540 -- We have determined that range of Index_Type has at least as
1541 -- many values as in Count_Type, so Count_Type'Last is the
1542 -- maximum number of items that are allowed.
1544 Max_Length := Count_Type'Last;
1547 -- The range of Index_Type has fewer values than in Count_Type,
1548 -- so the maximum number of items is computed from the range of
1551 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1555 -- No_Index is equal or greater than 0, so we can safely compute
1556 -- the difference without fear of overflow (which we would have to
1557 -- worry about if No_Index were less than 0, but that case is
1560 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1563 elsif Index_Type'First <= 0 then
1565 -- We know that No_Index (the same as Index_Type'First - 1) is less
1566 -- than 0, so it is safe to compute the following sum without fear of
1569 J := Count_Type'Base (No_Index) + Count_Type'Last;
1571 if J <= Count_Type'Base (Index_Type'Last) then
1573 -- We have determined that range of Index_Type has at least as
1574 -- many values as in Count_Type, so Count_Type'Last is the maximum
1575 -- number of items that are allowed.
1577 Max_Length := Count_Type'Last;
1580 -- The range of Index_Type has fewer values than Count_Type does,
1581 -- so the maximum number of items is computed from the range of
1585 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1589 -- No_Index is equal or greater than 0, so we can safely compute the
1590 -- difference without fear of overflow (which we would have to worry
1591 -- about if No_Index were less than 0, but that case is handled
1595 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1598 -- We have just computed the maximum length (number of items). We must
1599 -- now compare the requested length to the maximum length, as we do not
1600 -- allow a vector expand beyond the maximum (because that would create
1601 -- an internal array with a last index value greater than
1602 -- Index_Type'Last, with no way to index those elements).
1604 if New_Length > Max_Length then
1605 raise Constraint_Error with "Count is out of range";
1608 -- New_Last is the last index value of the items in the container after
1609 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1610 -- compute its value from the New_Length.
1612 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1613 New_Last := No_Index + Index_Type'Base (New_Length);
1616 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1619 if Container.Elements = null then
1620 pragma Assert (Container.Last = No_Index);
1622 -- This is the simplest case, with which we must always begin: we're
1623 -- inserting items into an empty vector that hasn't allocated an
1624 -- internal array yet. Note that we don't need to check the busy bit
1625 -- here, because an empty container cannot be busy.
1627 -- In an indefinite vector, elements are allocated individually, and
1628 -- stored as access values on the internal array (the length of which
1629 -- represents the vector "capacity"), which is separately allocated.
1631 Container.Elements := new Elements_Type (New_Last);
1633 -- The element backbone has been successfully allocated, so now we
1634 -- allocate the elements.
1636 for Idx in Container.Elements.EA'Range loop
1638 -- In order to preserve container invariants, we always attempt
1639 -- the element allocation first, before setting the Last index
1640 -- value, in case the allocation fails (either because there is no
1641 -- storage available, or because element initialization fails).
1643 Container.Elements.EA (Idx) := new Element_Type'(New_Item);
1645 -- The allocation of the element succeeded, so it is now safe to
1646 -- update the Last index, restoring container invariants.
1648 Container.Last := Idx;
1654 -- The tampering bits exist to prevent an item from being harmfully
1655 -- manipulated while it is being visited. Query, Update, and Iterate
1656 -- increment the busy count on entry, and decrement the count on
1657 -- exit. Insert checks the count to determine whether it is being called
1658 -- while the associated callback procedure is executing.
1660 if Container.Busy > 0 then
1661 raise Program_Error with
1662 "attempt to tamper with cursors (vector is busy)";
1665 if New_Length <= Container.Elements.EA'Length then
1667 -- In this case, we're inserting elements into a vector that has
1668 -- already allocated an internal array, and the existing array has
1669 -- enough unused storage for the new items.
1672 E : Elements_Array renames Container.Elements.EA;
1673 K : Index_Type'Base;
1676 if Before > Container.Last then
1678 -- The new items are being appended to the vector, so no
1679 -- sliding of existing elements is required.
1681 for Idx in Before .. New_Last loop
1683 -- In order to preserve container invariants, we always
1684 -- attempt the element allocation first, before setting the
1685 -- Last index value, in case the allocation fails (either
1686 -- because there is no storage available, or because element
1687 -- initialization fails).
1689 E (Idx) := new Element_Type'(New_Item);
1691 -- The allocation of the element succeeded, so it is now
1692 -- safe to update the Last index, restoring container
1695 Container.Last := Idx;
1699 -- The new items are being inserted before some existing
1700 -- elements, so we must slide the existing elements up to their
1701 -- new home. We use the wider of Index_Type'Base and
1702 -- Count_Type'Base as the type for intermediate index values.
1704 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1705 Index := Before + Index_Type'Base (Count);
1707 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1710 -- The new items are being inserted in the middle of the array,
1711 -- in the range [Before, Index). Copy the existing elements to
1712 -- the end of the array, to make room for the new items.
1714 E (Index .. New_Last) := E (Before .. Container.Last);
1715 Container.Last := New_Last;
1717 -- We have copied the existing items up to the end of the
1718 -- array, to make room for the new items in the middle of
1719 -- the array. Now we actually allocate the new items.
1721 -- Note: initialize K outside loop to make it clear that
1722 -- K always has a value if the exception handler triggers.
1726 while K < Index loop
1727 E (K) := new Element_Type'(New_Item);
1734 -- Values in the range [Before, K) were successfully
1735 -- allocated, but values in the range [K, Index) are
1736 -- stale (these array positions contain copies of the
1737 -- old items, that did not get assigned a new item,
1738 -- because the allocation failed). We must finish what
1739 -- we started by clearing out all of the stale values,
1740 -- leaving a "hole" in the middle of the array.
1742 E (K .. Index - 1) := (others => null);
1751 -- In this case, we're inserting elements into a vector that has already
1752 -- allocated an internal array, but the existing array does not have
1753 -- enough storage, so we must allocate a new, longer array. In order to
1754 -- guarantee that the amortized insertion cost is O(1), we always
1755 -- allocate an array whose length is some power-of-two factor of the
1756 -- current array length. (The new array cannot have a length less than
1757 -- the New_Length of the container, but its last index value cannot be
1758 -- greater than Index_Type'Last.)
1760 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1761 while New_Capacity < New_Length loop
1762 if New_Capacity > Count_Type'Last / 2 then
1763 New_Capacity := Count_Type'Last;
1767 New_Capacity := 2 * New_Capacity;
1770 if New_Capacity > Max_Length then
1772 -- We have reached the limit of capacity, so no further expansion
1773 -- will occur. (This is not a problem, as there is never a need to
1774 -- have more capacity than the maximum container length.)
1776 New_Capacity := Max_Length;
1779 -- We have computed the length of the new internal array (and this is
1780 -- what "vector capacity" means), so use that to compute its last index.
1782 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1783 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1787 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1790 -- Now we allocate the new, longer internal array. If the allocation
1791 -- fails, we have not changed any container state, so no side-effect
1792 -- will occur as a result of propagating the exception.
1794 Dst := new Elements_Type (Dst_Last);
1796 -- We have our new internal array. All that needs to be done now is to
1797 -- copy the existing items (if any) from the old array (the "source"
1798 -- array) to the new array (the "destination" array), and then
1799 -- deallocate the old array.
1802 Src : Elements_Access := Container.Elements;
1805 Dst.EA (Index_Type'First .. Before - 1) :=
1806 Src.EA (Index_Type'First .. Before - 1);
1808 if Before > Container.Last then
1810 -- The new items are being appended to the vector, so no
1811 -- sliding of existing elements is required.
1813 -- We have copied the elements from to the old, source array to
1814 -- the new, destination array, so we can now deallocate the old
1817 Container.Elements := Dst;
1820 -- Now we append the new items.
1822 for Idx in Before .. New_Last loop
1824 -- In order to preserve container invariants, we always
1825 -- attempt the element allocation first, before setting the
1826 -- Last index value, in case the allocation fails (either
1827 -- because there is no storage available, or because element
1828 -- initialization fails).
1830 Dst.EA (Idx) := new Element_Type'(New_Item);
1832 -- The allocation of the element succeeded, so it is now safe
1833 -- to update the Last index, restoring container invariants.
1835 Container.Last := Idx;
1839 -- The new items are being inserted before some existing elements,
1840 -- so we must slide the existing elements up to their new home.
1842 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1843 Index := Before + Index_Type'Base (Count);
1846 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1849 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1851 -- We have copied the elements from to the old, source array to
1852 -- the new, destination array, so we can now deallocate the old
1855 Container.Elements := Dst;
1856 Container.Last := New_Last;
1859 -- The new array has a range in the middle containing null access
1860 -- values. We now fill in that partition of the array with the new
1863 for Idx in Before .. Index - 1 loop
1865 -- Note that container invariants have already been satisfied
1866 -- (in particular, the Last index value of the vector has
1867 -- already been updated), so if this allocation fails we simply
1868 -- let it propagate.
1870 Dst.EA (Idx) := new Element_Type'(New_Item);
1877 (Container : in out Vector;
1878 Before : Extended_Index;
1881 N : constant Count_Type := Length (New_Item);
1882 J : Index_Type'Base;
1885 -- Use Insert_Space to create the "hole" (the destination slice) into
1886 -- which we copy the source items.
1888 Insert_Space (Container, Before, Count => N);
1892 -- There's nothing else to do here (vetting of parameters was
1893 -- performed already in Insert_Space), so we simply return.
1898 if Container'Address /= New_Item'Address then
1900 -- This is the simple case. New_Item denotes an object different
1901 -- from Container, so there's nothing special we need to do to copy
1902 -- the source items to their destination, because all of the source
1903 -- items are contiguous.
1906 subtype Src_Index_Subtype is Index_Type'Base range
1907 Index_Type'First .. New_Item.Last;
1909 Src : Elements_Array renames
1910 New_Item.Elements.EA (Src_Index_Subtype);
1912 Dst : Elements_Array renames Container.Elements.EA;
1914 Dst_Index : Index_Type'Base;
1917 Dst_Index := Before - 1;
1918 for Src_Index in Src'Range loop
1919 Dst_Index := Dst_Index + 1;
1921 if Src (Src_Index) /= null then
1922 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1930 -- New_Item denotes the same object as Container, so an insertion has
1931 -- potentially split the source items. The first source slice is
1932 -- [Index_Type'First, Before), and the second source slice is
1933 -- [J, Container.Last], where index value J is the first index of the
1934 -- second slice. (J gets computed below, but only after we have
1935 -- determined that the second source slice is non-empty.) The
1936 -- destination slice is always the range [Before, J). We perform the
1937 -- copy in two steps, using each of the two slices of the source items.
1940 L : constant Index_Type'Base := Before - 1;
1942 subtype Src_Index_Subtype is Index_Type'Base range
1943 Index_Type'First .. L;
1945 Src : Elements_Array renames
1946 Container.Elements.EA (Src_Index_Subtype);
1948 Dst : Elements_Array renames Container.Elements.EA;
1950 Dst_Index : Index_Type'Base;
1953 -- We first copy the source items that precede the space we
1954 -- inserted. (If Before equals Index_Type'First, then this first
1955 -- source slice will be empty, which is harmless.)
1957 Dst_Index := Before - 1;
1958 for Src_Index in Src'Range loop
1959 Dst_Index := Dst_Index + 1;
1961 if Src (Src_Index) /= null then
1962 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1966 if Src'Length = N then
1968 -- The new items were effectively appended to the container, so we
1969 -- have already copied all of the items that need to be copied.
1970 -- We return early here, even though the source slice below is
1971 -- empty (so the assignment would be harmless), because we want to
1972 -- avoid computing J, which will overflow if J is greater than
1973 -- Index_Type'Base'Last.
1979 -- Index value J is the first index of the second source slice. (It is
1980 -- also 1 greater than the last index of the destination slice.) Note:
1981 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
1982 -- to avoid overflow. Prevent that by returning early above, immediately
1983 -- after copying the first slice of the source, and determining that
1984 -- this second slice of the source is empty.
1986 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1987 J := Before + Index_Type'Base (N);
1990 J := Index_Type'Base (Count_Type'Base (Before) + N);
1994 subtype Src_Index_Subtype is Index_Type'Base range
1995 J .. Container.Last;
1997 Src : Elements_Array renames
1998 Container.Elements.EA (Src_Index_Subtype);
2000 Dst : Elements_Array renames Container.Elements.EA;
2002 Dst_Index : Index_Type'Base;
2005 -- We next copy the source items that follow the space we inserted.
2006 -- Index value Dst_Index is the first index of that portion of the
2007 -- destination that receives this slice of the source. (For the
2008 -- reasons given above, this slice is guaranteed to be non-empty.)
2010 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2011 Dst_Index := J - Index_Type'Base (Src'Length);
2014 Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
2017 for Src_Index in Src'Range loop
2018 if Src (Src_Index) /= null then
2019 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
2022 Dst_Index := Dst_Index + 1;
2028 (Container : in out Vector;
2032 Index : Index_Type'Base;
2035 if Before.Container /= null
2036 and then Before.Container /= Container'Unrestricted_Access
2038 raise Program_Error with "Before cursor denotes wrong container";
2041 if Is_Empty (New_Item) then
2045 if Before.Container = null
2046 or else Before.Index > Container.Last
2048 if Container.Last = Index_Type'Last then
2049 raise Constraint_Error with
2050 "vector is already at its maximum length";
2053 Index := Container.Last + 1;
2056 Index := Before.Index;
2059 Insert (Container, Index, New_Item);
2063 (Container : in out Vector;
2066 Position : out Cursor)
2068 Index : Index_Type'Base;
2071 if Before.Container /= null
2072 and then Before.Container /=
2073 Vector_Access'(Container'Unrestricted_Access)
2075 raise Program_Error with "Before cursor denotes wrong container";
2078 if Is_Empty (New_Item) then
2079 if Before.Container = null
2080 or else Before.Index > Container.Last
2082 Position := No_Element;
2084 Position := (Container'Unrestricted_Access, Before.Index);
2090 if Before.Container = null
2091 or else Before.Index > Container.Last
2093 if Container.Last = Index_Type'Last then
2094 raise Constraint_Error with
2095 "vector is already at its maximum length";
2098 Index := Container.Last + 1;
2101 Index := Before.Index;
2104 Insert (Container, Index, New_Item);
2106 Position := Cursor'(Container'Unrestricted_Access, Index);
2110 (Container : in out Vector;
2112 New_Item : Element_Type;
2113 Count : Count_Type := 1)
2115 Index : Index_Type'Base;
2118 if Before.Container /= null
2119 and then Before.Container /= Container'Unrestricted_Access
2121 raise Program_Error with "Before cursor denotes wrong container";
2128 if Before.Container = null
2129 or else Before.Index > Container.Last
2131 if Container.Last = Index_Type'Last then
2132 raise Constraint_Error with
2133 "vector is already at its maximum length";
2136 Index := Container.Last + 1;
2139 Index := Before.Index;
2142 Insert (Container, Index, New_Item, Count);
2146 (Container : in out Vector;
2148 New_Item : Element_Type;
2149 Position : out Cursor;
2150 Count : Count_Type := 1)
2152 Index : Index_Type'Base;
2155 if Before.Container /= null
2156 and then Before.Container /= Container'Unrestricted_Access
2158 raise Program_Error with "Before cursor denotes wrong container";
2162 if Before.Container = null
2163 or else Before.Index > Container.Last
2165 Position := No_Element;
2167 Position := (Container'Unrestricted_Access, Before.Index);
2173 if Before.Container = null
2174 or else Before.Index > Container.Last
2176 if Container.Last = Index_Type'Last then
2177 raise Constraint_Error with
2178 "vector is already at its maximum length";
2181 Index := Container.Last + 1;
2184 Index := Before.Index;
2187 Insert (Container, Index, New_Item, Count);
2189 Position := (Container'Unrestricted_Access, Index);
2196 procedure Insert_Space
2197 (Container : in out Vector;
2198 Before : Extended_Index;
2199 Count : Count_Type := 1)
2201 Old_Length : constant Count_Type := Container.Length;
2203 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2204 New_Length : Count_Type'Base; -- sum of current length and Count
2205 New_Last : Index_Type'Base; -- last index of vector after insertion
2207 Index : Index_Type'Base; -- scratch for intermediate values
2208 J : Count_Type'Base; -- scratch
2210 New_Capacity : Count_Type'Base; -- length of new, expanded array
2211 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2212 Dst : Elements_Access; -- new, expanded internal array
2215 -- As a precondition on the generic actual Index_Type, the base type
2216 -- must include Index_Type'Pred (Index_Type'First); this is the value
2217 -- that Container.Last assumes when the vector is empty. However, we do
2218 -- not allow that as the value for Index when specifying where the new
2219 -- items should be inserted, so we must manually check. (That the user
2220 -- is allowed to specify the value at all here is a consequence of the
2221 -- declaration of the Extended_Index subtype, which includes the values
2222 -- in the base range that immediately precede and immediately follow the
2223 -- values in the Index_Type.)
2225 if Before < Index_Type'First then
2226 raise Constraint_Error with
2227 "Before index is out of range (too small)";
2230 -- We do allow a value greater than Container.Last to be specified as
2231 -- the Index, but only if it's immediately greater. This allows for the
2232 -- case of appending items to the back end of the vector. (It is assumed
2233 -- that specifying an index value greater than Last + 1 indicates some
2234 -- deeper flaw in the caller's algorithm, so that case is treated as a
2237 if Before > Container.Last
2238 and then Before > Container.Last + 1
2240 raise Constraint_Error with
2241 "Before index is out of range (too large)";
2244 -- We treat inserting 0 items into the container as a no-op, even when
2245 -- the container is busy, so we simply return.
2251 -- There are two constraints we need to satisfy. The first constraint is
2252 -- that a container cannot have more than Count_Type'Last elements, so
2253 -- we must check the sum of the current length and the insertion
2254 -- count. Note that we cannot simply add these values, because of the
2255 -- possibility of overflow.
2257 if Old_Length > Count_Type'Last - Count then
2258 raise Constraint_Error with "Count is out of range";
2261 -- It is now safe compute the length of the new vector, without fear of
2264 New_Length := Old_Length + Count;
2266 -- The second constraint is that the new Last index value cannot exceed
2267 -- Index_Type'Last. In each branch below, we calculate the maximum
2268 -- length (computed from the range of values in Index_Type), and then
2269 -- compare the new length to the maximum length. If the new length is
2270 -- acceptable, then we compute the new last index from that.
2272 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2273 -- We have to handle the case when there might be more values in the
2274 -- range of Index_Type than in the range of Count_Type.
2276 if Index_Type'First <= 0 then
2278 -- We know that No_Index (the same as Index_Type'First - 1) is
2279 -- less than 0, so it is safe to compute the following sum without
2280 -- fear of overflow.
2282 Index := No_Index + Index_Type'Base (Count_Type'Last);
2284 if Index <= Index_Type'Last then
2286 -- We have determined that range of Index_Type has at least as
2287 -- many values as in Count_Type, so Count_Type'Last is the
2288 -- maximum number of items that are allowed.
2290 Max_Length := Count_Type'Last;
2293 -- The range of Index_Type has fewer values than in Count_Type,
2294 -- so the maximum number of items is computed from the range of
2297 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2301 -- No_Index is equal or greater than 0, so we can safely compute
2302 -- the difference without fear of overflow (which we would have to
2303 -- worry about if No_Index were less than 0, but that case is
2306 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2309 elsif Index_Type'First <= 0 then
2311 -- We know that No_Index (the same as Index_Type'First - 1) is less
2312 -- than 0, so it is safe to compute the following sum without fear of
2315 J := Count_Type'Base (No_Index) + Count_Type'Last;
2317 if J <= Count_Type'Base (Index_Type'Last) then
2319 -- We have determined that range of Index_Type has at least as
2320 -- many values as in Count_Type, so Count_Type'Last is the maximum
2321 -- number of items that are allowed.
2323 Max_Length := Count_Type'Last;
2326 -- The range of Index_Type has fewer values than Count_Type does,
2327 -- so the maximum number of items is computed from the range of
2331 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2335 -- No_Index is equal or greater than 0, so we can safely compute the
2336 -- difference without fear of overflow (which we would have to worry
2337 -- about if No_Index were less than 0, but that case is handled
2341 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2344 -- We have just computed the maximum length (number of items). We must
2345 -- now compare the requested length to the maximum length, as we do not
2346 -- allow a vector expand beyond the maximum (because that would create
2347 -- an internal array with a last index value greater than
2348 -- Index_Type'Last, with no way to index those elements).
2350 if New_Length > Max_Length then
2351 raise Constraint_Error with "Count is out of range";
2354 -- New_Last is the last index value of the items in the container after
2355 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2356 -- compute its value from the New_Length.
2358 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2359 New_Last := No_Index + Index_Type'Base (New_Length);
2362 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2365 if Container.Elements = null then
2366 pragma Assert (Container.Last = No_Index);
2368 -- This is the simplest case, with which we must always begin: we're
2369 -- inserting items into an empty vector that hasn't allocated an
2370 -- internal array yet. Note that we don't need to check the busy bit
2371 -- here, because an empty container cannot be busy.
2373 -- In an indefinite vector, elements are allocated individually, and
2374 -- stored as access values on the internal array (the length of which
2375 -- represents the vector "capacity"), which is separately allocated.
2376 -- We have no elements here (because we're inserting "space"), so all
2377 -- we need to do is allocate the backbone.
2379 Container.Elements := new Elements_Type (New_Last);
2380 Container.Last := New_Last;
2385 -- The tampering bits exist to prevent an item from being harmfully
2386 -- manipulated while it is being visited. Query, Update, and Iterate
2387 -- increment the busy count on entry, and decrement the count on exit.
2388 -- Insert checks the count to determine whether it is being called while
2389 -- the associated callback procedure is executing.
2391 if Container.Busy > 0 then
2392 raise Program_Error with
2393 "attempt to tamper with cursors (vector is busy)";
2396 if New_Length <= Container.Elements.EA'Length then
2397 -- In this case, we're inserting elements into a vector that has
2398 -- already allocated an internal array, and the existing array has
2399 -- enough unused storage for the new items.
2402 E : Elements_Array renames Container.Elements.EA;
2405 if Before <= Container.Last then
2407 -- The new space is being inserted before some existing
2408 -- elements, so we must slide the existing elements up to their
2409 -- new home. We use the wider of Index_Type'Base and
2410 -- Count_Type'Base as the type for intermediate index values.
2412 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2413 Index := Before + Index_Type'Base (Count);
2416 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2419 E (Index .. New_Last) := E (Before .. Container.Last);
2420 E (Before .. Index - 1) := (others => null);
2424 Container.Last := New_Last;
2428 -- In this case, we're inserting elements into a vector that has already
2429 -- allocated an internal array, but the existing array does not have
2430 -- enough storage, so we must allocate a new, longer array. In order to
2431 -- guarantee that the amortized insertion cost is O(1), we always
2432 -- allocate an array whose length is some power-of-two factor of the
2433 -- current array length. (The new array cannot have a length less than
2434 -- the New_Length of the container, but its last index value cannot be
2435 -- greater than Index_Type'Last.)
2437 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2438 while New_Capacity < New_Length loop
2439 if New_Capacity > Count_Type'Last / 2 then
2440 New_Capacity := Count_Type'Last;
2444 New_Capacity := 2 * New_Capacity;
2447 if New_Capacity > Max_Length then
2449 -- We have reached the limit of capacity, so no further expansion
2450 -- will occur. (This is not a problem, as there is never a need to
2451 -- have more capacity than the maximum container length.)
2453 New_Capacity := Max_Length;
2456 -- We have computed the length of the new internal array (and this is
2457 -- what "vector capacity" means), so use that to compute its last index.
2459 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2460 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2464 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2467 -- Now we allocate the new, longer internal array. If the allocation
2468 -- fails, we have not changed any container state, so no side-effect
2469 -- will occur as a result of propagating the exception.
2471 Dst := new Elements_Type (Dst_Last);
2473 -- We have our new internal array. All that needs to be done now is to
2474 -- copy the existing items (if any) from the old array (the "source"
2475 -- array) to the new array (the "destination" array), and then
2476 -- deallocate the old array.
2479 Src : Elements_Access := Container.Elements;
2482 Dst.EA (Index_Type'First .. Before - 1) :=
2483 Src.EA (Index_Type'First .. Before - 1);
2485 if Before <= Container.Last then
2487 -- The new items are being inserted before some existing elements,
2488 -- so we must slide the existing elements up to their new home.
2490 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2491 Index := Before + Index_Type'Base (Count);
2494 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2497 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
2500 -- We have copied the elements from to the old, source array to the
2501 -- new, destination array, so we can now restore invariants, and
2502 -- deallocate the old array.
2504 Container.Elements := Dst;
2505 Container.Last := New_Last;
2510 procedure Insert_Space
2511 (Container : in out Vector;
2513 Position : out Cursor;
2514 Count : Count_Type := 1)
2516 Index : Index_Type'Base;
2519 if Before.Container /= null
2520 and then Before.Container /= Container'Unrestricted_Access
2522 raise Program_Error with "Before cursor denotes wrong container";
2526 if Before.Container = null
2527 or else Before.Index > Container.Last
2529 Position := No_Element;
2531 Position := (Container'Unrestricted_Access, Before.Index);
2537 if Before.Container = null
2538 or else Before.Index > Container.Last
2540 if Container.Last = Index_Type'Last then
2541 raise Constraint_Error with
2542 "vector is already at its maximum length";
2545 Index := Container.Last + 1;
2548 Index := Before.Index;
2551 Insert_Space (Container, Index, Count);
2553 Position := Cursor'(Container'Unrestricted_Access, Index);
2560 function Is_Empty (Container : Vector) return Boolean is
2562 return Container.Last < Index_Type'First;
2570 (Container : Vector;
2571 Process : not null access procedure (Position : Cursor))
2573 B : Natural renames Container'Unrestricted_Access.all.Busy;
2579 for Indx in Index_Type'First .. Container.Last loop
2580 Process (Cursor'(Container'Unrestricted_Access, Indx));
2591 function Iterate (Container : Vector)
2592 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2594 V : constant Vector_Access := Container'Unrestricted_Access;
2595 B : Natural renames V.Busy;
2598 -- The value of its Index component influences the behavior of the First
2599 -- and Last selector functions of the iterator object. When the Index
2600 -- component is No_Index (as is the case here), this means the iterator
2601 -- object was constructed without a start expression. This is a complete
2602 -- iterator, meaning that the iteration starts from the (logical)
2603 -- beginning of the sequence of items.
2605 -- Note: For a forward iterator, Container.First is the beginning, and
2606 -- for a reverse iterator, Container.Last is the beginning.
2608 return It : constant Iterator :=
2609 (Limited_Controlled with
2618 (Container : Vector;
2620 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2622 V : constant Vector_Access := Container'Unrestricted_Access;
2623 B : Natural renames V.Busy;
2626 -- It was formerly the case that when Start = No_Element, the partial
2627 -- iterator was defined to behave the same as for a complete iterator,
2628 -- and iterate over the entire sequence of items. However, those
2629 -- semantics were unintuitive and arguably error-prone (it is too easy
2630 -- to accidentally create an endless loop), and so they were changed,
2631 -- per the ARG meeting in Denver on 2011/11. However, there was no
2632 -- consensus about what positive meaning this corner case should have,
2633 -- and so it was decided to simply raise an exception. This does imply,
2634 -- however, that it is not possible to use a partial iterator to specify
2635 -- an empty sequence of items.
2637 if Start.Container = null then
2638 raise Constraint_Error with
2639 "Start position for iterator equals No_Element";
2642 if Start.Container /= V then
2643 raise Program_Error with
2644 "Start cursor of Iterate designates wrong vector";
2647 if Start.Index > V.Last then
2648 raise Constraint_Error with
2649 "Start position for iterator equals No_Element";
2652 -- The value of its Index component influences the behavior of the First
2653 -- and Last selector functions of the iterator object. When the Index
2654 -- component is not No_Index (as is the case here), it means that this
2655 -- is a partial iteration, over a subset of the complete sequence of
2656 -- items. The iterator object was constructed with a start expression,
2657 -- indicating the position from which the iteration begins. Note that
2658 -- the start position has the same value irrespective of whether this
2659 -- is a forward or reverse iteration.
2661 return It : constant Iterator :=
2662 (Limited_Controlled with
2664 Index => Start.Index)
2674 function Last (Container : Vector) return Cursor is
2676 if Is_Empty (Container) then
2680 return (Container'Unrestricted_Access, Container.Last);
2683 function Last (Object : Iterator) return Cursor is
2685 -- The value of the iterator object's Index component influences the
2686 -- behavior of the Last (and First) selector function.
2688 -- When the Index component is No_Index, this means the iterator
2689 -- object was constructed without a start expression, in which case the
2690 -- (reverse) iteration starts from the (logical) beginning of the entire
2691 -- sequence (corresponding to Container.Last, for a reverse iterator).
2693 -- Otherwise, this is iteration over a partial sequence of items.
2694 -- When the Index component is not No_Index, the iterator object was
2695 -- constructed with a start expression, that specifies the position
2696 -- from which the (reverse) partial iteration begins.
2698 if Object.Index = No_Index then
2699 return Last (Object.Container.all);
2701 return Cursor'(Object.Container, Object.Index);
2709 function Last_Element (Container : Vector) return Element_Type is
2711 if Container.Last = No_Index then
2712 raise Constraint_Error with "Container is empty";
2716 EA : constant Element_Access :=
2717 Container.Elements.EA (Container.Last);
2721 raise Constraint_Error with "last element is empty";
2732 function Last_Index (Container : Vector) return Extended_Index is
2734 return Container.Last;
2741 function Length (Container : Vector) return Count_Type is
2742 L : constant Index_Type'Base := Container.Last;
2743 F : constant Index_Type := Index_Type'First;
2746 -- The base range of the index type (Index_Type'Base) might not include
2747 -- all values for length (Count_Type). Contrariwise, the index type
2748 -- might include values outside the range of length. Hence we use
2749 -- whatever type is wider for intermediate values when calculating
2750 -- length. Note that no matter what the index type is, the maximum
2751 -- length to which a vector is allowed to grow is always the minimum
2752 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2754 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2755 -- to have a base range of -128 .. 127, but the corresponding vector
2756 -- would have lengths in the range 0 .. 255. In this case we would need
2757 -- to use Count_Type'Base for intermediate values.
2759 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2760 -- vector would have a maximum length of 10, but the index values lie
2761 -- outside the range of Count_Type (which is only 32 bits). In this
2762 -- case we would need to use Index_Type'Base for intermediate values.
2764 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2765 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2767 return Count_Type (L - F + 1);
2776 (Target : in out Vector;
2777 Source : in out Vector)
2780 if Target'Address = Source'Address then
2784 if Source.Busy > 0 then
2785 raise Program_Error with
2786 "attempt to tamper with cursors (Source is busy)";
2789 Clear (Target); -- Checks busy-bit
2792 Target_Elements : constant Elements_Access := Target.Elements;
2794 Target.Elements := Source.Elements;
2795 Source.Elements := Target_Elements;
2798 Target.Last := Source.Last;
2799 Source.Last := No_Index;
2806 function Next (Position : Cursor) return Cursor is
2808 if Position.Container = null then
2812 if Position.Index < Position.Container.Last then
2813 return (Position.Container, Position.Index + 1);
2819 function Next (Object : Iterator; Position : Cursor) return Cursor is
2821 if Position.Container = null then
2825 if Position.Container /= Object.Container then
2826 raise Program_Error with
2827 "Position cursor of Next designates wrong vector";
2830 return Next (Position);
2833 procedure Next (Position : in out Cursor) is
2835 if Position.Container = null then
2839 if Position.Index < Position.Container.Last then
2840 Position.Index := Position.Index + 1;
2842 Position := No_Element;
2850 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2852 Insert (Container, Index_Type'First, New_Item);
2856 (Container : in out Vector;
2857 New_Item : Element_Type;
2858 Count : Count_Type := 1)
2871 procedure Previous (Position : in out Cursor) is
2873 if Position.Container = null then
2877 if Position.Index > Index_Type'First then
2878 Position.Index := Position.Index - 1;
2880 Position := No_Element;
2884 function Previous (Position : Cursor) return Cursor is
2886 if Position.Container = null then
2890 if Position.Index > Index_Type'First then
2891 return (Position.Container, Position.Index - 1);
2897 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2899 if Position.Container = null then
2903 if Position.Container /= Object.Container then
2904 raise Program_Error with
2905 "Position cursor of Previous designates wrong vector";
2908 return Previous (Position);
2915 procedure Query_Element
2916 (Container : Vector;
2918 Process : not null access procedure (Element : Element_Type))
2920 V : Vector renames Container'Unrestricted_Access.all;
2921 B : Natural renames V.Busy;
2922 L : Natural renames V.Lock;
2925 if Index > Container.Last then
2926 raise Constraint_Error with "Index is out of range";
2929 if V.Elements.EA (Index) = null then
2930 raise Constraint_Error with "element is null";
2937 Process (V.Elements.EA (Index).all);
2949 procedure Query_Element
2951 Process : not null access procedure (Element : Element_Type))
2954 if Position.Container = null then
2955 raise Constraint_Error with "Position cursor has no element";
2958 Query_Element (Position.Container.all, Position.Index, Process);
2966 (Stream : not null access Root_Stream_Type'Class;
2967 Container : out Vector)
2969 Length : Count_Type'Base;
2970 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
2977 Count_Type'Base'Read (Stream, Length);
2979 if Length > Capacity (Container) then
2980 Reserve_Capacity (Container, Capacity => Length);
2983 for J in Count_Type range 1 .. Length loop
2986 Boolean'Read (Stream, B);
2989 Container.Elements.EA (Last) :=
2990 new Element_Type'(Element_Type'Input (Stream));
2993 Container.Last := Last;
2998 (Stream : not null access Root_Stream_Type'Class;
2999 Position : out Cursor)
3002 raise Program_Error with "attempt to stream vector cursor";
3006 (Stream : not null access Root_Stream_Type'Class;
3007 Item : out Reference_Type)
3010 raise Program_Error with "attempt to stream reference";
3014 (Stream : not null access Root_Stream_Type'Class;
3015 Item : out Constant_Reference_Type)
3018 raise Program_Error with "attempt to stream reference";
3026 (Container : aliased in out Vector;
3027 Position : Cursor) return Reference_Type
3032 if Position.Container = null then
3033 raise Constraint_Error with "Position cursor has no element";
3036 if Position.Container /= Container'Unrestricted_Access then
3037 raise Program_Error with "Position cursor denotes wrong container";
3040 if Position.Index > Position.Container.Last then
3041 raise Constraint_Error with "Position cursor is out of range";
3044 E := Container.Elements.EA (Position.Index);
3047 raise Constraint_Error with "element at Position is empty";
3050 return (Element => E.all'Access);
3054 (Container : aliased in out Vector;
3055 Index : Index_Type) return Reference_Type
3060 if Index > Container.Last then
3061 raise Constraint_Error with "Index is out of range";
3064 E := Container.Elements.EA (Index);
3067 raise Constraint_Error with "element at Index is empty";
3070 return (Element => E.all'Access);
3073 ---------------------
3074 -- Replace_Element --
3075 ---------------------
3077 procedure Replace_Element
3078 (Container : in out Vector;
3080 New_Item : Element_Type)
3083 if Index > Container.Last then
3084 raise Constraint_Error with "Index is out of range";
3087 if Container.Lock > 0 then
3088 raise Program_Error with
3089 "attempt to tamper with elements (vector is locked)";
3093 X : Element_Access := Container.Elements.EA (Index);
3095 Container.Elements.EA (Index) := new Element_Type'(New_Item);
3098 end Replace_Element;
3100 procedure Replace_Element
3101 (Container : in out Vector;
3103 New_Item : Element_Type)
3106 if Position.Container = null then
3107 raise Constraint_Error with "Position cursor has no element";
3110 if Position.Container /= Container'Unrestricted_Access then
3111 raise Program_Error with "Position cursor denotes wrong container";
3114 if Position.Index > Container.Last then
3115 raise Constraint_Error with "Position cursor is out of range";
3118 if Container.Lock > 0 then
3119 raise Program_Error with
3120 "attempt to tamper with elements (vector is locked)";
3124 X : Element_Access := Container.Elements.EA (Position.Index);
3126 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
3129 end Replace_Element;
3131 ----------------------
3132 -- Reserve_Capacity --
3133 ----------------------
3135 procedure Reserve_Capacity
3136 (Container : in out Vector;
3137 Capacity : Count_Type)
3139 N : constant Count_Type := Length (Container);
3141 Index : Count_Type'Base;
3142 Last : Index_Type'Base;
3145 -- Reserve_Capacity can be used to either expand the storage available
3146 -- for elements (this would be its typical use, in anticipation of
3147 -- future insertion), or to trim back storage. In the latter case,
3148 -- storage can only be trimmed back to the limit of the container
3149 -- length. Note that Reserve_Capacity neither deletes (active) elements
3150 -- nor inserts elements; it only affects container capacity, never
3151 -- container length.
3153 if Capacity = 0 then
3155 -- This is a request to trim back storage, to the minimum amount
3156 -- possible given the current state of the container.
3160 -- The container is empty, so in this unique case we can
3161 -- deallocate the entire internal array. Note that an empty
3162 -- container can never be busy, so there's no need to check the
3166 X : Elements_Access := Container.Elements;
3169 -- First we remove the internal array from the container, to
3170 -- handle the case when the deallocation raises an exception
3171 -- (although that's unlikely, since this is simply an array of
3172 -- access values, all of which are null).
3174 Container.Elements := null;
3176 -- Container invariants have been restored, so it is now safe
3177 -- to attempt to deallocate the internal array.
3182 elsif N < Container.Elements.EA'Length then
3184 -- The container is not empty, and the current length is less than
3185 -- the current capacity, so there's storage available to trim. In
3186 -- this case, we allocate a new internal array having a length
3187 -- that exactly matches the number of items in the
3188 -- container. (Reserve_Capacity does not delete active elements,
3189 -- so this is the best we can do with respect to minimizing
3192 if Container.Busy > 0 then
3193 raise Program_Error with
3194 "attempt to tamper with cursors (vector is busy)";
3198 subtype Array_Index_Subtype is Index_Type'Base range
3199 Index_Type'First .. Container.Last;
3201 Src : Elements_Array renames
3202 Container.Elements.EA (Array_Index_Subtype);
3204 X : Elements_Access := Container.Elements;
3207 -- Although we have isolated the old internal array that we're
3208 -- going to deallocate, we don't deallocate it until we have
3209 -- successfully allocated a new one. If there is an exception
3210 -- during allocation (because there is not enough storage), we
3211 -- let it propagate without causing any side-effect.
3213 Container.Elements := new Elements_Type'(Container.Last, Src);
3215 -- We have successfully allocated a new internal array (with a
3216 -- smaller length than the old one, and containing a copy of
3217 -- just the active elements in the container), so we can
3218 -- deallocate the old array.
3227 -- Reserve_Capacity can be used to expand the storage available for
3228 -- elements, but we do not let the capacity grow beyond the number of
3229 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3230 -- to refer to the elements with index values greater than
3231 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3232 -- the Last index value of the new internal array, in a way that avoids
3233 -- any possibility of overflow.
3235 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3237 -- We perform a two-part test. First we determine whether the
3238 -- computed Last value lies in the base range of the type, and then
3239 -- determine whether it lies in the range of the index (sub)type.
3241 -- Last must satisfy this relation:
3242 -- First + Length - 1 <= Last
3243 -- We regroup terms:
3244 -- First - 1 <= Last - Length
3245 -- Which can rewrite as:
3246 -- No_Index <= Last - Length
3248 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
3249 raise Constraint_Error with "Capacity is out of range";
3252 -- We now know that the computed value of Last is within the base
3253 -- range of the type, so it is safe to compute its value:
3255 Last := No_Index + Index_Type'Base (Capacity);
3257 -- Finally we test whether the value is within the range of the
3258 -- generic actual index subtype:
3260 if Last > Index_Type'Last then
3261 raise Constraint_Error with "Capacity is out of range";
3264 elsif Index_Type'First <= 0 then
3266 -- Here we can compute Last directly, in the normal way. We know that
3267 -- No_Index is less than 0, so there is no danger of overflow when
3268 -- adding the (positive) value of Capacity.
3270 Index := Count_Type'Base (No_Index) + Capacity; -- Last
3272 if Index > Count_Type'Base (Index_Type'Last) then
3273 raise Constraint_Error with "Capacity is out of range";
3276 -- We know that the computed value (having type Count_Type) of Last
3277 -- is within the range of the generic actual index subtype, so it is
3278 -- safe to convert to Index_Type:
3280 Last := Index_Type'Base (Index);
3283 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3284 -- must test the length indirectly (by working backwards from the
3285 -- largest possible value of Last), in order to prevent overflow.
3287 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
3289 if Index < Count_Type'Base (No_Index) then
3290 raise Constraint_Error with "Capacity is out of range";
3293 -- We have determined that the value of Capacity would not create a
3294 -- Last index value outside of the range of Index_Type, so we can now
3295 -- safely compute its value.
3297 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
3300 -- The requested capacity is non-zero, but we don't know yet whether
3301 -- this is a request for expansion or contraction of storage.
3303 if Container.Elements = null then
3305 -- The container is empty (it doesn't even have an internal array),
3306 -- so this represents a request to allocate storage having the given
3309 Container.Elements := new Elements_Type (Last);
3313 if Capacity <= N then
3315 -- This is a request to trim back storage, but only to the limit of
3316 -- what's already in the container. (Reserve_Capacity never deletes
3317 -- active elements, it only reclaims excess storage.)
3319 if N < Container.Elements.EA'Length then
3321 -- The container is not empty (because the requested capacity is
3322 -- positive, and less than or equal to the container length), and
3323 -- the current length is less than the current capacity, so there
3324 -- is storage available to trim. In this case, we allocate a new
3325 -- internal array having a length that exactly matches the number
3326 -- of items in the container.
3328 if Container.Busy > 0 then
3329 raise Program_Error with
3330 "attempt to tamper with cursors (vector is busy)";
3334 subtype Array_Index_Subtype is Index_Type'Base range
3335 Index_Type'First .. Container.Last;
3337 Src : Elements_Array renames
3338 Container.Elements.EA (Array_Index_Subtype);
3340 X : Elements_Access := Container.Elements;
3343 -- Although we have isolated the old internal array that we're
3344 -- going to deallocate, we don't deallocate it until we have
3345 -- successfully allocated a new one. If there is an exception
3346 -- during allocation (because there is not enough storage), we
3347 -- let it propagate without causing any side-effect.
3349 Container.Elements := new Elements_Type'(Container.Last, Src);
3351 -- We have successfully allocated a new internal array (with a
3352 -- smaller length than the old one, and containing a copy of
3353 -- just the active elements in the container), so it is now
3354 -- safe to deallocate the old array.
3363 -- The requested capacity is larger than the container length (the
3364 -- number of active elements). Whether this represents a request for
3365 -- expansion or contraction of the current capacity depends on what the
3366 -- current capacity is.
3368 if Capacity = Container.Elements.EA'Length then
3370 -- The requested capacity matches the existing capacity, so there's
3371 -- nothing to do here. We treat this case as a no-op, and simply
3372 -- return without checking the busy bit.
3377 -- There is a change in the capacity of a non-empty container, so a new
3378 -- internal array will be allocated. (The length of the new internal
3379 -- array could be less or greater than the old internal array. We know
3380 -- only that the length of the new internal array is greater than the
3381 -- number of active elements in the container.) We must check whether
3382 -- the container is busy before doing anything else.
3384 if Container.Busy > 0 then
3385 raise Program_Error with
3386 "attempt to tamper with cursors (vector is busy)";
3389 -- We now allocate a new internal array, having a length different from
3390 -- its current value.
3393 X : Elements_Access := Container.Elements;
3395 subtype Index_Subtype is Index_Type'Base range
3396 Index_Type'First .. Container.Last;
3399 -- We now allocate a new internal array, having a length different
3400 -- from its current value.
3402 Container.Elements := new Elements_Type (Last);
3404 -- We have successfully allocated the new internal array, so now we
3405 -- move the existing elements from the existing the old internal
3406 -- array onto the new one. Note that we're just copying access
3407 -- values, to this should not raise any exceptions.
3409 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3411 -- We have moved the elements from the old internal array, so now we
3412 -- can deallocate it.
3416 end Reserve_Capacity;
3418 ----------------------
3419 -- Reverse_Elements --
3420 ----------------------
3422 procedure Reverse_Elements (Container : in out Vector) is
3424 if Container.Length <= 1 then
3428 -- The exception behavior for the vector container must match that for
3429 -- the list container, so we check for cursor tampering here (which will
3430 -- catch more things) instead of for element tampering (which will catch
3431 -- fewer things). It's true that the elements of this vector container
3432 -- could be safely moved around while (say) an iteration is taking place
3433 -- (iteration only increments the busy counter), and so technically
3434 -- all we would need here is a test for element tampering (indicated
3435 -- by the lock counter), that's simply an artifact of our array-based
3436 -- implementation. Logically Reverse_Elements requires a check for
3437 -- cursor tampering.
3439 if Container.Busy > 0 then
3440 raise Program_Error with
3441 "attempt to tamper with cursors (vector is busy)";
3447 E : Elements_Array renames Container.Elements.EA;
3450 I := Index_Type'First;
3451 J := Container.Last;
3454 EI : constant Element_Access := E (I);
3465 end Reverse_Elements;
3471 function Reverse_Find
3472 (Container : Vector;
3473 Item : Element_Type;
3474 Position : Cursor := No_Element) return Cursor
3476 Last : Index_Type'Base;
3479 if Position.Container /= null
3480 and then Position.Container /= Container'Unrestricted_Access
3482 raise Program_Error with "Position cursor denotes wrong container";
3485 if Position.Container = null
3486 or else Position.Index > Container.Last
3488 Last := Container.Last;
3490 Last := Position.Index;
3493 for Indx in reverse Index_Type'First .. Last loop
3494 if Container.Elements.EA (Indx) /= null
3495 and then Container.Elements.EA (Indx).all = Item
3497 return (Container'Unrestricted_Access, Indx);
3504 ------------------------
3505 -- Reverse_Find_Index --
3506 ------------------------
3508 function Reverse_Find_Index
3509 (Container : Vector;
3510 Item : Element_Type;
3511 Index : Index_Type := Index_Type'Last) return Extended_Index
3513 Last : constant Index_Type'Base :=
3514 (if Index > Container.Last then Container.Last else Index);
3516 for Indx in reverse Index_Type'First .. Last loop
3517 if Container.Elements.EA (Indx) /= null
3518 and then Container.Elements.EA (Indx).all = Item
3525 end Reverse_Find_Index;
3527 ---------------------
3528 -- Reverse_Iterate --
3529 ---------------------
3531 procedure Reverse_Iterate
3532 (Container : Vector;
3533 Process : not null access procedure (Position : Cursor))
3535 V : Vector renames Container'Unrestricted_Access.all;
3536 B : Natural renames V.Busy;
3542 for Indx in reverse Index_Type'First .. Container.Last loop
3543 Process (Cursor'(Container'Unrestricted_Access, Indx));
3552 end Reverse_Iterate;
3558 procedure Set_Length
3559 (Container : in out Vector;
3560 Length : Count_Type)
3562 Count : constant Count_Type'Base := Container.Length - Length;
3565 -- Set_Length allows the user to set the length explicitly, instead of
3566 -- implicitly as a side-effect of deletion or insertion. If the
3567 -- requested length is less than the current length, this is equivalent
3568 -- to deleting items from the back end of the vector. If the requested
3569 -- length is greater than the current length, then this is equivalent to
3570 -- inserting "space" (nonce items) at the end.
3573 Container.Delete_Last (Count);
3575 elsif Container.Last >= Index_Type'Last then
3576 raise Constraint_Error with "vector is already at its maximum length";
3579 Container.Insert_Space (Container.Last + 1, -Count);
3588 (Container : in out Vector;
3592 if I > Container.Last then
3593 raise Constraint_Error with "I index is out of range";
3596 if J > Container.Last then
3597 raise Constraint_Error with "J index is out of range";
3604 if Container.Lock > 0 then
3605 raise Program_Error with
3606 "attempt to tamper with elements (vector is locked)";
3610 EI : Element_Access renames Container.Elements.EA (I);
3611 EJ : Element_Access renames Container.Elements.EA (J);
3613 EI_Copy : constant Element_Access := EI;
3622 (Container : in out Vector;
3626 if I.Container = null then
3627 raise Constraint_Error with "I cursor has no element";
3630 if J.Container = null then
3631 raise Constraint_Error with "J cursor has no element";
3634 if I.Container /= Container'Unrestricted_Access then
3635 raise Program_Error with "I cursor denotes wrong container";
3638 if J.Container /= Container'Unrestricted_Access then
3639 raise Program_Error with "J cursor denotes wrong container";
3642 Swap (Container, I.Index, J.Index);
3650 (Container : Vector;
3651 Index : Extended_Index) return Cursor
3654 if Index not in Index_Type'First .. Container.Last then
3658 return Cursor'(Container'Unrestricted_Access, Index);
3665 function To_Index (Position : Cursor) return Extended_Index is
3667 if Position.Container = null then
3671 if Position.Index <= Position.Container.Last then
3672 return Position.Index;
3682 function To_Vector (Length : Count_Type) return Vector is
3683 Index : Count_Type'Base;
3684 Last : Index_Type'Base;
3685 Elements : Elements_Access;
3689 return Empty_Vector;
3692 -- We create a vector object with a capacity that matches the specified
3693 -- Length, but we do not allow the vector capacity (the length of the
3694 -- internal array) to exceed the number of values in Index_Type'Range
3695 -- (otherwise, there would be no way to refer to those components via an
3696 -- index). We must therefore check whether the specified Length would
3697 -- create a Last index value greater than Index_Type'Last.
3699 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3701 -- We perform a two-part test. First we determine whether the
3702 -- computed Last value lies in the base range of the type, and then
3703 -- determine whether it lies in the range of the index (sub)type.
3705 -- Last must satisfy this relation:
3706 -- First + Length - 1 <= Last
3707 -- We regroup terms:
3708 -- First - 1 <= Last - Length
3709 -- Which can rewrite as:
3710 -- No_Index <= Last - Length
3712 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3713 raise Constraint_Error with "Length is out of range";
3716 -- We now know that the computed value of Last is within the base
3717 -- range of the type, so it is safe to compute its value:
3719 Last := No_Index + Index_Type'Base (Length);
3721 -- Finally we test whether the value is within the range of the
3722 -- generic actual index subtype:
3724 if Last > Index_Type'Last then
3725 raise Constraint_Error with "Length is out of range";
3728 elsif Index_Type'First <= 0 then
3730 -- Here we can compute Last directly, in the normal way. We know that
3731 -- No_Index is less than 0, so there is no danger of overflow when
3732 -- adding the (positive) value of Length.
3734 Index := Count_Type'Base (No_Index) + Length; -- Last
3736 if Index > Count_Type'Base (Index_Type'Last) then
3737 raise Constraint_Error with "Length is out of range";
3740 -- We know that the computed value (having type Count_Type) of Last
3741 -- is within the range of the generic actual index subtype, so it is
3742 -- safe to convert to Index_Type:
3744 Last := Index_Type'Base (Index);
3747 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3748 -- must test the length indirectly (by working backwards from the
3749 -- largest possible value of Last), in order to prevent overflow.
3751 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3753 if Index < Count_Type'Base (No_Index) then
3754 raise Constraint_Error with "Length is out of range";
3757 -- We have determined that the value of Length would not create a
3758 -- Last index value outside of the range of Index_Type, so we can now
3759 -- safely compute its value.
3761 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3764 Elements := new Elements_Type (Last);
3766 return Vector'(Controlled with Elements, Last, 0, 0);
3770 (New_Item : Element_Type;
3771 Length : Count_Type) return Vector
3773 Index : Count_Type'Base;
3774 Last : Index_Type'Base;
3775 Elements : Elements_Access;
3779 return Empty_Vector;
3782 -- We create a vector object with a capacity that matches the specified
3783 -- Length, but we do not allow the vector capacity (the length of the
3784 -- internal array) to exceed the number of values in Index_Type'Range
3785 -- (otherwise, there would be no way to refer to those components via an
3786 -- index). We must therefore check whether the specified Length would
3787 -- create a Last index value greater than Index_Type'Last.
3789 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3791 -- We perform a two-part test. First we determine whether the
3792 -- computed Last value lies in the base range of the type, and then
3793 -- determine whether it lies in the range of the index (sub)type.
3795 -- Last must satisfy this relation:
3796 -- First + Length - 1 <= Last
3797 -- We regroup terms:
3798 -- First - 1 <= Last - Length
3799 -- Which can rewrite as:
3800 -- No_Index <= Last - Length
3802 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3803 raise Constraint_Error with "Length is out of range";
3806 -- We now know that the computed value of Last is within the base
3807 -- range of the type, so it is safe to compute its value:
3809 Last := No_Index + Index_Type'Base (Length);
3811 -- Finally we test whether the value is within the range of the
3812 -- generic actual index subtype:
3814 if Last > Index_Type'Last then
3815 raise Constraint_Error with "Length is out of range";
3818 elsif Index_Type'First <= 0 then
3820 -- Here we can compute Last directly, in the normal way. We know that
3821 -- No_Index is less than 0, so there is no danger of overflow when
3822 -- adding the (positive) value of Length.
3824 Index := Count_Type'Base (No_Index) + Length; -- Last
3826 if Index > Count_Type'Base (Index_Type'Last) then
3827 raise Constraint_Error with "Length is out of range";
3830 -- We know that the computed value (having type Count_Type) of Last
3831 -- is within the range of the generic actual index subtype, so it is
3832 -- safe to convert to Index_Type:
3834 Last := Index_Type'Base (Index);
3837 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3838 -- must test the length indirectly (by working backwards from the
3839 -- largest possible value of Last), in order to prevent overflow.
3841 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3843 if Index < Count_Type'Base (No_Index) then
3844 raise Constraint_Error with "Length is out of range";
3847 -- We have determined that the value of Length would not create a
3848 -- Last index value outside of the range of Index_Type, so we can now
3849 -- safely compute its value.
3851 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3854 Elements := new Elements_Type (Last);
3856 -- We use Last as the index of the loop used to populate the internal
3857 -- array with items. In general, we prefer to initialize the loop index
3858 -- immediately prior to entering the loop. However, Last is also used in
3859 -- the exception handler (to reclaim elements that have been allocated,
3860 -- before propagating the exception), and the initialization of Last
3861 -- after entering the block containing the handler confuses some static
3862 -- analysis tools, with respect to whether Last has been properly
3863 -- initialized when the handler executes. So here we initialize our loop
3864 -- variable earlier than we prefer, before entering the block, so there
3867 Last := Index_Type'First;
3871 Elements.EA (Last) := new Element_Type'(New_Item);
3872 exit when Last = Elements.Last;
3878 for J in Index_Type'First .. Last - 1 loop
3879 Free (Elements.EA (J));
3886 return (Controlled with Elements, Last, 0, 0);
3889 --------------------
3890 -- Update_Element --
3891 --------------------
3893 procedure Update_Element
3894 (Container : in out Vector;
3896 Process : not null access procedure (Element : in out Element_Type))
3898 B : Natural renames Container.Busy;
3899 L : Natural renames Container.Lock;
3902 if Index > Container.Last then
3903 raise Constraint_Error with "Index is out of range";
3906 if Container.Elements.EA (Index) = null then
3907 raise Constraint_Error with "element is null";
3914 Process (Container.Elements.EA (Index).all);
3926 procedure Update_Element
3927 (Container : in out Vector;
3929 Process : not null access procedure (Element : in out Element_Type))
3932 if Position.Container = null then
3933 raise Constraint_Error with "Position cursor has no element";
3936 if Position.Container /= Container'Unrestricted_Access then
3937 raise Program_Error with "Position cursor denotes wrong container";
3940 Update_Element (Container, Position.Index, Process);
3948 (Stream : not null access Root_Stream_Type'Class;
3951 N : constant Count_Type := Length (Container);
3954 Count_Type'Base'Write (Stream, N);
3961 E : Elements_Array renames Container.Elements.EA;
3964 for Indx in Index_Type'First .. Container.Last loop
3965 if E (Indx) = null then
3966 Boolean'Write (Stream, False);
3968 Boolean'Write (Stream, True);
3969 Element_Type'Output (Stream, E (Indx).all);
3976 (Stream : not null access Root_Stream_Type'Class;
3980 raise Program_Error with "attempt to stream vector cursor";
3984 (Stream : not null access Root_Stream_Type'Class;
3985 Item : Reference_Type)
3988 raise Program_Error with "attempt to stream reference";
3992 (Stream : not null access Root_Stream_Type'Class;
3993 Item : Constant_Reference_Type)
3996 raise Program_Error with "attempt to stream reference";
3999 end Ada.Containers.Indefinite_Vectors;