1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
9 -- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Containers.Generic_Array_Sort;
31 with Ada.Unchecked_Deallocation;
32 with System; use type System.Address;
34 package body Ada.Containers.Indefinite_Vectors is
37 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
40 new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
43 Vector_Iterator_Interfaces.Reversible_Iterator with record
44 Container : Vector_Access;
48 overriding function First (Object : Iterator) return Cursor;
50 overriding function Last (Object : Iterator) return Cursor;
52 overriding function Next
54 Position : Cursor) return Cursor;
56 overriding function Previous
58 Position : Cursor) return Cursor;
64 function "&" (Left, Right : Vector) return Vector is
65 LN : constant Count_Type := Length (Left);
66 RN : constant Count_Type := Length (Right);
67 N : Count_Type'Base; -- length of result
68 J : Count_Type'Base; -- for computing intermediate values
69 Last : Index_Type'Base; -- Last index of result
72 -- We decide that the capacity of the result is the sum of the lengths
73 -- of the vector parameters. We could decide to make it larger, but we
74 -- have no basis for knowing how much larger, so we just allocate the
75 -- minimum amount of storage.
77 -- Here we handle the easy cases first, when one of the vector
78 -- parameters is empty. (We say "easy" because there's nothing to
79 -- compute, that can potentially overflow.)
87 RE : Elements_Array renames
88 Right.Elements.EA (Index_Type'First .. Right.Last);
90 Elements : Elements_Access :=
91 new Elements_Type (Right.Last);
94 -- Elements of an indefinite vector are allocated, so we cannot
95 -- use simple slice assignment to give a value to our result.
96 -- Hence we must walk the array of the Right vector, and copy
97 -- each source element individually.
99 for I in Elements.EA'Range loop
101 if RE (I) /= null then
102 Elements.EA (I) := new Element_Type'(RE (I).all);
107 for J in Index_Type'First .. I - 1 loop
108 Free (Elements.EA (J));
116 return (Controlled with Elements, Right.Last, 0, 0);
123 LE : Elements_Array renames
124 Left.Elements.EA (Index_Type'First .. Left.Last);
126 Elements : Elements_Access :=
127 new Elements_Type (Left.Last);
130 -- Elements of an indefinite vector are allocated, so we cannot
131 -- use simple slice assignment to give a value to our result.
132 -- Hence we must walk the array of the Left vector, and copy
133 -- each source element individually.
135 for I in Elements.EA'Range loop
137 if LE (I) /= null then
138 Elements.EA (I) := new Element_Type'(LE (I).all);
143 for J in Index_Type'First .. I - 1 loop
144 Free (Elements.EA (J));
152 return (Controlled with Elements, Left.Last, 0, 0);
156 -- Neither of the vector parameters is empty, so we must compute the
157 -- length of the result vector and its last index. (This is the harder
158 -- case, because our computations must avoid overflow.)
160 -- There are two constraints we need to satisfy. The first constraint is
161 -- that a container cannot have more than Count_Type'Last elements, so
162 -- we must check the sum of the combined lengths. Note that we cannot
163 -- simply add the lengths, because of the possibility of overflow.
165 if LN > Count_Type'Last - RN then
166 raise Constraint_Error with "new length is out of range";
169 -- It is now safe compute the length of the new vector.
173 -- The second constraint is that the new Last index value cannot
174 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
175 -- Count_Type'Base as the type for intermediate values.
177 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
179 -- We perform a two-part test. First we determine whether the
180 -- computed Last value lies in the base range of the type, and then
181 -- determine whether it lies in the range of the index (sub)type.
183 -- Last must satisfy this relation:
184 -- First + Length - 1 <= Last
186 -- First - 1 <= Last - Length
187 -- Which can rewrite as:
188 -- No_Index <= Last - Length
190 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
191 raise Constraint_Error with "new length is out of range";
194 -- We now know that the computed value of Last is within the base
195 -- range of the type, so it is safe to compute its value:
197 Last := No_Index + Index_Type'Base (N);
199 -- Finally we test whether the value is within the range of the
200 -- generic actual index subtype:
202 if Last > Index_Type'Last then
203 raise Constraint_Error with "new length is out of range";
206 elsif Index_Type'First <= 0 then
208 -- Here we can compute Last directly, in the normal way. We know that
209 -- No_Index is less than 0, so there is no danger of overflow when
210 -- adding the (positive) value of length.
212 J := Count_Type'Base (No_Index) + N; -- Last
214 if J > Count_Type'Base (Index_Type'Last) then
215 raise Constraint_Error with "new length is out of range";
218 -- We know that the computed value (having type Count_Type) of Last
219 -- is within the range of the generic actual index subtype, so it is
220 -- safe to convert to Index_Type:
222 Last := Index_Type'Base (J);
225 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
226 -- must test the length indirectly (by working backwards from the
227 -- largest possible value of Last), in order to prevent overflow.
229 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
231 if J < Count_Type'Base (No_Index) then
232 raise Constraint_Error with "new length is out of range";
235 -- We have determined that the result length would not create a Last
236 -- index value outside of the range of Index_Type, so we can now
237 -- safely compute its value.
239 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
243 LE : Elements_Array renames
244 Left.Elements.EA (Index_Type'First .. Left.Last);
246 RE : Elements_Array renames
247 Right.Elements.EA (Index_Type'First .. Right.Last);
249 Elements : Elements_Access := new Elements_Type (Last);
251 I : Index_Type'Base := No_Index;
254 -- Elements of an indefinite vector are allocated, so we cannot use
255 -- simple slice assignment to give a value to our result. Hence we
256 -- must walk the array of each vector parameter, and copy each source
257 -- element individually.
259 for LI in LE'Range loop
263 if LE (LI) /= null then
264 Elements.EA (I) := new Element_Type'(LE (LI).all);
269 for J in Index_Type'First .. I - 1 loop
270 Free (Elements.EA (J));
278 for RI in RE'Range loop
282 if RE (RI) /= null then
283 Elements.EA (I) := new Element_Type'(RE (RI).all);
288 for J in Index_Type'First .. I - 1 loop
289 Free (Elements.EA (J));
297 return (Controlled with Elements, Last, 0, 0);
301 function "&" (Left : Vector; Right : Element_Type) return Vector is
303 -- We decide that the capacity of the result is the sum of the lengths
304 -- of the parameters. We could decide to make it larger, but we have no
305 -- basis for knowing how much larger, so we just allocate the minimum
306 -- amount of storage.
308 -- Here we handle the easy case first, when the vector parameter (Left)
311 if Left.Is_Empty then
313 Elements : Elements_Access := new Elements_Type (Index_Type'First);
317 Elements.EA (Index_Type'First) := new Element_Type'(Right);
324 return (Controlled with Elements, Index_Type'First, 0, 0);
328 -- The vector parameter is not empty, so we must compute the length of
329 -- the result vector and its last index, but in such a way that overflow
330 -- is avoided. We must satisfy two constraints: the new length cannot
331 -- exceed Count_Type'Last, and the new Last index cannot exceed
334 if Left.Length = Count_Type'Last then
335 raise Constraint_Error with "new length is out of range";
338 if Left.Last >= Index_Type'Last then
339 raise Constraint_Error with "new length is out of range";
343 Last : constant Index_Type := Left.Last + 1;
345 LE : Elements_Array renames
346 Left.Elements.EA (Index_Type'First .. Left.Last);
348 Elements : Elements_Access :=
349 new Elements_Type (Last);
352 for I in LE'Range loop
354 if LE (I) /= null then
355 Elements.EA (I) := new Element_Type'(LE (I).all);
360 for J in Index_Type'First .. I - 1 loop
361 Free (Elements.EA (J));
370 Elements.EA (Last) := new Element_Type'(Right);
374 for J in Index_Type'First .. Last - 1 loop
375 Free (Elements.EA (J));
382 return (Controlled with Elements, Last, 0, 0);
386 function "&" (Left : Element_Type; Right : Vector) return Vector is
388 -- We decide that the capacity of the result is the sum of the lengths
389 -- of the parameters. We could decide to make it larger, but we have no
390 -- basis for knowing how much larger, so we just allocate the minimum
391 -- amount of storage.
393 -- Here we handle the easy case first, when the vector parameter (Right)
396 if Right.Is_Empty then
398 Elements : Elements_Access := new Elements_Type (Index_Type'First);
402 Elements.EA (Index_Type'First) := new Element_Type'(Left);
409 return (Controlled with Elements, Index_Type'First, 0, 0);
413 -- The vector parameter is not empty, so we must compute the length of
414 -- the result vector and its last index, but in such a way that overflow
415 -- is avoided. We must satisfy two constraints: the new length cannot
416 -- exceed Count_Type'Last, and the new Last index cannot exceed
419 if Right.Length = Count_Type'Last then
420 raise Constraint_Error with "new length is out of range";
423 if Right.Last >= Index_Type'Last then
424 raise Constraint_Error with "new length is out of range";
428 Last : constant Index_Type := Right.Last + 1;
430 RE : Elements_Array renames
431 Right.Elements.EA (Index_Type'First .. Right.Last);
433 Elements : Elements_Access :=
434 new Elements_Type (Last);
436 I : Index_Type'Base := Index_Type'First;
440 Elements.EA (I) := new Element_Type'(Left);
447 for RI in RE'Range loop
451 if RE (RI) /= null then
452 Elements.EA (I) := new Element_Type'(RE (RI).all);
457 for J in Index_Type'First .. I - 1 loop
458 Free (Elements.EA (J));
466 return (Controlled with Elements, Last, 0, 0);
470 function "&" (Left, Right : Element_Type) return Vector is
472 -- We decide that the capacity of the result is the sum of the lengths
473 -- of the parameters. We could decide to make it larger, but we have no
474 -- basis for knowing how much larger, so we just allocate the minimum
475 -- amount of storage.
477 -- We must compute the length of the result vector and its last index,
478 -- but in such a way that overflow is avoided. We must satisfy two
479 -- constraints: the new length cannot exceed Count_Type'Last (here, we
480 -- know that that condition is satisfied), and the new Last index cannot
481 -- exceed Index_Type'Last.
483 if Index_Type'First >= Index_Type'Last then
484 raise Constraint_Error with "new length is out of range";
488 Last : constant Index_Type := Index_Type'First + 1;
489 Elements : Elements_Access := new Elements_Type (Last);
493 Elements.EA (Index_Type'First) := new Element_Type'(Left);
501 Elements.EA (Last) := new Element_Type'(Right);
504 Free (Elements.EA (Index_Type'First));
509 return (Controlled with Elements, Last, 0, 0);
517 overriding function "=" (Left, Right : Vector) return Boolean is
519 if Left'Address = Right'Address then
523 if Left.Last /= Right.Last then
527 for J in Index_Type'First .. Left.Last loop
528 if Left.Elements.EA (J) = null then
529 if Right.Elements.EA (J) /= null then
533 elsif Right.Elements.EA (J) = null then
536 elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then
548 procedure Adjust (Container : in out Vector) is
550 if Container.Last = No_Index then
551 Container.Elements := null;
556 L : constant Index_Type := Container.Last;
557 E : Elements_Array renames
558 Container.Elements.EA (Index_Type'First .. L);
561 Container.Elements := null;
562 Container.Last := No_Index;
566 Container.Elements := new Elements_Type (L);
568 for I in E'Range loop
569 if E (I) /= null then
570 Container.Elements.EA (I) := new Element_Type'(E (I).all);
582 procedure Append (Container : in out Vector; New_Item : Vector) is
584 if Is_Empty (New_Item) then
588 if Container.Last = Index_Type'Last then
589 raise Constraint_Error with "vector is already at its maximum length";
599 (Container : in out Vector;
600 New_Item : Element_Type;
601 Count : Count_Type := 1)
608 if Container.Last = Index_Type'Last then
609 raise Constraint_Error with "vector is already at its maximum length";
623 function Capacity (Container : Vector) return Count_Type is
625 if Container.Elements = null then
629 return Container.Elements.EA'Length;
636 procedure Clear (Container : in out Vector) is
638 if Container.Busy > 0 then
639 raise Program_Error with
640 "attempt to tamper with cursors (vector is busy)";
643 while Container.Last >= Index_Type'First loop
645 X : Element_Access := Container.Elements.EA (Container.Last);
647 Container.Elements.EA (Container.Last) := null;
648 Container.Last := Container.Last - 1;
654 ------------------------
655 -- Constant_Reference --
656 ------------------------
658 function Constant_Reference
660 Position : Cursor) return Constant_Reference_Type
663 pragma Unreferenced (Container);
665 if Position.Container = null then
666 raise Constraint_Error with "Position cursor has no element";
669 if Position.Index > Position.Container.Last then
670 raise Constraint_Error with "Position cursor is out of range";
674 (Element => Position.Container.Elements.EA (Position.Index).all'Access);
675 end Constant_Reference;
677 function Constant_Reference
679 Position : Index_Type) return Constant_Reference_Type
682 if (Position) > Container.Last then
683 raise Constraint_Error with "Index is out of range";
686 return (Element => Container.Elements.EA (Position).all'Access);
687 end Constant_Reference;
695 Item : Element_Type) return Boolean
698 return Find_Index (Container, Item) /= No_Index;
706 (Container : in out Vector;
707 Index : Extended_Index;
708 Count : Count_Type := 1)
710 Old_Last : constant Index_Type'Base := Container.Last;
711 New_Last : Index_Type'Base;
712 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
713 J : Index_Type'Base; -- first index of items that slide down
716 -- Delete removes items from the vector, the number of which is the
717 -- minimum of the specified Count and the items (if any) that exist from
718 -- Index to Container.Last. There are no constraints on the specified
719 -- value of Count (it can be larger than what's available at this
720 -- position in the vector, for example), but there are constraints on
721 -- the allowed values of the Index.
723 -- As a precondition on the generic actual Index_Type, the base type
724 -- must include Index_Type'Pred (Index_Type'First); this is the value
725 -- that Container.Last assumes when the vector is empty. However, we do
726 -- not allow that as the value for Index when specifying which items
727 -- should be deleted, so we must manually check. (That the user is
728 -- allowed to specify the value at all here is a consequence of the
729 -- declaration of the Extended_Index subtype, which includes the values
730 -- in the base range that immediately precede and immediately follow the
731 -- values in the Index_Type.)
733 if Index < Index_Type'First then
734 raise Constraint_Error with "Index is out of range (too small)";
737 -- We do allow a value greater than Container.Last to be specified as
738 -- the Index, but only if it's immediately greater. This allows the
739 -- corner case of deleting no items from the back end of the vector to
740 -- be treated as a no-op. (It is assumed that specifying an index value
741 -- greater than Last + 1 indicates some deeper flaw in the caller's
742 -- algorithm, so that case is treated as a proper error.)
744 if Index > Old_Last then
745 if Index > Old_Last + 1 then
746 raise Constraint_Error with "Index is out of range (too large)";
752 -- Here and elsewhere we treat deleting 0 items from the container as a
753 -- no-op, even when the container is busy, so we simply return.
759 -- The internal elements array isn't guaranteed to exist unless we have
760 -- elements, so we handle that case here in order to avoid having to
761 -- check it later. (Note that an empty vector can never be busy, so
762 -- there's no semantic harm in returning early.)
764 if Container.Is_Empty then
768 -- The tampering bits exist to prevent an item from being deleted (or
769 -- otherwise harmfully manipulated) while it is being visited. Query,
770 -- Update, and Iterate increment the busy count on entry, and decrement
771 -- the count on exit. Delete checks the count to determine whether it is
772 -- being called while the associated callback procedure is executing.
774 if Container.Busy > 0 then
775 raise Program_Error with
776 "attempt to tamper with cursors (vector is busy)";
779 -- We first calculate what's available for deletion starting at
780 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
781 -- Count_Type'Base as the type for intermediate values. (See function
782 -- Length for more information.)
784 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
785 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
788 Count2 := Count_Type'Base (Old_Last - Index + 1);
791 -- If the number of elements requested (Count) for deletion is equal to
792 -- (or greater than) the number of elements available (Count2) for
793 -- deletion beginning at Index, then everything from Index to
794 -- Container.Last is deleted (this is equivalent to Delete_Last).
796 if Count >= Count2 then
797 -- Elements in an indefinite vector are allocated, so we must iterate
798 -- over the loop and deallocate elements one-at-a-time. We work from
799 -- back to front, deleting the last element during each pass, in
800 -- order to gracefully handle deallocation failures.
803 EA : Elements_Array renames Container.Elements.EA;
806 while Container.Last >= Index loop
808 K : constant Index_Type := Container.Last;
809 X : Element_Access := EA (K);
812 -- We first isolate the element we're deleting, removing it
813 -- from the vector before we attempt to deallocate it, in
814 -- case the deallocation fails.
817 Container.Last := K - 1;
819 -- Container invariants have been restored, so it is now
820 -- safe to attempt to deallocate the element.
830 -- There are some elements that aren't being deleted (the requested
831 -- count was less than the available count), so we must slide them down
832 -- to Index. We first calculate the index values of the respective array
833 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
834 -- type for intermediate calculations. For the elements that slide down,
835 -- index value New_Last is the last index value of their new home, and
836 -- index value J is the first index of their old home.
838 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
839 New_Last := Old_Last - Index_Type'Base (Count);
840 J := Index + Index_Type'Base (Count);
843 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
844 J := Index_Type'Base (Count_Type'Base (Index) + Count);
847 -- The internal elements array isn't guaranteed to exist unless we have
848 -- elements, but we have that guarantee here because we know we have
849 -- elements to slide. The array index values for each slice have
850 -- already been determined, so what remains to be done is to first
851 -- deallocate the elements that are being deleted, and then slide down
852 -- to Index the elements that aren't being deleted.
855 EA : Elements_Array renames Container.Elements.EA;
858 -- Before we can slide down the elements that aren't being deleted,
859 -- we need to deallocate the elements that are being deleted.
861 for K in Index .. J - 1 loop
863 X : Element_Access := EA (K);
866 -- First we remove the element we're about to deallocate from
867 -- the vector, in case the deallocation fails, in order to
868 -- preserve representation invariants.
872 -- The element has been removed from the vector, so it is now
873 -- safe to attempt to deallocate it.
879 EA (Index .. New_Last) := EA (J .. Old_Last);
880 Container.Last := New_Last;
885 (Container : in out Vector;
886 Position : in out Cursor;
887 Count : Count_Type := 1)
889 pragma Warnings (Off, Position);
892 if Position.Container = null then
893 raise Constraint_Error with "Position cursor has no element";
896 if Position.Container /= Container'Unrestricted_Access then
897 raise Program_Error with "Position cursor denotes wrong container";
900 if Position.Index > Container.Last then
901 raise Program_Error with "Position index is out of range";
904 Delete (Container, Position.Index, Count);
906 Position := No_Element;
913 procedure Delete_First
914 (Container : in out Vector;
915 Count : Count_Type := 1)
922 if Count >= Length (Container) then
927 Delete (Container, Index_Type'First, Count);
934 procedure Delete_Last
935 (Container : in out Vector;
936 Count : Count_Type := 1)
939 -- It is not permitted to delete items while the container is busy (for
940 -- example, we're in the middle of a passive iteration). However, we
941 -- always treat deleting 0 items as a no-op, even when we're busy, so we
942 -- simply return without checking.
948 -- We cannot simply subsume the empty case into the loop below (the loop
949 -- would iterate 0 times), because we rename the internal array object
950 -- (which is allocated), but an empty vector isn't guaranteed to have
951 -- actually allocated an array. (Note that an empty vector can never be
952 -- busy, so there's no semantic harm in returning early here.)
954 if Container.Is_Empty then
958 -- The tampering bits exist to prevent an item from being deleted (or
959 -- otherwise harmfully manipulated) while it is being visited. Query,
960 -- Update, and Iterate increment the busy count on entry, and decrement
961 -- the count on exit. Delete_Last checks the count to determine whether
962 -- it is being called while the associated callback procedure is
965 if Container.Busy > 0 then
966 raise Program_Error with
967 "attempt to tamper with cursors (vector is busy)";
970 -- Elements in an indefinite vector are allocated, so we must iterate
971 -- over the loop and deallocate elements one-at-a-time. We work from
972 -- back to front, deleting the last element during each pass, in order
973 -- to gracefully handle deallocation failures.
976 E : Elements_Array renames Container.Elements.EA;
979 for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop
981 J : constant Index_Type := Container.Last;
982 X : Element_Access := E (J);
985 -- Note that we first isolate the element we're deleting,
986 -- removing it from the vector, before we actually deallocate
987 -- it, in order to preserve representation invariants even if
988 -- the deallocation fails.
991 Container.Last := J - 1;
993 -- Container invariants have been restored, so it is now safe
994 -- to deallocate the element.
1007 (Container : Vector;
1008 Index : Index_Type) return Element_Type
1011 if Index > Container.Last then
1012 raise Constraint_Error with "Index is out of range";
1016 EA : constant Element_Access := Container.Elements.EA (Index);
1020 raise Constraint_Error with "element is empty";
1027 function Element (Position : Cursor) return Element_Type is
1029 if Position.Container = null then
1030 raise Constraint_Error with "Position cursor has no element";
1033 if Position.Index > Position.Container.Last then
1034 raise Constraint_Error with "Position cursor is out of range";
1038 EA : constant Element_Access :=
1039 Position.Container.Elements.EA (Position.Index);
1043 raise Constraint_Error with "element is empty";
1054 procedure Finalize (Container : in out Vector) is
1056 Clear (Container); -- Checks busy-bit
1059 X : Elements_Access := Container.Elements;
1061 Container.Elements := null;
1071 (Container : Vector;
1072 Item : Element_Type;
1073 Position : Cursor := No_Element) return Cursor
1076 if Position.Container /= null then
1077 if Position.Container /= Container'Unrestricted_Access then
1078 raise Program_Error with "Position cursor denotes wrong container";
1081 if Position.Index > Container.Last then
1082 raise Program_Error with "Position index is out of range";
1086 for J in Position.Index .. Container.Last loop
1087 if Container.Elements.EA (J) /= null
1088 and then Container.Elements.EA (J).all = Item
1090 return (Container'Unchecked_Access, J);
1102 (Container : Vector;
1103 Item : Element_Type;
1104 Index : Index_Type := Index_Type'First) return Extended_Index
1107 for Indx in Index .. Container.Last loop
1108 if Container.Elements.EA (Indx) /= null
1109 and then Container.Elements.EA (Indx).all = Item
1122 function First (Container : Vector) return Cursor is
1124 if Is_Empty (Container) then
1128 return (Container'Unchecked_Access, Index_Type'First);
1131 function First (Object : Iterator) return Cursor is
1132 C : constant Cursor := (Object.Container, Index_Type'First);
1141 function First_Element (Container : Vector) return Element_Type is
1143 if Container.Last = No_Index then
1144 raise Constraint_Error with "Container is empty";
1148 EA : constant Element_Access :=
1149 Container.Elements.EA (Index_Type'First);
1153 raise Constraint_Error with "first element is empty";
1164 function First_Index (Container : Vector) return Index_Type is
1165 pragma Unreferenced (Container);
1167 return Index_Type'First;
1170 ---------------------
1171 -- Generic_Sorting --
1172 ---------------------
1174 package body Generic_Sorting is
1176 -----------------------
1177 -- Local Subprograms --
1178 -----------------------
1180 function Is_Less (L, R : Element_Access) return Boolean;
1181 pragma Inline (Is_Less);
1187 function Is_Less (L, R : Element_Access) return Boolean is
1194 return L.all < R.all;
1202 function Is_Sorted (Container : Vector) return Boolean is
1204 if Container.Last <= Index_Type'First then
1209 E : Elements_Array renames Container.Elements.EA;
1211 for I in Index_Type'First .. Container.Last - 1 loop
1212 if Is_Less (E (I + 1), E (I)) then
1225 procedure Merge (Target, Source : in out Vector) is
1226 I, J : Index_Type'Base;
1229 if Target.Last < Index_Type'First then
1230 Move (Target => Target, Source => Source);
1234 if Target'Address = Source'Address then
1238 if Source.Last < Index_Type'First then
1242 if Source.Busy > 0 then
1243 raise Program_Error with
1244 "attempt to tamper with cursors (vector is busy)";
1247 I := Target.Last; -- original value (before Set_Length)
1248 Target.Set_Length (Length (Target) + Length (Source));
1250 J := Target.Last; -- new value (after Set_Length)
1251 while Source.Last >= Index_Type'First loop
1253 (Source.Last <= Index_Type'First
1254 or else not (Is_Less
1255 (Source.Elements.EA (Source.Last),
1256 Source.Elements.EA (Source.Last - 1))));
1258 if I < Index_Type'First then
1260 Src : Elements_Array renames
1261 Source.Elements.EA (Index_Type'First .. Source.Last);
1264 Target.Elements.EA (Index_Type'First .. J) := Src;
1265 Src := (others => null);
1268 Source.Last := No_Index;
1273 (I <= Index_Type'First
1274 or else not (Is_Less
1275 (Target.Elements.EA (I),
1276 Target.Elements.EA (I - 1))));
1279 Src : Element_Access renames Source.Elements.EA (Source.Last);
1280 Tgt : Element_Access renames Target.Elements.EA (I);
1283 if Is_Less (Src, Tgt) then
1284 Target.Elements.EA (J) := Tgt;
1289 Target.Elements.EA (J) := Src;
1291 Source.Last := Source.Last - 1;
1303 procedure Sort (Container : in out Vector) is
1305 procedure Sort is new Generic_Array_Sort
1306 (Index_Type => Index_Type,
1307 Element_Type => Element_Access,
1308 Array_Type => Elements_Array,
1311 -- Start of processing for Sort
1314 if Container.Last <= Index_Type'First then
1318 if Container.Lock > 0 then
1319 raise Program_Error with
1320 "attempt to tamper with elements (vector is locked)";
1323 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1326 end Generic_Sorting;
1332 function Has_Element (Position : Cursor) return Boolean is
1334 if Position.Container = null then
1338 return Position.Index <= Position.Container.Last;
1346 (Container : in out Vector;
1347 Before : Extended_Index;
1348 New_Item : Element_Type;
1349 Count : Count_Type := 1)
1351 Old_Length : constant Count_Type := Container.Length;
1353 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1354 New_Length : Count_Type'Base; -- sum of current length and Count
1355 New_Last : Index_Type'Base; -- last index of vector after insertion
1357 Index : Index_Type'Base; -- scratch for intermediate values
1358 J : Count_Type'Base; -- scratch
1360 New_Capacity : Count_Type'Base; -- length of new, expanded array
1361 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1362 Dst : Elements_Access; -- new, expanded internal array
1365 -- As a precondition on the generic actual Index_Type, the base type
1366 -- must include Index_Type'Pred (Index_Type'First); this is the value
1367 -- that Container.Last assumes when the vector is empty. However, we do
1368 -- not allow that as the value for Index when specifying where the new
1369 -- items should be inserted, so we must manually check. (That the user
1370 -- is allowed to specify the value at all here is a consequence of the
1371 -- declaration of the Extended_Index subtype, which includes the values
1372 -- in the base range that immediately precede and immediately follow the
1373 -- values in the Index_Type.)
1375 if Before < Index_Type'First then
1376 raise Constraint_Error with
1377 "Before index is out of range (too small)";
1380 -- We do allow a value greater than Container.Last to be specified as
1381 -- the Index, but only if it's immediately greater. This allows for the
1382 -- case of appending items to the back end of the vector. (It is assumed
1383 -- that specifying an index value greater than Last + 1 indicates some
1384 -- deeper flaw in the caller's algorithm, so that case is treated as a
1387 if Before > Container.Last
1388 and then Before > Container.Last + 1
1390 raise Constraint_Error with
1391 "Before index is out of range (too large)";
1394 -- We treat inserting 0 items into the container as a no-op, even when
1395 -- the container is busy, so we simply return.
1401 -- There are two constraints we need to satisfy. The first constraint is
1402 -- that a container cannot have more than Count_Type'Last elements, so
1403 -- we must check the sum of the current length and the insertion count.
1404 -- Note that we cannot simply add these values, because of the
1405 -- possibility of overflow.
1407 if Old_Length > Count_Type'Last - Count then
1408 raise Constraint_Error with "Count is out of range";
1411 -- It is now safe compute the length of the new vector, without fear of
1414 New_Length := Old_Length + Count;
1416 -- The second constraint is that the new Last index value cannot exceed
1417 -- Index_Type'Last. In each branch below, we calculate the maximum
1418 -- length (computed from the range of values in Index_Type), and then
1419 -- compare the new length to the maximum length. If the new length is
1420 -- acceptable, then we compute the new last index from that.
1422 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1424 -- We have to handle the case when there might be more values in the
1425 -- range of Index_Type than in the range of Count_Type.
1427 if Index_Type'First <= 0 then
1429 -- We know that No_Index (the same as Index_Type'First - 1) is
1430 -- less than 0, so it is safe to compute the following sum without
1431 -- fear of overflow.
1433 Index := No_Index + Index_Type'Base (Count_Type'Last);
1435 if Index <= Index_Type'Last then
1437 -- We have determined that range of Index_Type has at least as
1438 -- many values as in Count_Type, so Count_Type'Last is the
1439 -- maximum number of items that are allowed.
1441 Max_Length := Count_Type'Last;
1444 -- The range of Index_Type has fewer values than in Count_Type,
1445 -- so the maximum number of items is computed from the range of
1448 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1452 -- No_Index is equal or greater than 0, so we can safely compute
1453 -- the difference without fear of overflow (which we would have to
1454 -- worry about if No_Index were less than 0, but that case is
1457 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1460 elsif Index_Type'First <= 0 then
1462 -- We know that No_Index (the same as Index_Type'First - 1) is less
1463 -- than 0, so it is safe to compute the following sum without fear of
1466 J := Count_Type'Base (No_Index) + Count_Type'Last;
1468 if J <= Count_Type'Base (Index_Type'Last) then
1470 -- We have determined that range of Index_Type has at least as
1471 -- many values as in Count_Type, so Count_Type'Last is the maximum
1472 -- number of items that are allowed.
1474 Max_Length := Count_Type'Last;
1477 -- The range of Index_Type has fewer values than Count_Type does,
1478 -- so the maximum number of items is computed from the range of
1482 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1486 -- No_Index is equal or greater than 0, so we can safely compute the
1487 -- difference without fear of overflow (which we would have to worry
1488 -- about if No_Index were less than 0, but that case is handled
1492 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1495 -- We have just computed the maximum length (number of items). We must
1496 -- now compare the requested length to the maximum length, as we do not
1497 -- allow a vector expand beyond the maximum (because that would create
1498 -- an internal array with a last index value greater than
1499 -- Index_Type'Last, with no way to index those elements).
1501 if New_Length > Max_Length then
1502 raise Constraint_Error with "Count is out of range";
1505 -- New_Last is the last index value of the items in the container after
1506 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1507 -- compute its value from the New_Length.
1509 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1510 New_Last := No_Index + Index_Type'Base (New_Length);
1513 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1516 if Container.Elements = null then
1517 pragma Assert (Container.Last = No_Index);
1519 -- This is the simplest case, with which we must always begin: we're
1520 -- inserting items into an empty vector that hasn't allocated an
1521 -- internal array yet. Note that we don't need to check the busy bit
1522 -- here, because an empty container cannot be busy.
1524 -- In an indefinite vector, elements are allocated individually, and
1525 -- stored as access values on the internal array (the length of which
1526 -- represents the vector "capacity"), which is separately allocated.
1528 Container.Elements := new Elements_Type (New_Last);
1530 -- The element backbone has been successfully allocated, so now we
1531 -- allocate the elements.
1533 for Idx in Container.Elements.EA'Range loop
1535 -- In order to preserve container invariants, we always attempt
1536 -- the element allocation first, before setting the Last index
1537 -- value, in case the allocation fails (either because there is no
1538 -- storage available, or because element initialization fails).
1540 Container.Elements.EA (Idx) := new Element_Type'(New_Item);
1542 -- The allocation of the element succeeded, so it is now safe to
1543 -- update the Last index, restoring container invariants.
1545 Container.Last := Idx;
1551 -- The tampering bits exist to prevent an item from being harmfully
1552 -- manipulated while it is being visited. Query, Update, and Iterate
1553 -- increment the busy count on entry, and decrement the count on
1554 -- exit. Insert checks the count to determine whether it is being called
1555 -- while the associated callback procedure is executing.
1557 if Container.Busy > 0 then
1558 raise Program_Error with
1559 "attempt to tamper with cursors (vector is busy)";
1562 if New_Length <= Container.Elements.EA'Length then
1564 -- In this case, we're inserting elements into a vector that has
1565 -- already allocated an internal array, and the existing array has
1566 -- enough unused storage for the new items.
1569 E : Elements_Array renames Container.Elements.EA;
1570 K : Index_Type'Base;
1573 if Before > Container.Last then
1575 -- The new items are being appended to the vector, so no
1576 -- sliding of existing elements is required.
1578 for Idx in Before .. New_Last loop
1580 -- In order to preserve container invariants, we always
1581 -- attempt the element allocation first, before setting the
1582 -- Last index value, in case the allocation fails (either
1583 -- because there is no storage available, or because element
1584 -- initialization fails).
1586 E (Idx) := new Element_Type'(New_Item);
1588 -- The allocation of the element succeeded, so it is now
1589 -- safe to update the Last index, restoring container
1592 Container.Last := Idx;
1596 -- The new items are being inserted before some existing
1597 -- elements, so we must slide the existing elements up to their
1598 -- new home. We use the wider of Index_Type'Base and
1599 -- Count_Type'Base as the type for intermediate index values.
1601 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1602 Index := Before + Index_Type'Base (Count);
1604 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1607 -- The new items are being inserted in the middle of the array,
1608 -- in the range [Before, Index). Copy the existing elements to
1609 -- the end of the array, to make room for the new items.
1611 E (Index .. New_Last) := E (Before .. Container.Last);
1612 Container.Last := New_Last;
1614 -- We have copied the existing items up to the end of the
1615 -- array, to make room for the new items in the middle of
1616 -- the array. Now we actually allocate the new items.
1618 -- Note: initialize K outside loop to make it clear that
1619 -- K always has a value if the exception handler triggers.
1623 while K < Index loop
1624 E (K) := new Element_Type'(New_Item);
1631 -- Values in the range [Before, K) were successfully
1632 -- allocated, but values in the range [K, Index) are
1633 -- stale (these array positions contain copies of the
1634 -- old items, that did not get assigned a new item,
1635 -- because the allocation failed). We must finish what
1636 -- we started by clearing out all of the stale values,
1637 -- leaving a "hole" in the middle of the array.
1639 E (K .. Index - 1) := (others => null);
1648 -- In this case, we're inserting elements into a vector that has already
1649 -- allocated an internal array, but the existing array does not have
1650 -- enough storage, so we must allocate a new, longer array. In order to
1651 -- guarantee that the amortized insertion cost is O(1), we always
1652 -- allocate an array whose length is some power-of-two factor of the
1653 -- current array length. (The new array cannot have a length less than
1654 -- the New_Length of the container, but its last index value cannot be
1655 -- greater than Index_Type'Last.)
1657 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1658 while New_Capacity < New_Length loop
1659 if New_Capacity > Count_Type'Last / 2 then
1660 New_Capacity := Count_Type'Last;
1664 New_Capacity := 2 * New_Capacity;
1667 if New_Capacity > Max_Length then
1669 -- We have reached the limit of capacity, so no further expansion
1670 -- will occur. (This is not a problem, as there is never a need to
1671 -- have more capacity than the maximum container length.)
1673 New_Capacity := Max_Length;
1676 -- We have computed the length of the new internal array (and this is
1677 -- what "vector capacity" means), so use that to compute its last index.
1679 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1680 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1684 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1687 -- Now we allocate the new, longer internal array. If the allocation
1688 -- fails, we have not changed any container state, so no side-effect
1689 -- will occur as a result of propagating the exception.
1691 Dst := new Elements_Type (Dst_Last);
1693 -- We have our new internal array. All that needs to be done now is to
1694 -- copy the existing items (if any) from the old array (the "source"
1695 -- array) to the new array (the "destination" array), and then
1696 -- deallocate the old array.
1699 Src : Elements_Access := Container.Elements;
1702 Dst.EA (Index_Type'First .. Before - 1) :=
1703 Src.EA (Index_Type'First .. Before - 1);
1705 if Before > Container.Last then
1707 -- The new items are being appended to the vector, so no
1708 -- sliding of existing elements is required.
1710 -- We have copied the elements from to the old, source array to
1711 -- the new, destination array, so we can now deallocate the old
1714 Container.Elements := Dst;
1717 -- Now we append the new items.
1719 for Idx in Before .. New_Last loop
1721 -- In order to preserve container invariants, we always
1722 -- attempt the element allocation first, before setting the
1723 -- Last index value, in case the allocation fails (either
1724 -- because there is no storage available, or because element
1725 -- initialization fails).
1727 Dst.EA (Idx) := new Element_Type'(New_Item);
1729 -- The allocation of the element succeeded, so it is now safe
1730 -- to update the Last index, restoring container invariants.
1732 Container.Last := Idx;
1736 -- The new items are being inserted before some existing elements,
1737 -- so we must slide the existing elements up to their new home.
1739 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1740 Index := Before + Index_Type'Base (Count);
1743 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1746 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1748 -- We have copied the elements from to the old, source array to
1749 -- the new, destination array, so we can now deallocate the old
1752 Container.Elements := Dst;
1753 Container.Last := New_Last;
1756 -- The new array has a range in the middle containing null access
1757 -- values. We now fill in that partition of the array with the new
1760 for Idx in Before .. Index - 1 loop
1762 -- Note that container invariants have already been satisfied
1763 -- (in particular, the Last index value of the vector has
1764 -- already been updated), so if this allocation fails we simply
1765 -- let it propagate.
1767 Dst.EA (Idx) := new Element_Type'(New_Item);
1774 (Container : in out Vector;
1775 Before : Extended_Index;
1778 N : constant Count_Type := Length (New_Item);
1779 J : Index_Type'Base;
1782 -- Use Insert_Space to create the "hole" (the destination slice) into
1783 -- which we copy the source items.
1785 Insert_Space (Container, Before, Count => N);
1789 -- There's nothing else to do here (vetting of parameters was
1790 -- performed already in Insert_Space), so we simply return.
1795 if Container'Address /= New_Item'Address then
1797 -- This is the simple case. New_Item denotes an object different
1798 -- from Container, so there's nothing special we need to do to copy
1799 -- the source items to their destination, because all of the source
1800 -- items are contiguous.
1803 subtype Src_Index_Subtype is Index_Type'Base range
1804 Index_Type'First .. New_Item.Last;
1806 Src : Elements_Array renames
1807 New_Item.Elements.EA (Src_Index_Subtype);
1809 Dst : Elements_Array renames Container.Elements.EA;
1811 Dst_Index : Index_Type'Base;
1814 Dst_Index := Before - 1;
1815 for Src_Index in Src'Range loop
1816 Dst_Index := Dst_Index + 1;
1818 if Src (Src_Index) /= null then
1819 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1827 -- New_Item denotes the same object as Container, so an insertion has
1828 -- potentially split the source items. The first source slice is
1829 -- [Index_Type'First, Before), and the second source slice is
1830 -- [J, Container.Last], where index value J is the first index of the
1831 -- second slice. (J gets computed below, but only after we have
1832 -- determined that the second source slice is non-empty.) The
1833 -- destination slice is always the range [Before, J). We perform the
1834 -- copy in two steps, using each of the two slices of the source items.
1837 L : constant Index_Type'Base := Before - 1;
1839 subtype Src_Index_Subtype is Index_Type'Base range
1840 Index_Type'First .. L;
1842 Src : Elements_Array renames
1843 Container.Elements.EA (Src_Index_Subtype);
1845 Dst : Elements_Array renames Container.Elements.EA;
1847 Dst_Index : Index_Type'Base;
1850 -- We first copy the source items that precede the space we
1851 -- inserted. (If Before equals Index_Type'First, then this first
1852 -- source slice will be empty, which is harmless.)
1854 Dst_Index := Before - 1;
1855 for Src_Index in Src'Range loop
1856 Dst_Index := Dst_Index + 1;
1858 if Src (Src_Index) /= null then
1859 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1863 if Src'Length = N then
1865 -- The new items were effectively appended to the container, so we
1866 -- have already copied all of the items that need to be copied.
1867 -- We return early here, even though the source slice below is
1868 -- empty (so the assignment would be harmless), because we want to
1869 -- avoid computing J, which will overflow if J is greater than
1870 -- Index_Type'Base'Last.
1876 -- Index value J is the first index of the second source slice. (It is
1877 -- also 1 greater than the last index of the destination slice.) Note:
1878 -- avoid computing J if J is greater than Index_Type'Base'Last, in order
1879 -- to avoid overflow. Prevent that by returning early above, immediately
1880 -- after copying the first slice of the source, and determining that
1881 -- this second slice of the source is empty.
1883 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1884 J := Before + Index_Type'Base (N);
1887 J := Index_Type'Base (Count_Type'Base (Before) + N);
1891 subtype Src_Index_Subtype is Index_Type'Base range
1892 J .. Container.Last;
1894 Src : Elements_Array renames
1895 Container.Elements.EA (Src_Index_Subtype);
1897 Dst : Elements_Array renames Container.Elements.EA;
1899 Dst_Index : Index_Type'Base;
1902 -- We next copy the source items that follow the space we inserted.
1903 -- Index value Dst_Index is the first index of that portion of the
1904 -- destination that receives this slice of the source. (For the
1905 -- reasons given above, this slice is guaranteed to be non-empty.)
1907 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1908 Dst_Index := J - Index_Type'Base (Src'Length);
1911 Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length);
1914 for Src_Index in Src'Range loop
1915 if Src (Src_Index) /= null then
1916 Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all);
1919 Dst_Index := Dst_Index + 1;
1925 (Container : in out Vector;
1929 Index : Index_Type'Base;
1932 if Before.Container /= null
1933 and then Before.Container /= Container'Unchecked_Access
1935 raise Program_Error with "Before cursor denotes wrong container";
1938 if Is_Empty (New_Item) then
1942 if Before.Container = null
1943 or else Before.Index > Container.Last
1945 if Container.Last = Index_Type'Last then
1946 raise Constraint_Error with
1947 "vector is already at its maximum length";
1950 Index := Container.Last + 1;
1953 Index := Before.Index;
1956 Insert (Container, Index, New_Item);
1960 (Container : in out Vector;
1963 Position : out Cursor)
1965 Index : Index_Type'Base;
1968 if Before.Container /= null
1969 and then Before.Container /= Vector_Access'(Container'Unchecked_Access)
1971 raise Program_Error with "Before cursor denotes wrong container";
1974 if Is_Empty (New_Item) then
1975 if Before.Container = null
1976 or else Before.Index > Container.Last
1978 Position := No_Element;
1980 Position := (Container'Unchecked_Access, Before.Index);
1986 if Before.Container = null
1987 or else Before.Index > Container.Last
1989 if Container.Last = Index_Type'Last then
1990 raise Constraint_Error with
1991 "vector is already at its maximum length";
1994 Index := Container.Last + 1;
1997 Index := Before.Index;
2000 Insert (Container, Index, New_Item);
2002 Position := Cursor'(Container'Unchecked_Access, Index);
2006 (Container : in out Vector;
2008 New_Item : Element_Type;
2009 Count : Count_Type := 1)
2011 Index : Index_Type'Base;
2014 if Before.Container /= null
2015 and then Before.Container /= Container'Unchecked_Access
2017 raise Program_Error with "Before cursor denotes wrong container";
2024 if Before.Container = null
2025 or else Before.Index > Container.Last
2027 if Container.Last = Index_Type'Last then
2028 raise Constraint_Error with
2029 "vector is already at its maximum length";
2032 Index := Container.Last + 1;
2035 Index := Before.Index;
2038 Insert (Container, Index, New_Item, Count);
2042 (Container : in out Vector;
2044 New_Item : Element_Type;
2045 Position : out Cursor;
2046 Count : Count_Type := 1)
2048 Index : Index_Type'Base;
2051 if Before.Container /= null
2052 and then Before.Container /= Container'Unchecked_Access
2054 raise Program_Error with "Before cursor denotes wrong container";
2058 if Before.Container = null
2059 or else Before.Index > Container.Last
2061 Position := No_Element;
2063 Position := (Container'Unchecked_Access, Before.Index);
2069 if Before.Container = null
2070 or else Before.Index > Container.Last
2072 if Container.Last = Index_Type'Last then
2073 raise Constraint_Error with
2074 "vector is already at its maximum length";
2077 Index := Container.Last + 1;
2080 Index := Before.Index;
2083 Insert (Container, Index, New_Item, Count);
2085 Position := (Container'Unchecked_Access, Index);
2092 procedure Insert_Space
2093 (Container : in out Vector;
2094 Before : Extended_Index;
2095 Count : Count_Type := 1)
2097 Old_Length : constant Count_Type := Container.Length;
2099 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2100 New_Length : Count_Type'Base; -- sum of current length and Count
2101 New_Last : Index_Type'Base; -- last index of vector after insertion
2103 Index : Index_Type'Base; -- scratch for intermediate values
2104 J : Count_Type'Base; -- scratch
2106 New_Capacity : Count_Type'Base; -- length of new, expanded array
2107 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2108 Dst : Elements_Access; -- new, expanded internal array
2111 -- As a precondition on the generic actual Index_Type, the base type
2112 -- must include Index_Type'Pred (Index_Type'First); this is the value
2113 -- that Container.Last assumes when the vector is empty. However, we do
2114 -- not allow that as the value for Index when specifying where the new
2115 -- items should be inserted, so we must manually check. (That the user
2116 -- is allowed to specify the value at all here is a consequence of the
2117 -- declaration of the Extended_Index subtype, which includes the values
2118 -- in the base range that immediately precede and immediately follow the
2119 -- values in the Index_Type.)
2121 if Before < Index_Type'First then
2122 raise Constraint_Error with
2123 "Before index is out of range (too small)";
2126 -- We do allow a value greater than Container.Last to be specified as
2127 -- the Index, but only if it's immediately greater. This allows for the
2128 -- case of appending items to the back end of the vector. (It is assumed
2129 -- that specifying an index value greater than Last + 1 indicates some
2130 -- deeper flaw in the caller's algorithm, so that case is treated as a
2133 if Before > Container.Last
2134 and then Before > Container.Last + 1
2136 raise Constraint_Error with
2137 "Before index is out of range (too large)";
2140 -- We treat inserting 0 items into the container as a no-op, even when
2141 -- the container is busy, so we simply return.
2147 -- There are two constraints we need to satisfy. The first constraint is
2148 -- that a container cannot have more than Count_Type'Last elements, so
2149 -- we must check the sum of the current length and the insertion
2150 -- count. Note that we cannot simply add these values, because of the
2151 -- possibility of overflow.
2153 if Old_Length > Count_Type'Last - Count then
2154 raise Constraint_Error with "Count is out of range";
2157 -- It is now safe compute the length of the new vector, without fear of
2160 New_Length := Old_Length + Count;
2162 -- The second constraint is that the new Last index value cannot exceed
2163 -- Index_Type'Last. In each branch below, we calculate the maximum
2164 -- length (computed from the range of values in Index_Type), and then
2165 -- compare the new length to the maximum length. If the new length is
2166 -- acceptable, then we compute the new last index from that.
2168 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2169 -- We have to handle the case when there might be more values in the
2170 -- range of Index_Type than in the range of Count_Type.
2172 if Index_Type'First <= 0 then
2174 -- We know that No_Index (the same as Index_Type'First - 1) is
2175 -- less than 0, so it is safe to compute the following sum without
2176 -- fear of overflow.
2178 Index := No_Index + Index_Type'Base (Count_Type'Last);
2180 if Index <= Index_Type'Last then
2182 -- We have determined that range of Index_Type has at least as
2183 -- many values as in Count_Type, so Count_Type'Last is the
2184 -- maximum number of items that are allowed.
2186 Max_Length := Count_Type'Last;
2189 -- The range of Index_Type has fewer values than in Count_Type,
2190 -- so the maximum number of items is computed from the range of
2193 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2197 -- No_Index is equal or greater than 0, so we can safely compute
2198 -- the difference without fear of overflow (which we would have to
2199 -- worry about if No_Index were less than 0, but that case is
2202 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2205 elsif Index_Type'First <= 0 then
2207 -- We know that No_Index (the same as Index_Type'First - 1) is less
2208 -- than 0, so it is safe to compute the following sum without fear of
2211 J := Count_Type'Base (No_Index) + Count_Type'Last;
2213 if J <= Count_Type'Base (Index_Type'Last) then
2215 -- We have determined that range of Index_Type has at least as
2216 -- many values as in Count_Type, so Count_Type'Last is the maximum
2217 -- number of items that are allowed.
2219 Max_Length := Count_Type'Last;
2222 -- The range of Index_Type has fewer values than Count_Type does,
2223 -- so the maximum number of items is computed from the range of
2227 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2231 -- No_Index is equal or greater than 0, so we can safely compute the
2232 -- difference without fear of overflow (which we would have to worry
2233 -- about if No_Index were less than 0, but that case is handled
2237 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2240 -- We have just computed the maximum length (number of items). We must
2241 -- now compare the requested length to the maximum length, as we do not
2242 -- allow a vector expand beyond the maximum (because that would create
2243 -- an internal array with a last index value greater than
2244 -- Index_Type'Last, with no way to index those elements).
2246 if New_Length > Max_Length then
2247 raise Constraint_Error with "Count is out of range";
2250 -- New_Last is the last index value of the items in the container after
2251 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2252 -- compute its value from the New_Length.
2254 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2255 New_Last := No_Index + Index_Type'Base (New_Length);
2258 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2261 if Container.Elements = null then
2262 pragma Assert (Container.Last = No_Index);
2264 -- This is the simplest case, with which we must always begin: we're
2265 -- inserting items into an empty vector that hasn't allocated an
2266 -- internal array yet. Note that we don't need to check the busy bit
2267 -- here, because an empty container cannot be busy.
2269 -- In an indefinite vector, elements are allocated individually, and
2270 -- stored as access values on the internal array (the length of which
2271 -- represents the vector "capacity"), which is separately allocated.
2272 -- We have no elements here (because we're inserting "space"), so all
2273 -- we need to do is allocate the backbone.
2275 Container.Elements := new Elements_Type (New_Last);
2276 Container.Last := New_Last;
2281 -- The tampering bits exist to prevent an item from being harmfully
2282 -- manipulated while it is being visited. Query, Update, and Iterate
2283 -- increment the busy count on entry, and decrement the count on exit.
2284 -- Insert checks the count to determine whether it is being called while
2285 -- the associated callback procedure is executing.
2287 if Container.Busy > 0 then
2288 raise Program_Error with
2289 "attempt to tamper with cursors (vector is busy)";
2292 if New_Length <= Container.Elements.EA'Length then
2293 -- In this case, we're inserting elements into a vector that has
2294 -- already allocated an internal array, and the existing array has
2295 -- enough unused storage for the new items.
2298 E : Elements_Array renames Container.Elements.EA;
2301 if Before <= Container.Last then
2303 -- The new space is being inserted before some existing
2304 -- elements, so we must slide the existing elements up to their
2305 -- new home. We use the wider of Index_Type'Base and
2306 -- Count_Type'Base as the type for intermediate index values.
2308 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2309 Index := Before + Index_Type'Base (Count);
2312 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2315 E (Index .. New_Last) := E (Before .. Container.Last);
2316 E (Before .. Index - 1) := (others => null);
2320 Container.Last := New_Last;
2324 -- In this case, we're inserting elements into a vector that has already
2325 -- allocated an internal array, but the existing array does not have
2326 -- enough storage, so we must allocate a new, longer array. In order to
2327 -- guarantee that the amortized insertion cost is O(1), we always
2328 -- allocate an array whose length is some power-of-two factor of the
2329 -- current array length. (The new array cannot have a length less than
2330 -- the New_Length of the container, but its last index value cannot be
2331 -- greater than Index_Type'Last.)
2333 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2334 while New_Capacity < New_Length loop
2335 if New_Capacity > Count_Type'Last / 2 then
2336 New_Capacity := Count_Type'Last;
2340 New_Capacity := 2 * New_Capacity;
2343 if New_Capacity > Max_Length then
2345 -- We have reached the limit of capacity, so no further expansion
2346 -- will occur. (This is not a problem, as there is never a need to
2347 -- have more capacity than the maximum container length.)
2349 New_Capacity := Max_Length;
2352 -- We have computed the length of the new internal array (and this is
2353 -- what "vector capacity" means), so use that to compute its last index.
2355 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2356 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2360 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2363 -- Now we allocate the new, longer internal array. If the allocation
2364 -- fails, we have not changed any container state, so no side-effect
2365 -- will occur as a result of propagating the exception.
2367 Dst := new Elements_Type (Dst_Last);
2369 -- We have our new internal array. All that needs to be done now is to
2370 -- copy the existing items (if any) from the old array (the "source"
2371 -- array) to the new array (the "destination" array), and then
2372 -- deallocate the old array.
2375 Src : Elements_Access := Container.Elements;
2378 Dst.EA (Index_Type'First .. Before - 1) :=
2379 Src.EA (Index_Type'First .. Before - 1);
2381 if Before <= Container.Last then
2383 -- The new items are being inserted before some existing elements,
2384 -- so we must slide the existing elements up to their new home.
2386 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2387 Index := Before + Index_Type'Base (Count);
2390 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2393 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
2396 -- We have copied the elements from to the old, source array to the
2397 -- new, destination array, so we can now restore invariants, and
2398 -- deallocate the old array.
2400 Container.Elements := Dst;
2401 Container.Last := New_Last;
2406 procedure Insert_Space
2407 (Container : in out Vector;
2409 Position : out Cursor;
2410 Count : Count_Type := 1)
2412 Index : Index_Type'Base;
2415 if Before.Container /= null
2416 and then Before.Container /= Container'Unchecked_Access
2418 raise Program_Error with "Before cursor denotes wrong container";
2422 if Before.Container = null
2423 or else Before.Index > Container.Last
2425 Position := No_Element;
2427 Position := (Container'Unchecked_Access, Before.Index);
2433 if Before.Container = null
2434 or else Before.Index > Container.Last
2436 if Container.Last = Index_Type'Last then
2437 raise Constraint_Error with
2438 "vector is already at its maximum length";
2441 Index := Container.Last + 1;
2444 Index := Before.Index;
2447 Insert_Space (Container, Index, Count);
2449 Position := Cursor'(Container'Unchecked_Access, Index);
2456 function Is_Empty (Container : Vector) return Boolean is
2458 return Container.Last < Index_Type'First;
2466 (Container : Vector;
2467 Process : not null access procedure (Position : Cursor))
2469 V : Vector renames Container'Unrestricted_Access.all;
2470 B : Natural renames V.Busy;
2476 for Indx in Index_Type'First .. Container.Last loop
2477 Process (Cursor'(Container'Unchecked_Access, Indx));
2488 function Iterate (Container : Vector)
2489 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2491 It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
2497 (Container : Vector;
2499 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2501 It : constant Iterator :=
2502 (Container'Unchecked_Access, Start.Index);
2511 function Last (Container : Vector) return Cursor is
2513 if Is_Empty (Container) then
2517 return (Container'Unchecked_Access, Container.Last);
2520 function Last (Object : Iterator) return Cursor is
2521 C : constant Cursor := (Object.Container, Object.Container.Last);
2530 function Last_Element (Container : Vector) return Element_Type is
2532 if Container.Last = No_Index then
2533 raise Constraint_Error with "Container is empty";
2537 EA : constant Element_Access :=
2538 Container.Elements.EA (Container.Last);
2542 raise Constraint_Error with "last element is empty";
2553 function Last_Index (Container : Vector) return Extended_Index is
2555 return Container.Last;
2562 function Length (Container : Vector) return Count_Type is
2563 L : constant Index_Type'Base := Container.Last;
2564 F : constant Index_Type := Index_Type'First;
2567 -- The base range of the index type (Index_Type'Base) might not include
2568 -- all values for length (Count_Type). Contrariwise, the index type
2569 -- might include values outside the range of length. Hence we use
2570 -- whatever type is wider for intermediate values when calculating
2571 -- length. Note that no matter what the index type is, the maximum
2572 -- length to which a vector is allowed to grow is always the minimum
2573 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2575 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2576 -- to have a base range of -128 .. 127, but the corresponding vector
2577 -- would have lengths in the range 0 .. 255. In this case we would need
2578 -- to use Count_Type'Base for intermediate values.
2580 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2581 -- vector would have a maximum length of 10, but the index values lie
2582 -- outside the range of Count_Type (which is only 32 bits). In this
2583 -- case we would need to use Index_Type'Base for intermediate values.
2585 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2586 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2588 return Count_Type (L - F + 1);
2597 (Target : in out Vector;
2598 Source : in out Vector)
2601 if Target'Address = Source'Address then
2605 if Source.Busy > 0 then
2606 raise Program_Error with
2607 "attempt to tamper with cursors (Source is busy)";
2610 Clear (Target); -- Checks busy-bit
2613 Target_Elements : constant Elements_Access := Target.Elements;
2615 Target.Elements := Source.Elements;
2616 Source.Elements := Target_Elements;
2619 Target.Last := Source.Last;
2620 Source.Last := No_Index;
2627 function Next (Position : Cursor) return Cursor is
2629 if Position.Container = null then
2633 if Position.Index < Position.Container.Last then
2634 return (Position.Container, Position.Index + 1);
2640 function Next (Object : Iterator; Position : Cursor) return Cursor is
2642 if Position.Index = Object.Container.Last then
2645 return (Object.Container, Position.Index + 1);
2649 procedure Next (Position : in out Cursor) is
2651 if Position.Container = null then
2655 if Position.Index < Position.Container.Last then
2656 Position.Index := Position.Index + 1;
2658 Position := No_Element;
2666 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2668 Insert (Container, Index_Type'First, New_Item);
2672 (Container : in out Vector;
2673 New_Item : Element_Type;
2674 Count : Count_Type := 1)
2687 procedure Previous (Position : in out Cursor) is
2689 if Position.Container = null then
2693 if Position.Index > Index_Type'First then
2694 Position.Index := Position.Index - 1;
2696 Position := No_Element;
2700 function Previous (Position : Cursor) return Cursor is
2702 if Position.Container = null then
2706 if Position.Index > Index_Type'First then
2707 return (Position.Container, Position.Index - 1);
2713 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2715 if Position.Index > Index_Type'First then
2716 return (Object.Container, Position.Index - 1);
2726 procedure Query_Element
2727 (Container : Vector;
2729 Process : not null access procedure (Element : Element_Type))
2731 V : Vector renames Container'Unrestricted_Access.all;
2732 B : Natural renames V.Busy;
2733 L : Natural renames V.Lock;
2736 if Index > Container.Last then
2737 raise Constraint_Error with "Index is out of range";
2740 if V.Elements.EA (Index) = null then
2741 raise Constraint_Error with "element is null";
2748 Process (V.Elements.EA (Index).all);
2760 procedure Query_Element
2762 Process : not null access procedure (Element : Element_Type))
2765 if Position.Container = null then
2766 raise Constraint_Error with "Position cursor has no element";
2769 Query_Element (Position.Container.all, Position.Index, Process);
2777 (Stream : not null access Root_Stream_Type'Class;
2778 Container : out Vector)
2780 Length : Count_Type'Base;
2781 Last : Index_Type'Base := Index_Type'Pred (Index_Type'First);
2788 Count_Type'Base'Read (Stream, Length);
2790 if Length > Capacity (Container) then
2791 Reserve_Capacity (Container, Capacity => Length);
2794 for J in Count_Type range 1 .. Length loop
2797 Boolean'Read (Stream, B);
2800 Container.Elements.EA (Last) :=
2801 new Element_Type'(Element_Type'Input (Stream));
2804 Container.Last := Last;
2809 (Stream : not null access Root_Stream_Type'Class;
2810 Position : out Cursor)
2813 raise Program_Error with "attempt to stream vector cursor";
2817 (Stream : not null access Root_Stream_Type'Class;
2818 Item : out Reference_Type)
2821 raise Program_Error with "attempt to stream reference";
2825 (Stream : not null access Root_Stream_Type'Class;
2826 Item : out Constant_Reference_Type)
2829 raise Program_Error with "attempt to stream reference";
2837 (Container : Vector;
2838 Position : Cursor) return Reference_Type
2841 pragma Unreferenced (Container);
2843 if Position.Container = null then
2844 raise Constraint_Error with "Position cursor has no element";
2847 if Position.Index > Position.Container.Last then
2848 raise Constraint_Error with "Position cursor is out of range";
2853 Position.Container.Elements.EA (Position.Index).all'Access);
2857 (Container : Vector;
2858 Position : Index_Type) return Reference_Type
2861 if Position > Container.Last then
2862 raise Constraint_Error with "Index is out of range";
2865 return (Element => Container.Elements.EA (Position).all'Access);
2868 ---------------------
2869 -- Replace_Element --
2870 ---------------------
2872 procedure Replace_Element
2873 (Container : in out Vector;
2875 New_Item : Element_Type)
2878 if Index > Container.Last then
2879 raise Constraint_Error with "Index is out of range";
2882 if Container.Lock > 0 then
2883 raise Program_Error with
2884 "attempt to tamper with elements (vector is locked)";
2888 X : Element_Access := Container.Elements.EA (Index);
2890 Container.Elements.EA (Index) := new Element_Type'(New_Item);
2893 end Replace_Element;
2895 procedure Replace_Element
2896 (Container : in out Vector;
2898 New_Item : Element_Type)
2901 if Position.Container = null then
2902 raise Constraint_Error with "Position cursor has no element";
2905 if Position.Container /= Container'Unrestricted_Access then
2906 raise Program_Error with "Position cursor denotes wrong container";
2909 if Position.Index > Container.Last then
2910 raise Constraint_Error with "Position cursor is out of range";
2913 if Container.Lock > 0 then
2914 raise Program_Error with
2915 "attempt to tamper with elements (vector is locked)";
2919 X : Element_Access := Container.Elements.EA (Position.Index);
2921 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
2924 end Replace_Element;
2926 ----------------------
2927 -- Reserve_Capacity --
2928 ----------------------
2930 procedure Reserve_Capacity
2931 (Container : in out Vector;
2932 Capacity : Count_Type)
2934 N : constant Count_Type := Length (Container);
2936 Index : Count_Type'Base;
2937 Last : Index_Type'Base;
2940 -- Reserve_Capacity can be used to either expand the storage available
2941 -- for elements (this would be its typical use, in anticipation of
2942 -- future insertion), or to trim back storage. In the latter case,
2943 -- storage can only be trimmed back to the limit of the container
2944 -- length. Note that Reserve_Capacity neither deletes (active) elements
2945 -- nor inserts elements; it only affects container capacity, never
2946 -- container length.
2948 if Capacity = 0 then
2950 -- This is a request to trim back storage, to the minimum amount
2951 -- possible given the current state of the container.
2955 -- The container is empty, so in this unique case we can
2956 -- deallocate the entire internal array. Note that an empty
2957 -- container can never be busy, so there's no need to check the
2961 X : Elements_Access := Container.Elements;
2964 -- First we remove the internal array from the container, to
2965 -- handle the case when the deallocation raises an exception
2966 -- (although that's unlikely, since this is simply an array of
2967 -- access values, all of which are null).
2969 Container.Elements := null;
2971 -- Container invariants have been restored, so it is now safe
2972 -- to attempt to deallocate the internal array.
2977 elsif N < Container.Elements.EA'Length then
2979 -- The container is not empty, and the current length is less than
2980 -- the current capacity, so there's storage available to trim. In
2981 -- this case, we allocate a new internal array having a length
2982 -- that exactly matches the number of items in the
2983 -- container. (Reserve_Capacity does not delete active elements,
2984 -- so this is the best we can do with respect to minimizing
2987 if Container.Busy > 0 then
2988 raise Program_Error with
2989 "attempt to tamper with cursors (vector is busy)";
2993 subtype Array_Index_Subtype is Index_Type'Base range
2994 Index_Type'First .. Container.Last;
2996 Src : Elements_Array renames
2997 Container.Elements.EA (Array_Index_Subtype);
2999 X : Elements_Access := Container.Elements;
3002 -- Although we have isolated the old internal array that we're
3003 -- going to deallocate, we don't deallocate it until we have
3004 -- successfully allocated a new one. If there is an exception
3005 -- during allocation (because there is not enough storage), we
3006 -- let it propagate without causing any side-effect.
3008 Container.Elements := new Elements_Type'(Container.Last, Src);
3010 -- We have successfully allocated a new internal array (with a
3011 -- smaller length than the old one, and containing a copy of
3012 -- just the active elements in the container), so we can
3013 -- deallocate the old array.
3022 -- Reserve_Capacity can be used to expand the storage available for
3023 -- elements, but we do not let the capacity grow beyond the number of
3024 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3025 -- to refer to the elements with index values greater than
3026 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3027 -- the Last index value of the new internal array, in a way that avoids
3028 -- any possibility of overflow.
3030 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3032 -- We perform a two-part test. First we determine whether the
3033 -- computed Last value lies in the base range of the type, and then
3034 -- determine whether it lies in the range of the index (sub)type.
3036 -- Last must satisfy this relation:
3037 -- First + Length - 1 <= Last
3038 -- We regroup terms:
3039 -- First - 1 <= Last - Length
3040 -- Which can rewrite as:
3041 -- No_Index <= Last - Length
3043 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
3044 raise Constraint_Error with "Capacity is out of range";
3047 -- We now know that the computed value of Last is within the base
3048 -- range of the type, so it is safe to compute its value:
3050 Last := No_Index + Index_Type'Base (Capacity);
3052 -- Finally we test whether the value is within the range of the
3053 -- generic actual index subtype:
3055 if Last > Index_Type'Last then
3056 raise Constraint_Error with "Capacity is out of range";
3059 elsif Index_Type'First <= 0 then
3061 -- Here we can compute Last directly, in the normal way. We know that
3062 -- No_Index is less than 0, so there is no danger of overflow when
3063 -- adding the (positive) value of Capacity.
3065 Index := Count_Type'Base (No_Index) + Capacity; -- Last
3067 if Index > Count_Type'Base (Index_Type'Last) then
3068 raise Constraint_Error with "Capacity is out of range";
3071 -- We know that the computed value (having type Count_Type) of Last
3072 -- is within the range of the generic actual index subtype, so it is
3073 -- safe to convert to Index_Type:
3075 Last := Index_Type'Base (Index);
3078 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3079 -- must test the length indirectly (by working backwards from the
3080 -- largest possible value of Last), in order to prevent overflow.
3082 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
3084 if Index < Count_Type'Base (No_Index) then
3085 raise Constraint_Error with "Capacity is out of range";
3088 -- We have determined that the value of Capacity would not create a
3089 -- Last index value outside of the range of Index_Type, so we can now
3090 -- safely compute its value.
3092 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
3095 -- The requested capacity is non-zero, but we don't know yet whether
3096 -- this is a request for expansion or contraction of storage.
3098 if Container.Elements = null then
3100 -- The container is empty (it doesn't even have an internal array),
3101 -- so this represents a request to allocate storage having the given
3104 Container.Elements := new Elements_Type (Last);
3108 if Capacity <= N then
3110 -- This is a request to trim back storage, but only to the limit of
3111 -- what's already in the container. (Reserve_Capacity never deletes
3112 -- active elements, it only reclaims excess storage.)
3114 if N < Container.Elements.EA'Length then
3116 -- The container is not empty (because the requested capacity is
3117 -- positive, and less than or equal to the container length), and
3118 -- the current length is less than the current capacity, so there
3119 -- is storage available to trim. In this case, we allocate a new
3120 -- internal array having a length that exactly matches the number
3121 -- of items in the container.
3123 if Container.Busy > 0 then
3124 raise Program_Error with
3125 "attempt to tamper with cursors (vector is busy)";
3129 subtype Array_Index_Subtype is Index_Type'Base range
3130 Index_Type'First .. Container.Last;
3132 Src : Elements_Array renames
3133 Container.Elements.EA (Array_Index_Subtype);
3135 X : Elements_Access := Container.Elements;
3138 -- Although we have isolated the old internal array that we're
3139 -- going to deallocate, we don't deallocate it until we have
3140 -- successfully allocated a new one. If there is an exception
3141 -- during allocation (because there is not enough storage), we
3142 -- let it propagate without causing any side-effect.
3144 Container.Elements := new Elements_Type'(Container.Last, Src);
3146 -- We have successfully allocated a new internal array (with a
3147 -- smaller length than the old one, and containing a copy of
3148 -- just the active elements in the container), so it is now
3149 -- safe to deallocate the old array.
3158 -- The requested capacity is larger than the container length (the
3159 -- number of active elements). Whether this represents a request for
3160 -- expansion or contraction of the current capacity depends on what the
3161 -- current capacity is.
3163 if Capacity = Container.Elements.EA'Length then
3165 -- The requested capacity matches the existing capacity, so there's
3166 -- nothing to do here. We treat this case as a no-op, and simply
3167 -- return without checking the busy bit.
3172 -- There is a change in the capacity of a non-empty container, so a new
3173 -- internal array will be allocated. (The length of the new internal
3174 -- array could be less or greater than the old internal array. We know
3175 -- only that the length of the new internal array is greater than the
3176 -- number of active elements in the container.) We must check whether
3177 -- the container is busy before doing anything else.
3179 if Container.Busy > 0 then
3180 raise Program_Error with
3181 "attempt to tamper with cursors (vector is busy)";
3184 -- We now allocate a new internal array, having a length different from
3185 -- its current value.
3188 X : Elements_Access := Container.Elements;
3190 subtype Index_Subtype is Index_Type'Base range
3191 Index_Type'First .. Container.Last;
3194 -- We now allocate a new internal array, having a length different
3195 -- from its current value.
3197 Container.Elements := new Elements_Type (Last);
3199 -- We have successfully allocated the new internal array, so now we
3200 -- move the existing elements from the existing the old internal
3201 -- array onto the new one. Note that we're just copying access
3202 -- values, to this should not raise any exceptions.
3204 Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype);
3206 -- We have moved the elements from the old internal array, so now we
3207 -- can deallocate it.
3211 end Reserve_Capacity;
3213 ----------------------
3214 -- Reverse_Elements --
3215 ----------------------
3217 procedure Reverse_Elements (Container : in out Vector) is
3219 if Container.Length <= 1 then
3223 if Container.Lock > 0 then
3224 raise Program_Error with
3225 "attempt to tamper with elements (vector is locked)";
3231 E : Elements_Array renames Container.Elements.EA;
3234 I := Index_Type'First;
3235 J := Container.Last;
3238 EI : constant Element_Access := E (I);
3249 end Reverse_Elements;
3255 function Reverse_Find
3256 (Container : Vector;
3257 Item : Element_Type;
3258 Position : Cursor := No_Element) return Cursor
3260 Last : Index_Type'Base;
3263 if Position.Container /= null
3264 and then Position.Container /= Container'Unchecked_Access
3266 raise Program_Error with "Position cursor denotes wrong container";
3269 if Position.Container = null
3270 or else Position.Index > Container.Last
3272 Last := Container.Last;
3274 Last := Position.Index;
3277 for Indx in reverse Index_Type'First .. Last loop
3278 if Container.Elements.EA (Indx) /= null
3279 and then Container.Elements.EA (Indx).all = Item
3281 return (Container'Unchecked_Access, Indx);
3288 ------------------------
3289 -- Reverse_Find_Index --
3290 ------------------------
3292 function Reverse_Find_Index
3293 (Container : Vector;
3294 Item : Element_Type;
3295 Index : Index_Type := Index_Type'Last) return Extended_Index
3297 Last : constant Index_Type'Base :=
3298 (if Index > Container.Last then Container.Last else Index);
3300 for Indx in reverse Index_Type'First .. Last loop
3301 if Container.Elements.EA (Indx) /= null
3302 and then Container.Elements.EA (Indx).all = Item
3309 end Reverse_Find_Index;
3311 ---------------------
3312 -- Reverse_Iterate --
3313 ---------------------
3315 procedure Reverse_Iterate
3316 (Container : Vector;
3317 Process : not null access procedure (Position : Cursor))
3319 V : Vector renames Container'Unrestricted_Access.all;
3320 B : Natural renames V.Busy;
3326 for Indx in reverse Index_Type'First .. Container.Last loop
3327 Process (Cursor'(Container'Unchecked_Access, Indx));
3336 end Reverse_Iterate;
3342 procedure Set_Length
3343 (Container : in out Vector;
3344 Length : Count_Type)
3346 Count : constant Count_Type'Base := Container.Length - Length;
3349 -- Set_Length allows the user to set the length explicitly, instead of
3350 -- implicitly as a side-effect of deletion or insertion. If the
3351 -- requested length is less than the current length, this is equivalent
3352 -- to deleting items from the back end of the vector. If the requested
3353 -- length is greater than the current length, then this is equivalent to
3354 -- inserting "space" (nonce items) at the end.
3357 Container.Delete_Last (Count);
3359 elsif Container.Last >= Index_Type'Last then
3360 raise Constraint_Error with "vector is already at its maximum length";
3363 Container.Insert_Space (Container.Last + 1, -Count);
3372 (Container : in out Vector;
3376 if I > Container.Last then
3377 raise Constraint_Error with "I index is out of range";
3380 if J > Container.Last then
3381 raise Constraint_Error with "J index is out of range";
3388 if Container.Lock > 0 then
3389 raise Program_Error with
3390 "attempt to tamper with elements (vector is locked)";
3394 EI : Element_Access renames Container.Elements.EA (I);
3395 EJ : Element_Access renames Container.Elements.EA (J);
3397 EI_Copy : constant Element_Access := EI;
3406 (Container : in out Vector;
3410 if I.Container = null then
3411 raise Constraint_Error with "I cursor has no element";
3414 if J.Container = null then
3415 raise Constraint_Error with "J cursor has no element";
3418 if I.Container /= Container'Unrestricted_Access then
3419 raise Program_Error with "I cursor denotes wrong container";
3422 if J.Container /= Container'Unrestricted_Access then
3423 raise Program_Error with "J cursor denotes wrong container";
3426 Swap (Container, I.Index, J.Index);
3434 (Container : Vector;
3435 Index : Extended_Index) return Cursor
3438 if Index not in Index_Type'First .. Container.Last then
3442 return Cursor'(Container'Unchecked_Access, Index);
3449 function To_Index (Position : Cursor) return Extended_Index is
3451 if Position.Container = null then
3455 if Position.Index <= Position.Container.Last then
3456 return Position.Index;
3466 function To_Vector (Length : Count_Type) return Vector is
3467 Index : Count_Type'Base;
3468 Last : Index_Type'Base;
3469 Elements : Elements_Access;
3473 return Empty_Vector;
3476 -- We create a vector object with a capacity that matches the specified
3477 -- Length, but we do not allow the vector capacity (the length of the
3478 -- internal array) to exceed the number of values in Index_Type'Range
3479 -- (otherwise, there would be no way to refer to those components via an
3480 -- index). We must therefore check whether the specified Length would
3481 -- create a Last index value greater than Index_Type'Last.
3483 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3485 -- We perform a two-part test. First we determine whether the
3486 -- computed Last value lies in the base range of the type, and then
3487 -- determine whether it lies in the range of the index (sub)type.
3489 -- Last must satisfy this relation:
3490 -- First + Length - 1 <= Last
3491 -- We regroup terms:
3492 -- First - 1 <= Last - Length
3493 -- Which can rewrite as:
3494 -- No_Index <= Last - Length
3496 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3497 raise Constraint_Error with "Length is out of range";
3500 -- We now know that the computed value of Last is within the base
3501 -- range of the type, so it is safe to compute its value:
3503 Last := No_Index + Index_Type'Base (Length);
3505 -- Finally we test whether the value is within the range of the
3506 -- generic actual index subtype:
3508 if Last > Index_Type'Last then
3509 raise Constraint_Error with "Length is out of range";
3512 elsif Index_Type'First <= 0 then
3514 -- Here we can compute Last directly, in the normal way. We know that
3515 -- No_Index is less than 0, so there is no danger of overflow when
3516 -- adding the (positive) value of Length.
3518 Index := Count_Type'Base (No_Index) + Length; -- Last
3520 if Index > Count_Type'Base (Index_Type'Last) then
3521 raise Constraint_Error with "Length is out of range";
3524 -- We know that the computed value (having type Count_Type) of Last
3525 -- is within the range of the generic actual index subtype, so it is
3526 -- safe to convert to Index_Type:
3528 Last := Index_Type'Base (Index);
3531 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3532 -- must test the length indirectly (by working backwards from the
3533 -- largest possible value of Last), in order to prevent overflow.
3535 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3537 if Index < Count_Type'Base (No_Index) then
3538 raise Constraint_Error with "Length is out of range";
3541 -- We have determined that the value of Length would not create a
3542 -- Last index value outside of the range of Index_Type, so we can now
3543 -- safely compute its value.
3545 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3548 Elements := new Elements_Type (Last);
3550 return Vector'(Controlled with Elements, Last, 0, 0);
3554 (New_Item : Element_Type;
3555 Length : Count_Type) return Vector
3557 Index : Count_Type'Base;
3558 Last : Index_Type'Base;
3559 Elements : Elements_Access;
3563 return Empty_Vector;
3566 -- We create a vector object with a capacity that matches the specified
3567 -- Length, but we do not allow the vector capacity (the length of the
3568 -- internal array) to exceed the number of values in Index_Type'Range
3569 -- (otherwise, there would be no way to refer to those components via an
3570 -- index). We must therefore check whether the specified Length would
3571 -- create a Last index value greater than Index_Type'Last.
3573 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3575 -- We perform a two-part test. First we determine whether the
3576 -- computed Last value lies in the base range of the type, and then
3577 -- determine whether it lies in the range of the index (sub)type.
3579 -- Last must satisfy this relation:
3580 -- First + Length - 1 <= Last
3581 -- We regroup terms:
3582 -- First - 1 <= Last - Length
3583 -- Which can rewrite as:
3584 -- No_Index <= Last - Length
3586 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3587 raise Constraint_Error with "Length is out of range";
3590 -- We now know that the computed value of Last is within the base
3591 -- range of the type, so it is safe to compute its value:
3593 Last := No_Index + Index_Type'Base (Length);
3595 -- Finally we test whether the value is within the range of the
3596 -- generic actual index subtype:
3598 if Last > Index_Type'Last then
3599 raise Constraint_Error with "Length is out of range";
3602 elsif Index_Type'First <= 0 then
3604 -- Here we can compute Last directly, in the normal way. We know that
3605 -- No_Index is less than 0, so there is no danger of overflow when
3606 -- adding the (positive) value of Length.
3608 Index := Count_Type'Base (No_Index) + Length; -- Last
3610 if Index > Count_Type'Base (Index_Type'Last) then
3611 raise Constraint_Error with "Length is out of range";
3614 -- We know that the computed value (having type Count_Type) of Last
3615 -- is within the range of the generic actual index subtype, so it is
3616 -- safe to convert to Index_Type:
3618 Last := Index_Type'Base (Index);
3621 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3622 -- must test the length indirectly (by working backwards from the
3623 -- largest possible value of Last), in order to prevent overflow.
3625 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3627 if Index < Count_Type'Base (No_Index) then
3628 raise Constraint_Error with "Length is out of range";
3631 -- We have determined that the value of Length would not create a
3632 -- Last index value outside of the range of Index_Type, so we can now
3633 -- safely compute its value.
3635 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3638 Elements := new Elements_Type (Last);
3640 -- We use Last as the index of the loop used to populate the internal
3641 -- array with items. In general, we prefer to initialize the loop index
3642 -- immediately prior to entering the loop. However, Last is also used in
3643 -- the exception handler (to reclaim elements that have been allocated,
3644 -- before propagating the exception), and the initialization of Last
3645 -- after entering the block containing the handler confuses some static
3646 -- analysis tools, with respect to whether Last has been properly
3647 -- initialized when the handler executes. So here we initialize our loop
3648 -- variable earlier than we prefer, before entering the block, so there
3651 Last := Index_Type'First;
3655 Elements.EA (Last) := new Element_Type'(New_Item);
3656 exit when Last = Elements.Last;
3662 for J in Index_Type'First .. Last - 1 loop
3663 Free (Elements.EA (J));
3670 return (Controlled with Elements, Last, 0, 0);
3673 --------------------
3674 -- Update_Element --
3675 --------------------
3677 procedure Update_Element
3678 (Container : in out Vector;
3680 Process : not null access procedure (Element : in out Element_Type))
3682 B : Natural renames Container.Busy;
3683 L : Natural renames Container.Lock;
3686 if Index > Container.Last then
3687 raise Constraint_Error with "Index is out of range";
3690 if Container.Elements.EA (Index) = null then
3691 raise Constraint_Error with "element is null";
3698 Process (Container.Elements.EA (Index).all);
3710 procedure Update_Element
3711 (Container : in out Vector;
3713 Process : not null access procedure (Element : in out Element_Type))
3716 if Position.Container = null then
3717 raise Constraint_Error with "Position cursor has no element";
3720 if Position.Container /= Container'Unrestricted_Access then
3721 raise Program_Error with "Position cursor denotes wrong container";
3724 Update_Element (Container, Position.Index, Process);
3732 (Stream : not null access Root_Stream_Type'Class;
3735 N : constant Count_Type := Length (Container);
3738 Count_Type'Base'Write (Stream, N);
3745 E : Elements_Array renames Container.Elements.EA;
3748 for Indx in Index_Type'First .. Container.Last loop
3749 if E (Indx) = null then
3750 Boolean'Write (Stream, False);
3752 Boolean'Write (Stream, True);
3753 Element_Type'Output (Stream, E (Indx).all);
3760 (Stream : not null access Root_Stream_Type'Class;
3764 raise Program_Error with "attempt to stream vector cursor";
3768 (Stream : not null access Root_Stream_Type'Class;
3769 Item : Reference_Type)
3772 raise Program_Error with "attempt to stream reference";
3776 (Stream : not null access Root_Stream_Type'Class;
3777 Item : Constant_Reference_Type)
3780 raise Program_Error with "attempt to stream reference";
3783 end Ada.Containers.Indefinite_Vectors;