1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . V E C T O R S --
9 -- Copyright (C) 2004-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;
33 with System; use type System.Address;
35 package body Ada.Containers.Vectors is
38 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
40 type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with
42 Container : Vector_Access;
46 overriding function First (Object : Iterator) return Cursor;
47 overriding function Last (Object : Iterator) return Cursor;
48 overriding function Next
50 Position : Cursor) return Cursor;
51 overriding function Previous
53 Position : Cursor) return Cursor;
59 function "&" (Left, Right : Vector) return Vector is
60 LN : constant Count_Type := Length (Left);
61 RN : constant Count_Type := Length (Right);
62 N : Count_Type'Base; -- length of result
63 J : Count_Type'Base; -- for computing intermediate index values
64 Last : Index_Type'Base; -- Last index of result
67 -- We decide that the capacity of the result is the sum of the lengths
68 -- of the vector parameters. We could decide to make it larger, but we
69 -- have no basis for knowing how much larger, so we just allocate the
70 -- minimum amount of storage.
72 -- Here we handle the easy cases first, when one of the vector
73 -- parameters is empty. (We say "easy" because there's nothing to
74 -- compute, that can potentially overflow.)
82 RE : Elements_Array renames
83 Right.Elements.EA (Index_Type'First .. Right.Last);
85 Elements : constant Elements_Access :=
86 new Elements_Type'(Right.Last, RE);
89 return (Controlled with Elements, Right.Last, 0, 0);
95 LE : Elements_Array renames
96 Left.Elements.EA (Index_Type'First .. Left.Last);
98 Elements : constant Elements_Access :=
99 new Elements_Type'(Left.Last, LE);
102 return (Controlled with Elements, Left.Last, 0, 0);
107 -- Neither of the vector parameters is empty, so must compute the length
108 -- of the result vector and its last index. (This is the harder case,
109 -- because our computations must avoid overflow.)
111 -- There are two constraints we need to satisfy. The first constraint is
112 -- that a container cannot have more than Count_Type'Last elements, so
113 -- we must check the sum of the combined lengths. Note that we cannot
114 -- simply add the lengths, because of the possibility of overflow.
116 if LN > Count_Type'Last - RN then
117 raise Constraint_Error with "new length is out of range";
120 -- It is now safe compute the length of the new vector, without fear of
125 -- The second constraint is that the new Last index value cannot
126 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
127 -- Count_Type'Base as the type for intermediate values.
129 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
131 -- We perform a two-part test. First we determine whether the
132 -- computed Last value lies in the base range of the type, and then
133 -- determine whether it lies in the range of the index (sub)type.
135 -- Last must satisfy this relation:
136 -- First + Length - 1 <= Last
138 -- First - 1 <= Last - Length
139 -- Which can rewrite as:
140 -- No_Index <= Last - Length
142 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
143 raise Constraint_Error with "new length is out of range";
146 -- We now know that the computed value of Last is within the base
147 -- range of the type, so it is safe to compute its value:
149 Last := No_Index + Index_Type'Base (N);
151 -- Finally we test whether the value is within the range of the
152 -- generic actual index subtype:
154 if Last > Index_Type'Last then
155 raise Constraint_Error with "new length is out of range";
158 elsif Index_Type'First <= 0 then
160 -- Here we can compute Last directly, in the normal way. We know that
161 -- No_Index is less than 0, so there is no danger of overflow when
162 -- adding the (positive) value of length.
164 J := Count_Type'Base (No_Index) + N; -- Last
166 if J > Count_Type'Base (Index_Type'Last) then
167 raise Constraint_Error with "new length is out of range";
170 -- We know that the computed value (having type Count_Type) of Last
171 -- is within the range of the generic actual index subtype, so it is
172 -- safe to convert to Index_Type:
174 Last := Index_Type'Base (J);
177 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
178 -- must test the length indirectly (by working backwards from the
179 -- largest possible value of Last), in order to prevent overflow.
181 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
183 if J < Count_Type'Base (No_Index) then
184 raise Constraint_Error with "new length is out of range";
187 -- We have determined that the result length would not create a Last
188 -- index value outside of the range of Index_Type, so we can now
189 -- safely compute its value.
191 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
195 LE : Elements_Array renames
196 Left.Elements.EA (Index_Type'First .. Left.Last);
198 RE : Elements_Array renames
199 Right.Elements.EA (Index_Type'First .. Right.Last);
201 Elements : constant Elements_Access :=
202 new Elements_Type'(Last, LE & RE);
205 return (Controlled with Elements, Last, 0, 0);
209 function "&" (Left : Vector; Right : Element_Type) return Vector is
211 -- We decide that the capacity of the result is the sum of the lengths
212 -- of the parameters. We could decide to make it larger, but we have no
213 -- basis for knowing how much larger, so we just allocate the minimum
214 -- amount of storage.
216 -- Handle easy case first, when the vector parameter (Left) is empty
218 if Left.Is_Empty then
220 Elements : constant Elements_Access :=
222 (Last => Index_Type'First,
223 EA => (others => Right));
226 return (Controlled with Elements, Index_Type'First, 0, 0);
230 -- The vector parameter is not empty, so we must compute the length of
231 -- the result vector and its last index, but in such a way that overflow
232 -- is avoided. We must satisfy two constraints: the new length cannot
233 -- exceed Count_Type'Last, and the new Last index cannot exceed
236 if Left.Length = Count_Type'Last then
237 raise Constraint_Error with "new length is out of range";
240 if Left.Last >= Index_Type'Last then
241 raise Constraint_Error with "new length is out of range";
245 Last : constant Index_Type := Left.Last + 1;
247 LE : Elements_Array renames
248 Left.Elements.EA (Index_Type'First .. Left.Last);
250 Elements : constant Elements_Access :=
251 new Elements_Type'(Last => Last, EA => LE & Right);
254 return (Controlled with Elements, Last, 0, 0);
258 function "&" (Left : Element_Type; Right : Vector) return Vector is
260 -- We decide that the capacity of the result is the sum of the lengths
261 -- of the parameters. We could decide to make it larger, but we have no
262 -- basis for knowing how much larger, so we just allocate the minimum
263 -- amount of storage.
265 -- Handle easy case first, when the vector parameter (Right) is empty
267 if Right.Is_Empty then
269 Elements : constant Elements_Access :=
271 (Last => Index_Type'First,
272 EA => (others => Left));
275 return (Controlled with Elements, Index_Type'First, 0, 0);
279 -- The vector parameter is not empty, so we must compute the length of
280 -- the result vector and its last index, but in such a way that overflow
281 -- is avoided. We must satisfy two constraints: the new length cannot
282 -- exceed Count_Type'Last, and the new Last index cannot exceed
285 if Right.Length = Count_Type'Last then
286 raise Constraint_Error with "new length is out of range";
289 if Right.Last >= Index_Type'Last then
290 raise Constraint_Error with "new length is out of range";
294 Last : constant Index_Type := Right.Last + 1;
296 RE : Elements_Array renames
297 Right.Elements.EA (Index_Type'First .. Right.Last);
299 Elements : constant Elements_Access :=
305 return (Controlled with Elements, Last, 0, 0);
309 function "&" (Left, Right : Element_Type) return Vector is
311 -- We decide that the capacity of the result is the sum of the lengths
312 -- of the parameters. We could decide to make it larger, but we have no
313 -- basis for knowing how much larger, so we just allocate the minimum
314 -- amount of storage.
316 -- We must compute the length of the result vector and its last index,
317 -- but in such a way that overflow is avoided. We must satisfy two
318 -- constraints: the new length cannot exceed Count_Type'Last (here, we
319 -- know that that condition is satisfied), and the new Last index cannot
320 -- exceed Index_Type'Last.
322 if Index_Type'First >= Index_Type'Last then
323 raise Constraint_Error with "new length is out of range";
327 Last : constant Index_Type := Index_Type'First + 1;
329 Elements : constant Elements_Access :=
332 EA => (Left, Right));
335 return (Controlled with Elements, Last, 0, 0);
343 overriding function "=" (Left, Right : Vector) return Boolean is
345 if Left'Address = Right'Address then
349 if Left.Last /= Right.Last then
353 for J in Index_Type range Index_Type'First .. Left.Last loop
354 if Left.Elements.EA (J) /= Right.Elements.EA (J) then
366 procedure Adjust (Container : in out Vector) is
368 if Container.Last = No_Index then
369 Container.Elements := null;
374 L : constant Index_Type := Container.Last;
375 EA : Elements_Array renames
376 Container.Elements.EA (Index_Type'First .. L);
379 Container.Elements := null;
383 -- Note: it may seem that the following assignment to Container.Last
384 -- is useless, since we assign it to L below. However this code is
385 -- used in case 'new Elements_Type' below raises an exception, to
386 -- keep Container in a consistent state.
388 Container.Last := No_Index;
389 Container.Elements := new Elements_Type'(L, EA);
398 procedure Append (Container : in out Vector; New_Item : Vector) is
400 if Is_Empty (New_Item) then
404 if Container.Last = Index_Type'Last then
405 raise Constraint_Error with "vector is already at its maximum length";
415 (Container : in out Vector;
416 New_Item : Element_Type;
417 Count : Count_Type := 1)
424 if Container.Last = Index_Type'Last then
425 raise Constraint_Error with "vector is already at its maximum length";
439 procedure Assign (Target : in out Vector; Source : Vector) is
441 if Target'Address = Source'Address then
446 Target.Append (Source);
453 function Capacity (Container : Vector) return Count_Type is
455 if Container.Elements = null then
458 return Container.Elements.EA'Length;
466 procedure Clear (Container : in out Vector) is
468 if Container.Busy > 0 then
469 raise Program_Error with
470 "attempt to tamper with cursors (vector is busy)";
472 Container.Last := No_Index;
482 Item : Element_Type) return Boolean
485 return Find_Index (Container, Item) /= No_Index;
494 Capacity : Count_Type := 0) return Vector
502 elsif Capacity >= Source.Length then
507 with "Requested capacity is less than Source length";
510 return Target : Vector do
511 Target.Reserve_Capacity (C);
512 Target.Assign (Source);
521 (Container : in out Vector;
522 Index : Extended_Index;
523 Count : Count_Type := 1)
525 Old_Last : constant Index_Type'Base := Container.Last;
526 New_Last : Index_Type'Base;
527 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
528 J : Index_Type'Base; -- first index of items that slide down
531 -- Delete removes items from the vector, the number of which is the
532 -- minimum of the specified Count and the items (if any) that exist from
533 -- Index to Container.Last. There are no constraints on the specified
534 -- value of Count (it can be larger than what's available at this
535 -- position in the vector, for example), but there are constraints on
536 -- the allowed values of the Index.
538 -- As a precondition on the generic actual Index_Type, the base type
539 -- must include Index_Type'Pred (Index_Type'First); this is the value
540 -- that Container.Last assumes when the vector is empty. However, we do
541 -- not allow that as the value for Index when specifying which items
542 -- should be deleted, so we must manually check. (That the user is
543 -- allowed to specify the value at all here is a consequence of the
544 -- declaration of the Extended_Index subtype, which includes the values
545 -- in the base range that immediately precede and immediately follow the
546 -- values in the Index_Type.)
548 if Index < Index_Type'First then
549 raise Constraint_Error with "Index is out of range (too small)";
552 -- We do allow a value greater than Container.Last to be specified as
553 -- the Index, but only if it's immediately greater. This allows the
554 -- corner case of deleting no items from the back end of the vector to
555 -- be treated as a no-op. (It is assumed that specifying an index value
556 -- greater than Last + 1 indicates some deeper flaw in the caller's
557 -- algorithm, so that case is treated as a proper error.)
559 if Index > Old_Last then
560 if Index > Old_Last + 1 then
561 raise Constraint_Error with "Index is out of range (too large)";
567 -- Here and elsewhere we treat deleting 0 items from the container as a
568 -- no-op, even when the container is busy, so we simply return.
574 -- The tampering bits exist to prevent an item from being deleted (or
575 -- otherwise harmfully manipulated) while it is being visited. Query,
576 -- Update, and Iterate increment the busy count on entry, and decrement
577 -- the count on exit. Delete checks the count to determine whether it is
578 -- being called while the associated callback procedure is executing.
580 if Container.Busy > 0 then
581 raise Program_Error with
582 "attempt to tamper with cursors (vector is busy)";
585 -- We first calculate what's available for deletion starting at
586 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
587 -- Count_Type'Base as the type for intermediate values. (See function
588 -- Length for more information.)
590 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
591 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
594 Count2 := Count_Type'Base (Old_Last - Index + 1);
597 -- If more elements are requested (Count) for deletion than are
598 -- available (Count2) for deletion beginning at Index, then everything
599 -- from Index is deleted. There are no elements to slide down, and so
600 -- all we need to do is set the value of Container.Last.
602 if Count >= Count2 then
603 Container.Last := Index - 1;
607 -- There are some elements aren't being deleted (the requested count was
608 -- less than the available count), so we must slide them down to
609 -- Index. We first calculate the index values of the respective array
610 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
611 -- type for intermediate calculations. For the elements that slide down,
612 -- index value New_Last is the last index value of their new home, and
613 -- index value J is the first index of their old home.
615 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
616 New_Last := Old_Last - Index_Type'Base (Count);
617 J := Index + Index_Type'Base (Count);
620 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
621 J := Index_Type'Base (Count_Type'Base (Index) + Count);
624 -- The internal elements array isn't guaranteed to exist unless we have
625 -- elements, but we have that guarantee here because we know we have
626 -- elements to slide. The array index values for each slice have
627 -- already been determined, so we just slide down to Index the elements
628 -- that weren't deleted.
631 EA : Elements_Array renames Container.Elements.EA;
634 EA (Index .. New_Last) := EA (J .. Old_Last);
635 Container.Last := New_Last;
640 (Container : in out Vector;
641 Position : in out Cursor;
642 Count : Count_Type := 1)
644 pragma Warnings (Off, Position);
647 if Position.Container = null then
648 raise Constraint_Error with "Position cursor has no element";
651 if Position.Container /= Container'Unrestricted_Access then
652 raise Program_Error with "Position cursor denotes wrong container";
655 if Position.Index > Container.Last then
656 raise Program_Error with "Position index is out of range";
659 Delete (Container, Position.Index, Count);
660 Position := No_Element;
667 procedure Delete_First
668 (Container : in out Vector;
669 Count : Count_Type := 1)
676 if Count >= Length (Container) then
681 Delete (Container, Index_Type'First, Count);
688 procedure Delete_Last
689 (Container : in out Vector;
690 Count : Count_Type := 1)
693 -- It is not permitted to delete items while the container is busy (for
694 -- example, we're in the middle of a passive iteration). However, we
695 -- always treat deleting 0 items as a no-op, even when we're busy, so we
696 -- simply return without checking.
702 -- The tampering bits exist to prevent an item from being deleted (or
703 -- otherwise harmfully manipulated) while it is being visited. Query,
704 -- Update, and Iterate increment the busy count on entry, and decrement
705 -- the count on exit. Delete_Last checks the count to determine whether
706 -- it is being called while the associated callback procedure is
709 if Container.Busy > 0 then
710 raise Program_Error with
711 "attempt to tamper with cursors (vector is busy)";
714 -- There is no restriction on how large Count can be when deleting
715 -- items. If it is equal or greater than the current length, then this
716 -- is equivalent to clearing the vector. (In particular, there's no need
717 -- for us to actually calculate the new value for Last.)
719 -- If the requested count is less than the current length, then we must
720 -- calculate the new value for Last. For the type we use the widest of
721 -- Index_Type'Base and Count_Type'Base for the intermediate values of
722 -- our calculation. (See the comments in Length for more information.)
724 if Count >= Container.Length then
725 Container.Last := No_Index;
727 elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
728 Container.Last := Container.Last - Index_Type'Base (Count);
732 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
742 Index : Index_Type) return Element_Type
745 if Index > Container.Last then
746 raise Constraint_Error with "Index is out of range";
749 return Container.Elements.EA (Index);
752 function Element (Position : Cursor) return Element_Type is
754 if Position.Container = null then
755 raise Constraint_Error with "Position cursor has no element";
756 elsif Position.Index > Position.Container.Last then
757 raise Constraint_Error with "Position cursor is out of range";
759 return Position.Container.Elements.EA (Position.Index);
767 procedure Finalize (Container : in out Vector) is
768 X : Elements_Access := Container.Elements;
771 if Container.Busy > 0 then
772 raise Program_Error with
773 "attempt to tamper with cursors (vector is busy)";
776 Container.Elements := null;
777 Container.Last := No_Index;
788 Position : Cursor := No_Element) return Cursor
791 if Position.Container /= null then
792 if Position.Container /= Container'Unrestricted_Access then
793 raise Program_Error with "Position cursor denotes wrong container";
796 if Position.Index > Container.Last then
797 raise Program_Error with "Position index is out of range";
801 for J in Position.Index .. Container.Last loop
802 if Container.Elements.EA (J) = Item then
803 return (Container'Unchecked_Access, J);
817 Index : Index_Type := Index_Type'First) return Extended_Index
820 for Indx in Index .. Container.Last loop
821 if Container.Elements.EA (Indx) = Item then
833 function First (Container : Vector) return Cursor is
835 if Is_Empty (Container) then
838 return (Container'Unchecked_Access, Index_Type'First);
842 function First (Object : Iterator) return Cursor is
844 if Is_Empty (Object.Container.all) then
847 return (Object.Container, Index_Type'First);
855 function First_Element (Container : Vector) return Element_Type is
857 if Container.Last = No_Index then
858 raise Constraint_Error with "Container is empty";
860 return Container.Elements.EA (Index_Type'First);
868 function First_Index (Container : Vector) return Index_Type is
869 pragma Unreferenced (Container);
871 return Index_Type'First;
874 ---------------------
875 -- Generic_Sorting --
876 ---------------------
878 package body Generic_Sorting is
884 function Is_Sorted (Container : Vector) return Boolean is
886 if Container.Last <= Index_Type'First then
891 EA : Elements_Array renames Container.Elements.EA;
893 for J in Index_Type'First .. Container.Last - 1 loop
894 if EA (J + 1) < EA (J) then
907 procedure Merge (Target, Source : in out Vector) is
908 I : Index_Type'Base := Target.Last;
913 -- The semantics of Merge changed slightly per AI05-0021. It was
914 -- originally the case that if Target and Source denoted the same
915 -- container object, then the GNAT implementation of Merge did
916 -- nothing. However, it was argued that RM05 did not precisely
917 -- specify the semantics for this corner case. The decision of the
918 -- ARG was that if Target and Source denote the same non-empty
919 -- container object, then Program_Error is raised.
921 if Source.Last < Index_Type'First then -- Source is empty
925 if Target'Address = Source'Address then
926 raise Program_Error with
927 "Target and Source denote same non-empty container";
930 if Target.Last < Index_Type'First then -- Target is empty
931 Move (Target => Target, Source => Source);
935 if Source.Busy > 0 then
936 raise Program_Error with
937 "attempt to tamper with cursors (vector is busy)";
940 Target.Set_Length (Length (Target) + Length (Source));
943 TA : Elements_Array renames Target.Elements.EA;
944 SA : Elements_Array renames Source.Elements.EA;
948 while Source.Last >= Index_Type'First loop
949 pragma Assert (Source.Last <= Index_Type'First
950 or else not (SA (Source.Last) <
951 SA (Source.Last - 1)));
953 if I < Index_Type'First then
954 TA (Index_Type'First .. J) :=
955 SA (Index_Type'First .. Source.Last);
957 Source.Last := No_Index;
961 pragma Assert (I <= Index_Type'First
962 or else not (TA (I) < TA (I - 1)));
964 if SA (Source.Last) < TA (I) then
969 TA (J) := SA (Source.Last);
970 Source.Last := Source.Last - 1;
982 procedure Sort (Container : in out Vector)
985 new Generic_Array_Sort
986 (Index_Type => Index_Type,
987 Element_Type => Element_Type,
988 Array_Type => Elements_Array,
992 if Container.Last <= Index_Type'First then
996 if Container.Lock > 0 then
997 raise Program_Error with
998 "attempt to tamper with elements (vector is locked)";
1001 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1004 end Generic_Sorting;
1010 function Has_Element (Position : Cursor) return Boolean is
1012 return Position /= No_Element;
1020 (Container : in out Vector;
1021 Before : Extended_Index;
1022 New_Item : Element_Type;
1023 Count : Count_Type := 1)
1025 Old_Length : constant Count_Type := Container.Length;
1027 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1028 New_Length : Count_Type'Base; -- sum of current length and Count
1029 New_Last : Index_Type'Base; -- last index of vector after insertion
1031 Index : Index_Type'Base; -- scratch for intermediate values
1032 J : Count_Type'Base; -- scratch
1034 New_Capacity : Count_Type'Base; -- length of new, expanded array
1035 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1036 Dst : Elements_Access; -- new, expanded internal array
1039 -- As a precondition on the generic actual Index_Type, the base type
1040 -- must include Index_Type'Pred (Index_Type'First); this is the value
1041 -- that Container.Last assumes when the vector is empty. However, we do
1042 -- not allow that as the value for Index when specifying where the new
1043 -- items should be inserted, so we must manually check. (That the user
1044 -- is allowed to specify the value at all here is a consequence of the
1045 -- declaration of the Extended_Index subtype, which includes the values
1046 -- in the base range that immediately precede and immediately follow the
1047 -- values in the Index_Type.)
1049 if Before < Index_Type'First then
1050 raise Constraint_Error with
1051 "Before index is out of range (too small)";
1054 -- We do allow a value greater than Container.Last to be specified as
1055 -- the Index, but only if it's immediately greater. This allows for the
1056 -- case of appending items to the back end of the vector. (It is assumed
1057 -- that specifying an index value greater than Last + 1 indicates some
1058 -- deeper flaw in the caller's algorithm, so that case is treated as a
1061 if Before > Container.Last
1062 and then Before > Container.Last + 1
1064 raise Constraint_Error with
1065 "Before index is out of range (too large)";
1068 -- We treat inserting 0 items into the container as a no-op, even when
1069 -- the container is busy, so we simply return.
1075 -- There are two constraints we need to satisfy. The first constraint is
1076 -- that a container cannot have more than Count_Type'Last elements, so
1077 -- we must check the sum of the current length and the insertion count.
1078 -- Note: we cannot simply add these values, because of the possibility
1081 if Old_Length > Count_Type'Last - Count then
1082 raise Constraint_Error with "Count is out of range";
1085 -- It is now safe compute the length of the new vector, without fear of
1088 New_Length := Old_Length + Count;
1090 -- The second constraint is that the new Last index value cannot exceed
1091 -- Index_Type'Last. In each branch below, we calculate the maximum
1092 -- length (computed from the range of values in Index_Type), and then
1093 -- compare the new length to the maximum length. If the new length is
1094 -- acceptable, then we compute the new last index from that.
1096 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1098 -- We have to handle the case when there might be more values in the
1099 -- range of Index_Type than in the range of Count_Type.
1101 if Index_Type'First <= 0 then
1103 -- We know that No_Index (the same as Index_Type'First - 1) is
1104 -- less than 0, so it is safe to compute the following sum without
1105 -- fear of overflow.
1107 Index := No_Index + Index_Type'Base (Count_Type'Last);
1109 if Index <= Index_Type'Last then
1111 -- We have determined that range of Index_Type has at least as
1112 -- many values as in Count_Type, so Count_Type'Last is the
1113 -- maximum number of items that are allowed.
1115 Max_Length := Count_Type'Last;
1118 -- The range of Index_Type has fewer values than in Count_Type,
1119 -- so the maximum number of items is computed from the range of
1122 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1126 -- No_Index is equal or greater than 0, so we can safely compute
1127 -- the difference without fear of overflow (which we would have to
1128 -- worry about if No_Index were less than 0, but that case is
1131 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1134 elsif Index_Type'First <= 0 then
1136 -- We know that No_Index (the same as Index_Type'First - 1) is less
1137 -- than 0, so it is safe to compute the following sum without fear of
1140 J := Count_Type'Base (No_Index) + Count_Type'Last;
1142 if J <= Count_Type'Base (Index_Type'Last) then
1144 -- We have determined that range of Index_Type has at least as
1145 -- many values as in Count_Type, so Count_Type'Last is the maximum
1146 -- number of items that are allowed.
1148 Max_Length := Count_Type'Last;
1151 -- The range of Index_Type has fewer values than Count_Type does,
1152 -- so the maximum number of items is computed from the range of
1156 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1160 -- No_Index is equal or greater than 0, so we can safely compute the
1161 -- difference without fear of overflow (which we would have to worry
1162 -- about if No_Index were less than 0, but that case is handled
1166 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1169 -- We have just computed the maximum length (number of items). We must
1170 -- now compare the requested length to the maximum length, as we do not
1171 -- allow a vector expand beyond the maximum (because that would create
1172 -- an internal array with a last index value greater than
1173 -- Index_Type'Last, with no way to index those elements).
1175 if New_Length > Max_Length then
1176 raise Constraint_Error with "Count is out of range";
1179 -- New_Last is the last index value of the items in the container after
1180 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1181 -- compute its value from the New_Length.
1183 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1184 New_Last := No_Index + Index_Type'Base (New_Length);
1186 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1189 if Container.Elements = null then
1190 pragma Assert (Container.Last = No_Index);
1192 -- This is the simplest case, with which we must always begin: we're
1193 -- inserting items into an empty vector that hasn't allocated an
1194 -- internal array yet. Note that we don't need to check the busy bit
1195 -- here, because an empty container cannot be busy.
1197 -- In order to preserve container invariants, we allocate the new
1198 -- internal array first, before setting the Last index value, in case
1199 -- the allocation fails (which can happen either because there is no
1200 -- storage available, or because element initialization fails).
1202 Container.Elements := new Elements_Type'
1204 EA => (others => New_Item));
1206 -- The allocation of the new, internal array succeeded, so it is now
1207 -- safe to update the Last index, restoring container invariants.
1209 Container.Last := New_Last;
1214 -- The tampering bits exist to prevent an item from being harmfully
1215 -- manipulated while it is being visited. Query, Update, and Iterate
1216 -- increment the busy count on entry, and decrement the count on
1217 -- exit. Insert checks the count to determine whether it is being called
1218 -- while the associated callback procedure is executing.
1220 if Container.Busy > 0 then
1221 raise Program_Error with
1222 "attempt to tamper with cursors (vector is busy)";
1225 -- An internal array has already been allocated, so we must determine
1226 -- whether there is enough unused storage for the new items.
1228 if New_Length <= Container.Elements.EA'Length then
1230 -- In this case, we're inserting elements into a vector that has
1231 -- already allocated an internal array, and the existing array has
1232 -- enough unused storage for the new items.
1235 EA : Elements_Array renames Container.Elements.EA;
1238 if Before > Container.Last then
1240 -- The new items are being appended to the vector, so no
1241 -- sliding of existing elements is required.
1243 EA (Before .. New_Last) := (others => New_Item);
1246 -- The new items are being inserted before some existing
1247 -- elements, so we must slide the existing elements up to their
1248 -- new home. We use the wider of Index_Type'Base and
1249 -- Count_Type'Base as the type for intermediate index values.
1251 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1252 Index := Before + Index_Type'Base (Count);
1255 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1258 EA (Index .. New_Last) := EA (Before .. Container.Last);
1259 EA (Before .. Index - 1) := (others => New_Item);
1263 Container.Last := New_Last;
1267 -- In this case, we're inserting elements into a vector that has already
1268 -- allocated an internal array, but the existing array does not have
1269 -- enough storage, so we must allocate a new, longer array. In order to
1270 -- guarantee that the amortized insertion cost is O(1), we always
1271 -- allocate an array whose length is some power-of-two factor of the
1272 -- current array length. (The new array cannot have a length less than
1273 -- the New_Length of the container, but its last index value cannot be
1274 -- greater than Index_Type'Last.)
1276 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1277 while New_Capacity < New_Length loop
1278 if New_Capacity > Count_Type'Last / 2 then
1279 New_Capacity := Count_Type'Last;
1283 New_Capacity := 2 * New_Capacity;
1286 if New_Capacity > Max_Length then
1288 -- We have reached the limit of capacity, so no further expansion
1289 -- will occur. (This is not a problem, as there is never a need to
1290 -- have more capacity than the maximum container length.)
1292 New_Capacity := Max_Length;
1295 -- We have computed the length of the new internal array (and this is
1296 -- what "vector capacity" means), so use that to compute its last index.
1298 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1299 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1303 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1306 -- Now we allocate the new, longer internal array. If the allocation
1307 -- fails, we have not changed any container state, so no side-effect
1308 -- will occur as a result of propagating the exception.
1310 Dst := new Elements_Type (Dst_Last);
1312 -- We have our new internal array. All that needs to be done now is to
1313 -- copy the existing items (if any) from the old array (the "source"
1314 -- array, object SA below) to the new array (the "destination" array,
1315 -- object DA below), and then deallocate the old array.
1318 SA : Elements_Array renames Container.Elements.EA; -- source
1319 DA : Elements_Array renames Dst.EA; -- destination
1322 DA (Index_Type'First .. Before - 1) :=
1323 SA (Index_Type'First .. Before - 1);
1325 if Before > Container.Last then
1326 DA (Before .. New_Last) := (others => New_Item);
1329 -- The new items are being inserted before some existing elements,
1330 -- so we must slide the existing elements up to their new home.
1332 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1333 Index := Before + Index_Type'Base (Count);
1336 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1339 DA (Before .. Index - 1) := (others => New_Item);
1340 DA (Index .. New_Last) := SA (Before .. Container.Last);
1349 -- We have successfully copied the items onto the new array, so the
1350 -- final thing to do is deallocate the old array.
1353 X : Elements_Access := Container.Elements;
1355 -- We first isolate the old internal array, removing it from the
1356 -- container and replacing it with the new internal array, before we
1357 -- deallocate the old array (which can fail if finalization of
1358 -- elements propagates an exception).
1360 Container.Elements := Dst;
1361 Container.Last := New_Last;
1363 -- The container invariants have been restored, so it is now safe to
1364 -- attempt to deallocate the old array.
1371 (Container : in out Vector;
1372 Before : Extended_Index;
1375 N : constant Count_Type := Length (New_Item);
1376 J : Index_Type'Base;
1379 -- Use Insert_Space to create the "hole" (the destination slice) into
1380 -- which we copy the source items.
1382 Insert_Space (Container, Before, Count => N);
1386 -- There's nothing else to do here (vetting of parameters was
1387 -- performed already in Insert_Space), so we simply return.
1392 -- We calculate the last index value of the destination slice using the
1393 -- wider of Index_Type'Base and count_Type'Base.
1395 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1396 J := (Before - 1) + Index_Type'Base (N);
1399 J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
1402 if Container'Address /= New_Item'Address then
1404 -- This is the simple case. New_Item denotes an object different
1405 -- from Container, so there's nothing special we need to do to copy
1406 -- the source items to their destination, because all of the source
1407 -- items are contiguous.
1409 Container.Elements.EA (Before .. J) :=
1410 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
1415 -- New_Item denotes the same object as Container, so an insertion has
1416 -- potentially split the source items. The destination is always the
1417 -- range [Before, J], but the source is [Index_Type'First, Before) and
1418 -- (J, Container.Last]. We perform the copy in two steps, using each of
1419 -- the two slices of the source items.
1422 L : constant Index_Type'Base := Before - 1;
1424 subtype Src_Index_Subtype is Index_Type'Base range
1425 Index_Type'First .. L;
1427 Src : Elements_Array renames
1428 Container.Elements.EA (Src_Index_Subtype);
1430 K : Index_Type'Base;
1433 -- We first copy the source items that precede the space we
1434 -- inserted. Index value K is the last index of that portion
1435 -- destination that receives this slice of the source. (If Before
1436 -- equals Index_Type'First, then this first source slice will be
1437 -- empty, which is harmless.)
1439 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1440 K := L + Index_Type'Base (Src'Length);
1443 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1446 Container.Elements.EA (Before .. K) := Src;
1448 if Src'Length = N then
1450 -- The new items were effectively appended to the container, so we
1451 -- have already copied all of the items that need to be copied.
1452 -- We return early here, even though the source slice below is
1453 -- empty (so the assignment would be harmless), because we want to
1454 -- avoid computing J + 1, which will overflow if J equals
1455 -- Index_Type'Base'Last.
1462 -- Note that we want to avoid computing J + 1 here, in case J equals
1463 -- Index_Type'Base'Last. We prevent that by returning early above,
1464 -- immediately after copying the first slice of the source, and
1465 -- determining that this second slice of the source is empty.
1467 F : constant Index_Type'Base := J + 1;
1469 subtype Src_Index_Subtype is Index_Type'Base range
1470 F .. Container.Last;
1472 Src : Elements_Array renames
1473 Container.Elements.EA (Src_Index_Subtype);
1475 K : Index_Type'Base;
1478 -- We next copy the source items that follow the space we
1479 -- inserted. Index value K is the first index of that portion of the
1480 -- destination that receives this slice of the source. (For the
1481 -- reasons given above, this slice is guaranteed to be non-empty.)
1483 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1484 K := F - Index_Type'Base (Src'Length);
1487 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1490 Container.Elements.EA (K .. J) := Src;
1495 (Container : in out Vector;
1499 Index : Index_Type'Base;
1502 if Before.Container /= null
1503 and then Before.Container /= Container'Unchecked_Access
1505 raise Program_Error with "Before cursor denotes wrong container";
1508 if Is_Empty (New_Item) then
1512 if Before.Container = null
1513 or else Before.Index > Container.Last
1515 if Container.Last = Index_Type'Last then
1516 raise Constraint_Error with
1517 "vector is already at its maximum length";
1520 Index := Container.Last + 1;
1523 Index := Before.Index;
1526 Insert (Container, Index, New_Item);
1530 (Container : in out Vector;
1533 Position : out Cursor)
1535 Index : Index_Type'Base;
1538 if Before.Container /= null
1539 and then Before.Container /= Container'Unchecked_Access
1541 raise Program_Error with "Before cursor denotes wrong container";
1544 if Is_Empty (New_Item) then
1545 if Before.Container = null
1546 or else Before.Index > Container.Last
1548 Position := No_Element;
1550 Position := (Container'Unchecked_Access, Before.Index);
1556 if Before.Container = null
1557 or else Before.Index > Container.Last
1559 if Container.Last = Index_Type'Last then
1560 raise Constraint_Error with
1561 "vector is already at its maximum length";
1564 Index := Container.Last + 1;
1567 Index := Before.Index;
1570 Insert (Container, Index, New_Item);
1572 Position := (Container'Unchecked_Access, Index);
1576 (Container : in out Vector;
1578 New_Item : Element_Type;
1579 Count : Count_Type := 1)
1581 Index : Index_Type'Base;
1584 if Before.Container /= null
1585 and then Before.Container /= Container'Unchecked_Access
1587 raise Program_Error with "Before cursor denotes wrong container";
1594 if Before.Container = null
1595 or else Before.Index > Container.Last
1597 if Container.Last = Index_Type'Last then
1598 raise Constraint_Error with
1599 "vector is already at its maximum length";
1601 Index := Container.Last + 1;
1605 Index := Before.Index;
1608 Insert (Container, Index, New_Item, Count);
1612 (Container : in out Vector;
1614 New_Item : Element_Type;
1615 Position : out Cursor;
1616 Count : Count_Type := 1)
1618 Index : Index_Type'Base;
1621 if Before.Container /= null
1622 and then Before.Container /= Container'Unchecked_Access
1624 raise Program_Error with "Before cursor denotes wrong container";
1628 if Before.Container = null
1629 or else Before.Index > Container.Last
1631 Position := No_Element;
1633 Position := (Container'Unchecked_Access, Before.Index);
1639 if Before.Container = null
1640 or else Before.Index > Container.Last
1642 if Container.Last = Index_Type'Last then
1643 raise Constraint_Error with
1644 "vector is already at its maximum length";
1647 Index := Container.Last + 1;
1650 Index := Before.Index;
1653 Insert (Container, Index, New_Item, Count);
1655 Position := (Container'Unchecked_Access, Index);
1659 (Container : in out Vector;
1660 Before : Extended_Index;
1661 Count : Count_Type := 1)
1663 New_Item : Element_Type; -- Default-initialized value
1664 pragma Warnings (Off, New_Item);
1667 Insert (Container, Before, New_Item, Count);
1671 (Container : in out Vector;
1673 Position : out Cursor;
1674 Count : Count_Type := 1)
1676 New_Item : Element_Type; -- Default-initialized value
1677 pragma Warnings (Off, New_Item);
1680 Insert (Container, Before, New_Item, Position, Count);
1687 procedure Insert_Space
1688 (Container : in out Vector;
1689 Before : Extended_Index;
1690 Count : Count_Type := 1)
1692 Old_Length : constant Count_Type := Container.Length;
1694 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1695 New_Length : Count_Type'Base; -- sum of current length and Count
1696 New_Last : Index_Type'Base; -- last index of vector after insertion
1698 Index : Index_Type'Base; -- scratch for intermediate values
1699 J : Count_Type'Base; -- scratch
1701 New_Capacity : Count_Type'Base; -- length of new, expanded array
1702 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1703 Dst : Elements_Access; -- new, expanded internal array
1706 -- As a precondition on the generic actual Index_Type, the base type
1707 -- must include Index_Type'Pred (Index_Type'First); this is the value
1708 -- that Container.Last assumes when the vector is empty. However, we do
1709 -- not allow that as the value for Index when specifying where the new
1710 -- items should be inserted, so we must manually check. (That the user
1711 -- is allowed to specify the value at all here is a consequence of the
1712 -- declaration of the Extended_Index subtype, which includes the values
1713 -- in the base range that immediately precede and immediately follow the
1714 -- values in the Index_Type.)
1716 if Before < Index_Type'First then
1717 raise Constraint_Error with
1718 "Before index is out of range (too small)";
1721 -- We do allow a value greater than Container.Last to be specified as
1722 -- the Index, but only if it's immediately greater. This allows for the
1723 -- case of appending items to the back end of the vector. (It is assumed
1724 -- that specifying an index value greater than Last + 1 indicates some
1725 -- deeper flaw in the caller's algorithm, so that case is treated as a
1728 if Before > Container.Last
1729 and then Before > Container.Last + 1
1731 raise Constraint_Error with
1732 "Before index is out of range (too large)";
1735 -- We treat inserting 0 items into the container as a no-op, even when
1736 -- the container is busy, so we simply return.
1742 -- There are two constraints we need to satisfy. The first constraint is
1743 -- that a container cannot have more than Count_Type'Last elements, so
1744 -- we must check the sum of the current length and the insertion count.
1745 -- Note: we cannot simply add these values, because of the possibility
1748 if Old_Length > Count_Type'Last - Count then
1749 raise Constraint_Error with "Count is out of range";
1752 -- It is now safe compute the length of the new vector, without fear of
1755 New_Length := Old_Length + Count;
1757 -- The second constraint is that the new Last index value cannot exceed
1758 -- Index_Type'Last. In each branch below, we calculate the maximum
1759 -- length (computed from the range of values in Index_Type), and then
1760 -- compare the new length to the maximum length. If the new length is
1761 -- acceptable, then we compute the new last index from that.
1763 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1765 -- We have to handle the case when there might be more values in the
1766 -- range of Index_Type than in the range of Count_Type.
1768 if Index_Type'First <= 0 then
1770 -- We know that No_Index (the same as Index_Type'First - 1) is
1771 -- less than 0, so it is safe to compute the following sum without
1772 -- fear of overflow.
1774 Index := No_Index + Index_Type'Base (Count_Type'Last);
1776 if Index <= Index_Type'Last then
1778 -- We have determined that range of Index_Type has at least as
1779 -- many values as in Count_Type, so Count_Type'Last is the
1780 -- maximum number of items that are allowed.
1782 Max_Length := Count_Type'Last;
1785 -- The range of Index_Type has fewer values than in Count_Type,
1786 -- so the maximum number of items is computed from the range of
1789 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1793 -- No_Index is equal or greater than 0, so we can safely compute
1794 -- the difference without fear of overflow (which we would have to
1795 -- worry about if No_Index were less than 0, but that case is
1798 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1801 elsif Index_Type'First <= 0 then
1803 -- We know that No_Index (the same as Index_Type'First - 1) is less
1804 -- than 0, so it is safe to compute the following sum without fear of
1807 J := Count_Type'Base (No_Index) + Count_Type'Last;
1809 if J <= Count_Type'Base (Index_Type'Last) then
1811 -- We have determined that range of Index_Type has at least as
1812 -- many values as in Count_Type, so Count_Type'Last is the maximum
1813 -- number of items that are allowed.
1815 Max_Length := Count_Type'Last;
1818 -- The range of Index_Type has fewer values than Count_Type does,
1819 -- so the maximum number of items is computed from the range of
1823 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1827 -- No_Index is equal or greater than 0, so we can safely compute the
1828 -- difference without fear of overflow (which we would have to worry
1829 -- about if No_Index were less than 0, but that case is handled
1833 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1836 -- We have just computed the maximum length (number of items). We must
1837 -- now compare the requested length to the maximum length, as we do not
1838 -- allow a vector expand beyond the maximum (because that would create
1839 -- an internal array with a last index value greater than
1840 -- Index_Type'Last, with no way to index those elements).
1842 if New_Length > Max_Length then
1843 raise Constraint_Error with "Count is out of range";
1846 -- New_Last is the last index value of the items in the container after
1847 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1848 -- compute its value from the New_Length.
1850 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1851 New_Last := No_Index + Index_Type'Base (New_Length);
1854 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1857 if Container.Elements = null then
1858 pragma Assert (Container.Last = No_Index);
1860 -- This is the simplest case, with which we must always begin: we're
1861 -- inserting items into an empty vector that hasn't allocated an
1862 -- internal array yet. Note that we don't need to check the busy bit
1863 -- here, because an empty container cannot be busy.
1865 -- In order to preserve container invariants, we allocate the new
1866 -- internal array first, before setting the Last index value, in case
1867 -- the allocation fails (which can happen either because there is no
1868 -- storage available, or because default-valued element
1869 -- initialization fails).
1871 Container.Elements := new Elements_Type (New_Last);
1873 -- The allocation of the new, internal array succeeded, so it is now
1874 -- safe to update the Last index, restoring container invariants.
1876 Container.Last := New_Last;
1881 -- The tampering bits exist to prevent an item from being harmfully
1882 -- manipulated while it is being visited. Query, Update, and Iterate
1883 -- increment the busy count on entry, and decrement the count on
1884 -- exit. Insert checks the count to determine whether it is being called
1885 -- while the associated callback procedure is executing.
1887 if Container.Busy > 0 then
1888 raise Program_Error with
1889 "attempt to tamper with cursors (vector is busy)";
1892 -- An internal array has already been allocated, so we must determine
1893 -- whether there is enough unused storage for the new items.
1895 if New_Last <= Container.Elements.Last then
1897 -- In this case, we're inserting space into a vector that has already
1898 -- allocated an internal array, and the existing array has enough
1899 -- unused storage for the new items.
1902 EA : Elements_Array renames Container.Elements.EA;
1905 if Before <= Container.Last then
1907 -- The space is being inserted before some existing elements,
1908 -- so we must slide the existing elements up to their new
1909 -- home. We use the wider of Index_Type'Base and
1910 -- Count_Type'Base as the type for intermediate index values.
1912 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1913 Index := Before + Index_Type'Base (Count);
1916 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1919 EA (Index .. New_Last) := EA (Before .. Container.Last);
1923 Container.Last := New_Last;
1927 -- In this case, we're inserting space into a vector that has already
1928 -- allocated an internal array, but the existing array does not have
1929 -- enough storage, so we must allocate a new, longer array. In order to
1930 -- guarantee that the amortized insertion cost is O(1), we always
1931 -- allocate an array whose length is some power-of-two factor of the
1932 -- current array length. (The new array cannot have a length less than
1933 -- the New_Length of the container, but its last index value cannot be
1934 -- greater than Index_Type'Last.)
1936 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1937 while New_Capacity < New_Length loop
1938 if New_Capacity > Count_Type'Last / 2 then
1939 New_Capacity := Count_Type'Last;
1943 New_Capacity := 2 * New_Capacity;
1946 if New_Capacity > Max_Length then
1948 -- We have reached the limit of capacity, so no further expansion
1949 -- will occur. (This is not a problem, as there is never a need to
1950 -- have more capacity than the maximum container length.)
1952 New_Capacity := Max_Length;
1955 -- We have computed the length of the new internal array (and this is
1956 -- what "vector capacity" means), so use that to compute its last index.
1958 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1959 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1963 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1966 -- Now we allocate the new, longer internal array. If the allocation
1967 -- fails, we have not changed any container state, so no side-effect
1968 -- will occur as a result of propagating the exception.
1970 Dst := new Elements_Type (Dst_Last);
1972 -- We have our new internal array. All that needs to be done now is to
1973 -- copy the existing items (if any) from the old array (the "source"
1974 -- array, object SA below) to the new array (the "destination" array,
1975 -- object DA below), and then deallocate the old array.
1978 SA : Elements_Array renames Container.Elements.EA; -- source
1979 DA : Elements_Array renames Dst.EA; -- destination
1982 DA (Index_Type'First .. Before - 1) :=
1983 SA (Index_Type'First .. Before - 1);
1985 if Before <= Container.Last then
1987 -- The space is being inserted before some existing elements, so
1988 -- we must slide the existing elements up to their new home.
1990 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1991 Index := Before + Index_Type'Base (Count);
1994 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1997 DA (Index .. New_Last) := SA (Before .. Container.Last);
2006 -- We have successfully copied the items onto the new array, so the
2007 -- final thing to do is restore invariants, and deallocate the old
2011 X : Elements_Access := Container.Elements;
2014 -- We first isolate the old internal array, removing it from the
2015 -- container and replacing it with the new internal array, before we
2016 -- deallocate the old array (which can fail if finalization of
2017 -- elements propagates an exception).
2019 Container.Elements := Dst;
2020 Container.Last := New_Last;
2022 -- The container invariants have been restored, so it is now safe to
2023 -- attempt to deallocate the old array.
2029 procedure Insert_Space
2030 (Container : in out Vector;
2032 Position : out Cursor;
2033 Count : Count_Type := 1)
2035 Index : Index_Type'Base;
2038 if Before.Container /= null
2039 and then Before.Container /= Container'Unchecked_Access
2041 raise Program_Error with "Before cursor denotes wrong container";
2045 if Before.Container = null
2046 or else Before.Index > Container.Last
2048 Position := No_Element;
2050 Position := (Container'Unchecked_Access, Before.Index);
2056 if Before.Container = null
2057 or else Before.Index > Container.Last
2059 if Container.Last = Index_Type'Last then
2060 raise Constraint_Error with
2061 "vector is already at its maximum length";
2063 Index := Container.Last + 1;
2067 Index := Before.Index;
2070 Insert_Space (Container, Index, Count => Count);
2072 Position := (Container'Unchecked_Access, Index);
2079 function Is_Empty (Container : Vector) return Boolean is
2081 return Container.Last < Index_Type'First;
2089 (Container : Vector;
2090 Process : not null access procedure (Position : Cursor))
2092 V : Vector renames Container'Unrestricted_Access.all;
2093 B : Natural renames V.Busy;
2099 for Indx in Index_Type'First .. Container.Last loop
2100 Process (Cursor'(Container'Unchecked_Access, Indx));
2112 (Container : Vector)
2113 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2115 It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
2121 (Container : Vector;
2123 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2125 It : constant Iterator := (Container'Unchecked_Access, Start.Index);
2134 function Last (Container : Vector) return Cursor is
2136 if Is_Empty (Container) then
2139 return (Container'Unchecked_Access, Container.Last);
2143 function Last (Object : Iterator) return Cursor is
2145 if Is_Empty (Object.Container.all) then
2148 return (Object.Container, Object.Container.Last);
2156 function Last_Element (Container : Vector) return Element_Type is
2158 if Container.Last = No_Index then
2159 raise Constraint_Error with "Container is empty";
2161 return Container.Elements.EA (Container.Last);
2169 function Last_Index (Container : Vector) return Extended_Index is
2171 return Container.Last;
2178 function Length (Container : Vector) return Count_Type is
2179 L : constant Index_Type'Base := Container.Last;
2180 F : constant Index_Type := Index_Type'First;
2183 -- The base range of the index type (Index_Type'Base) might not include
2184 -- all values for length (Count_Type). Contrariwise, the index type
2185 -- might include values outside the range of length. Hence we use
2186 -- whatever type is wider for intermediate values when calculating
2187 -- length. Note that no matter what the index type is, the maximum
2188 -- length to which a vector is allowed to grow is always the minimum
2189 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2191 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2192 -- to have a base range of -128 .. 127, but the corresponding vector
2193 -- would have lengths in the range 0 .. 255. In this case we would need
2194 -- to use Count_Type'Base for intermediate values.
2196 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2197 -- vector would have a maximum length of 10, but the index values lie
2198 -- outside the range of Count_Type (which is only 32 bits). In this
2199 -- case we would need to use Index_Type'Base for intermediate values.
2201 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2202 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2204 return Count_Type (L - F + 1);
2213 (Target : in out Vector;
2214 Source : in out Vector)
2217 if Target'Address = Source'Address then
2221 if Target.Busy > 0 then
2222 raise Program_Error with
2223 "attempt to tamper with cursors (Target is busy)";
2226 if Source.Busy > 0 then
2227 raise Program_Error with
2228 "attempt to tamper with cursors (Source is busy)";
2232 Target_Elements : constant Elements_Access := Target.Elements;
2234 Target.Elements := Source.Elements;
2235 Source.Elements := Target_Elements;
2238 Target.Last := Source.Last;
2239 Source.Last := No_Index;
2246 function Next (Position : Cursor) return Cursor is
2248 if Position.Container = null then
2250 elsif Position.Index < Position.Container.Last then
2251 return (Position.Container, Position.Index + 1);
2257 function Next (Object : Iterator; Position : Cursor) return Cursor is
2259 if Position.Index < Object.Container.Last then
2260 return (Object.Container, Position.Index + 1);
2266 procedure Next (Position : in out Cursor) is
2268 if Position.Container = null then
2270 elsif Position.Index < Position.Container.Last then
2271 Position.Index := Position.Index + 1;
2273 Position := No_Element;
2281 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2283 Insert (Container, Index_Type'First, New_Item);
2287 (Container : in out Vector;
2288 New_Item : Element_Type;
2289 Count : Count_Type := 1)
2302 function Previous (Position : Cursor) return Cursor is
2304 if Position.Container = null then
2306 elsif Position.Index > Index_Type'First then
2307 return (Position.Container, Position.Index - 1);
2313 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2315 if Position.Index > Index_Type'First then
2316 return (Object.Container, Position.Index - 1);
2322 procedure Previous (Position : in out Cursor) is
2324 if Position.Container = null then
2326 elsif Position.Index > Index_Type'First then
2327 Position.Index := Position.Index - 1;
2329 Position := No_Element;
2337 procedure Query_Element
2338 (Container : Vector;
2340 Process : not null access procedure (Element : Element_Type))
2342 V : Vector renames Container'Unrestricted_Access.all;
2343 B : Natural renames V.Busy;
2344 L : Natural renames V.Lock;
2347 if Index > Container.Last then
2348 raise Constraint_Error with "Index is out of range";
2355 Process (V.Elements.EA (Index));
2367 procedure Query_Element
2369 Process : not null access procedure (Element : Element_Type))
2372 if Position.Container = null then
2373 raise Constraint_Error with "Position cursor has no element";
2376 Query_Element (Position.Container.all, Position.Index, Process);
2384 (Stream : not null access Root_Stream_Type'Class;
2385 Container : out Vector)
2387 Length : Count_Type'Base;
2388 Last : Index_Type'Base := No_Index;
2393 Count_Type'Base'Read (Stream, Length);
2395 if Length > Capacity (Container) then
2396 Reserve_Capacity (Container, Capacity => Length);
2399 for J in Count_Type range 1 .. Length loop
2401 Element_Type'Read (Stream, Container.Elements.EA (Last));
2402 Container.Last := Last;
2407 (Stream : not null access Root_Stream_Type'Class;
2408 Position : out Cursor)
2411 raise Program_Error with "attempt to stream vector cursor";
2415 (Stream : not null access Root_Stream_Type'Class;
2416 Item : out Reference_Type)
2419 raise Program_Error with "attempt to stream reference";
2423 (Stream : not null access Root_Stream_Type'Class;
2424 Item : out Constant_Reference_Type)
2427 raise Program_Error with "attempt to stream reference";
2434 function Constant_Reference
2435 (Container : Vector;
2436 Position : Cursor) -- SHOULD BE ALIASED
2437 return Constant_Reference_Type
2440 pragma Unreferenced (Container);
2442 if Position.Container = null then
2443 raise Constraint_Error with "Position cursor has no element";
2446 if Position.Index > Position.Container.Last then
2447 raise Constraint_Error with "Position cursor is out of range";
2452 Position.Container.Elements.EA (Position.Index)'Access);
2453 end Constant_Reference;
2455 function Constant_Reference
2456 (Container : Vector;
2457 Position : Index_Type)
2458 return Constant_Reference_Type
2461 if Position > Container.Last then
2462 raise Constraint_Error with "Index is out of range";
2464 return (Element => Container.Elements.EA (Position)'Access);
2466 end Constant_Reference;
2468 function Reference (Container : Vector; Position : Cursor)
2469 return Reference_Type is
2471 pragma Unreferenced (Container);
2473 if Position.Container = null then
2474 raise Constraint_Error with "Position cursor has no element";
2477 if Position.Index > Position.Container.Last then
2478 raise Constraint_Error with "Position cursor is out of range";
2482 (Element => Position.Container.Elements.EA (Position.Index)'Access);
2485 function Reference (Container : Vector; Position : Index_Type)
2486 return Reference_Type is
2488 if Position > Container.Last then
2489 raise Constraint_Error with "Index is out of range";
2491 return (Element => Container.Elements.EA (Position)'Access);
2495 ---------------------
2496 -- Replace_Element --
2497 ---------------------
2499 procedure Replace_Element
2500 (Container : in out Vector;
2502 New_Item : Element_Type)
2505 if Index > Container.Last then
2506 raise Constraint_Error with "Index is out of range";
2509 if Container.Lock > 0 then
2510 raise Program_Error with
2511 "attempt to tamper with elements (vector is locked)";
2514 Container.Elements.EA (Index) := New_Item;
2515 end Replace_Element;
2517 procedure Replace_Element
2518 (Container : in out Vector;
2520 New_Item : Element_Type)
2523 if Position.Container = null then
2524 raise Constraint_Error with "Position cursor has no element";
2527 if Position.Container /= Container'Unrestricted_Access then
2528 raise Program_Error with "Position cursor denotes wrong container";
2531 if Position.Index > Container.Last then
2532 raise Constraint_Error with "Position cursor is out of range";
2535 if Container.Lock > 0 then
2536 raise Program_Error with
2537 "attempt to tamper with elements (vector is locked)";
2540 Container.Elements.EA (Position.Index) := New_Item;
2541 end Replace_Element;
2543 ----------------------
2544 -- Reserve_Capacity --
2545 ----------------------
2547 procedure Reserve_Capacity
2548 (Container : in out Vector;
2549 Capacity : Count_Type)
2551 N : constant Count_Type := Length (Container);
2553 Index : Count_Type'Base;
2554 Last : Index_Type'Base;
2557 -- Reserve_Capacity can be used to either expand the storage available
2558 -- for elements (this would be its typical use, in anticipation of
2559 -- future insertion), or to trim back storage. In the latter case,
2560 -- storage can only be trimmed back to the limit of the container
2561 -- length. Note that Reserve_Capacity neither deletes (active) elements
2562 -- nor inserts elements; it only affects container capacity, never
2563 -- container length.
2565 if Capacity = 0 then
2567 -- This is a request to trim back storage, to the minimum amount
2568 -- possible given the current state of the container.
2572 -- The container is empty, so in this unique case we can
2573 -- deallocate the entire internal array. Note that an empty
2574 -- container can never be busy, so there's no need to check the
2578 X : Elements_Access := Container.Elements;
2581 -- First we remove the internal array from the container, to
2582 -- handle the case when the deallocation raises an exception.
2584 Container.Elements := null;
2586 -- Container invariants have been restored, so it is now safe
2587 -- to attempt to deallocate the internal array.
2592 elsif N < Container.Elements.EA'Length then
2594 -- The container is not empty, and the current length is less than
2595 -- the current capacity, so there's storage available to trim. In
2596 -- this case, we allocate a new internal array having a length
2597 -- that exactly matches the number of items in the
2598 -- container. (Reserve_Capacity does not delete active elements,
2599 -- so this is the best we can do with respect to minimizing
2602 if Container.Busy > 0 then
2603 raise Program_Error with
2604 "attempt to tamper with cursors (vector is busy)";
2608 subtype Src_Index_Subtype is Index_Type'Base range
2609 Index_Type'First .. Container.Last;
2611 Src : Elements_Array renames
2612 Container.Elements.EA (Src_Index_Subtype);
2614 X : Elements_Access := Container.Elements;
2617 -- Although we have isolated the old internal array that we're
2618 -- going to deallocate, we don't deallocate it until we have
2619 -- successfully allocated a new one. If there is an exception
2620 -- during allocation (either because there is not enough
2621 -- storage, or because initialization of the elements fails),
2622 -- we let it propagate without causing any side-effect.
2624 Container.Elements := new Elements_Type'(Container.Last, Src);
2626 -- We have successfully allocated a new internal array (with a
2627 -- smaller length than the old one, and containing a copy of
2628 -- just the active elements in the container), so it is now
2629 -- safe to attempt to deallocate the old array. The old array
2630 -- has been isolated, and container invariants have been
2631 -- restored, so if the deallocation fails (because finalization
2632 -- of the elements fails), we simply let it propagate.
2641 -- Reserve_Capacity can be used to expand the storage available for
2642 -- elements, but we do not let the capacity grow beyond the number of
2643 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2644 -- to refer to the elements with an index value greater than
2645 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2646 -- the Last index value of the new internal array, in a way that avoids
2647 -- any possibility of overflow.
2649 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2651 -- We perform a two-part test. First we determine whether the
2652 -- computed Last value lies in the base range of the type, and then
2653 -- determine whether it lies in the range of the index (sub)type.
2655 -- Last must satisfy this relation:
2656 -- First + Length - 1 <= Last
2657 -- We regroup terms:
2658 -- First - 1 <= Last - Length
2659 -- Which can rewrite as:
2660 -- No_Index <= Last - Length
2662 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
2663 raise Constraint_Error with "Capacity is out of range";
2666 -- We now know that the computed value of Last is within the base
2667 -- range of the type, so it is safe to compute its value:
2669 Last := No_Index + Index_Type'Base (Capacity);
2671 -- Finally we test whether the value is within the range of the
2672 -- generic actual index subtype:
2674 if Last > Index_Type'Last then
2675 raise Constraint_Error with "Capacity is out of range";
2678 elsif Index_Type'First <= 0 then
2680 -- Here we can compute Last directly, in the normal way. We know that
2681 -- No_Index is less than 0, so there is no danger of overflow when
2682 -- adding the (positive) value of Capacity.
2684 Index := Count_Type'Base (No_Index) + Capacity; -- Last
2686 if Index > Count_Type'Base (Index_Type'Last) then
2687 raise Constraint_Error with "Capacity is out of range";
2690 -- We know that the computed value (having type Count_Type) of Last
2691 -- is within the range of the generic actual index subtype, so it is
2692 -- safe to convert to Index_Type:
2694 Last := Index_Type'Base (Index);
2697 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2698 -- must test the length indirectly (by working backwards from the
2699 -- largest possible value of Last), in order to prevent overflow.
2701 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
2703 if Index < Count_Type'Base (No_Index) then
2704 raise Constraint_Error with "Capacity is out of range";
2707 -- We have determined that the value of Capacity would not create a
2708 -- Last index value outside of the range of Index_Type, so we can now
2709 -- safely compute its value.
2711 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
2714 -- The requested capacity is non-zero, but we don't know yet whether
2715 -- this is a request for expansion or contraction of storage.
2717 if Container.Elements = null then
2719 -- The container is empty (it doesn't even have an internal array),
2720 -- so this represents a request to allocate (expand) storage having
2721 -- the given capacity.
2723 Container.Elements := new Elements_Type (Last);
2727 if Capacity <= N then
2729 -- This is a request to trim back storage, but only to the limit of
2730 -- what's already in the container. (Reserve_Capacity never deletes
2731 -- active elements, it only reclaims excess storage.)
2733 if N < Container.Elements.EA'Length then
2735 -- The container is not empty (because the requested capacity is
2736 -- positive, and less than or equal to the container length), and
2737 -- the current length is less than the current capacity, so
2738 -- there's storage available to trim. In this case, we allocate a
2739 -- new internal array having a length that exactly matches the
2740 -- number of items in the container.
2742 if Container.Busy > 0 then
2743 raise Program_Error with
2744 "attempt to tamper with cursors (vector is busy)";
2748 subtype Src_Index_Subtype is Index_Type'Base range
2749 Index_Type'First .. Container.Last;
2751 Src : Elements_Array renames
2752 Container.Elements.EA (Src_Index_Subtype);
2754 X : Elements_Access := Container.Elements;
2757 -- Although we have isolated the old internal array that we're
2758 -- going to deallocate, we don't deallocate it until we have
2759 -- successfully allocated a new one. If there is an exception
2760 -- during allocation (either because there is not enough
2761 -- storage, or because initialization of the elements fails),
2762 -- we let it propagate without causing any side-effect.
2764 Container.Elements := new Elements_Type'(Container.Last, Src);
2766 -- We have successfully allocated a new internal array (with a
2767 -- smaller length than the old one, and containing a copy of
2768 -- just the active elements in the container), so it is now
2769 -- safe to attempt to deallocate the old array. The old array
2770 -- has been isolated, and container invariants have been
2771 -- restored, so if the deallocation fails (because finalization
2772 -- of the elements fails), we simply let it propagate.
2781 -- The requested capacity is larger than the container length (the
2782 -- number of active elements). Whether this represents a request for
2783 -- expansion or contraction of the current capacity depends on what the
2784 -- current capacity is.
2786 if Capacity = Container.Elements.EA'Length then
2788 -- The requested capacity matches the existing capacity, so there's
2789 -- nothing to do here. We treat this case as a no-op, and simply
2790 -- return without checking the busy bit.
2795 -- There is a change in the capacity of a non-empty container, so a new
2796 -- internal array will be allocated. (The length of the new internal
2797 -- array could be less or greater than the old internal array. We know
2798 -- only that the length of the new internal array is greater than the
2799 -- number of active elements in the container.) We must check whether
2800 -- the container is busy before doing anything else.
2802 if Container.Busy > 0 then
2803 raise Program_Error with
2804 "attempt to tamper with cursors (vector is busy)";
2807 -- We now allocate a new internal array, having a length different from
2808 -- its current value.
2811 E : Elements_Access := new Elements_Type (Last);
2814 -- We have successfully allocated the new internal array. We first
2815 -- attempt to copy the existing elements from the old internal array
2816 -- ("src" elements) onto the new internal array ("tgt" elements).
2819 subtype Index_Subtype is Index_Type'Base range
2820 Index_Type'First .. Container.Last;
2822 Src : Elements_Array renames
2823 Container.Elements.EA (Index_Subtype);
2825 Tgt : Elements_Array renames E.EA (Index_Subtype);
2836 -- We have successfully copied the existing elements onto the new
2837 -- internal array, so now we can attempt to deallocate the old one.
2840 X : Elements_Access := Container.Elements;
2843 -- First we isolate the old internal array, and replace it in the
2844 -- container with the new internal array.
2846 Container.Elements := E;
2848 -- Container invariants have been restored, so it is now safe to
2849 -- attempt to deallocate the old internal array.
2854 end Reserve_Capacity;
2856 ----------------------
2857 -- Reverse_Elements --
2858 ----------------------
2860 procedure Reverse_Elements (Container : in out Vector) is
2862 if Container.Length <= 1 then
2866 if Container.Lock > 0 then
2867 raise Program_Error with
2868 "attempt to tamper with elements (vector is locked)";
2873 E : Elements_Type renames Container.Elements.all;
2876 I := Index_Type'First;
2877 J := Container.Last;
2880 EI : constant Element_Type := E.EA (I);
2883 E.EA (I) := E.EA (J);
2891 end Reverse_Elements;
2897 function Reverse_Find
2898 (Container : Vector;
2899 Item : Element_Type;
2900 Position : Cursor := No_Element) return Cursor
2902 Last : Index_Type'Base;
2905 if Position.Container /= null
2906 and then Position.Container /= Container'Unchecked_Access
2908 raise Program_Error with "Position cursor denotes wrong container";
2912 (if Position.Container = null or else Position.Index > Container.Last
2914 else Position.Index);
2916 for Indx in reverse Index_Type'First .. Last loop
2917 if Container.Elements.EA (Indx) = Item then
2918 return (Container'Unchecked_Access, Indx);
2925 ------------------------
2926 -- Reverse_Find_Index --
2927 ------------------------
2929 function Reverse_Find_Index
2930 (Container : Vector;
2931 Item : Element_Type;
2932 Index : Index_Type := Index_Type'Last) return Extended_Index
2934 Last : constant Index_Type'Base :=
2935 Index_Type'Min (Container.Last, Index);
2938 for Indx in reverse Index_Type'First .. Last loop
2939 if Container.Elements.EA (Indx) = Item then
2945 end Reverse_Find_Index;
2947 ---------------------
2948 -- Reverse_Iterate --
2949 ---------------------
2951 procedure Reverse_Iterate
2952 (Container : Vector;
2953 Process : not null access procedure (Position : Cursor))
2955 V : Vector renames Container'Unrestricted_Access.all;
2956 B : Natural renames V.Busy;
2962 for Indx in reverse Index_Type'First .. Container.Last loop
2963 Process (Cursor'(Container'Unchecked_Access, Indx));
2972 end Reverse_Iterate;
2978 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2979 Count : constant Count_Type'Base := Container.Length - Length;
2982 -- Set_Length allows the user to set the length explicitly, instead of
2983 -- implicitly as a side-effect of deletion or insertion. If the
2984 -- requested length is less then the current length, this is equivalent
2985 -- to deleting items from the back end of the vector. If the requested
2986 -- length is greater than the current length, then this is equivalent to
2987 -- inserting "space" (nonce items) at the end.
2990 Container.Delete_Last (Count);
2992 elsif Container.Last >= Index_Type'Last then
2993 raise Constraint_Error with "vector is already at its maximum length";
2996 Container.Insert_Space (Container.Last + 1, -Count);
3004 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3006 if I > Container.Last then
3007 raise Constraint_Error with "I index is out of range";
3010 if J > Container.Last then
3011 raise Constraint_Error with "J index is out of range";
3018 if Container.Lock > 0 then
3019 raise Program_Error with
3020 "attempt to tamper with elements (vector is locked)";
3024 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3026 Container.Elements.EA (I) := Container.Elements.EA (J);
3027 Container.Elements.EA (J) := EI_Copy;
3031 procedure Swap (Container : in out Vector; I, J : Cursor) is
3033 if I.Container = null then
3034 raise Constraint_Error with "I cursor has no element";
3037 if J.Container = null then
3038 raise Constraint_Error with "J cursor has no element";
3041 if I.Container /= Container'Unrestricted_Access then
3042 raise Program_Error with "I cursor denotes wrong container";
3045 if J.Container /= Container'Unrestricted_Access then
3046 raise Program_Error with "J cursor denotes wrong container";
3049 Swap (Container, I.Index, J.Index);
3057 (Container : Vector;
3058 Index : Extended_Index) return Cursor
3061 if Index not in Index_Type'First .. Container.Last then
3064 return (Container'Unchecked_Access, Index);
3072 function To_Index (Position : Cursor) return Extended_Index is
3074 if Position.Container = null then
3078 if Position.Index <= Position.Container.Last then
3079 return Position.Index;
3089 function To_Vector (Length : Count_Type) return Vector is
3090 Index : Count_Type'Base;
3091 Last : Index_Type'Base;
3092 Elements : Elements_Access;
3096 return Empty_Vector;
3099 -- We create a vector object with a capacity that matches the specified
3100 -- Length, but we do not allow the vector capacity (the length of the
3101 -- internal array) to exceed the number of values in Index_Type'Range
3102 -- (otherwise, there would be no way to refer to those components via an
3103 -- index). We must therefore check whether the specified Length would
3104 -- create a Last index value greater than Index_Type'Last.
3106 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3108 -- We perform a two-part test. First we determine whether the
3109 -- computed Last value lies in the base range of the type, and then
3110 -- determine whether it lies in the range of the index (sub)type.
3112 -- Last must satisfy this relation:
3113 -- First + Length - 1 <= Last
3114 -- We regroup terms:
3115 -- First - 1 <= Last - Length
3116 -- Which can rewrite as:
3117 -- No_Index <= Last - Length
3119 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3120 raise Constraint_Error with "Length is out of range";
3123 -- We now know that the computed value of Last is within the base
3124 -- range of the type, so it is safe to compute its value:
3126 Last := No_Index + Index_Type'Base (Length);
3128 -- Finally we test whether the value is within the range of the
3129 -- generic actual index subtype:
3131 if Last > Index_Type'Last then
3132 raise Constraint_Error with "Length is out of range";
3135 elsif Index_Type'First <= 0 then
3137 -- Here we can compute Last directly, in the normal way. We know that
3138 -- No_Index is less than 0, so there is no danger of overflow when
3139 -- adding the (positive) value of Length.
3141 Index := Count_Type'Base (No_Index) + Length; -- Last
3143 if Index > Count_Type'Base (Index_Type'Last) then
3144 raise Constraint_Error with "Length is out of range";
3147 -- We know that the computed value (having type Count_Type) of Last
3148 -- is within the range of the generic actual index subtype, so it is
3149 -- safe to convert to Index_Type:
3151 Last := Index_Type'Base (Index);
3154 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3155 -- must test the length indirectly (by working backwards from the
3156 -- largest possible value of Last), in order to prevent overflow.
3158 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3160 if Index < Count_Type'Base (No_Index) then
3161 raise Constraint_Error with "Length is out of range";
3164 -- We have determined that the value of Length would not create a
3165 -- Last index value outside of the range of Index_Type, so we can now
3166 -- safely compute its value.
3168 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3171 Elements := new Elements_Type (Last);
3173 return Vector'(Controlled with Elements, Last, 0, 0);
3177 (New_Item : Element_Type;
3178 Length : Count_Type) return Vector
3180 Index : Count_Type'Base;
3181 Last : Index_Type'Base;
3182 Elements : Elements_Access;
3186 return Empty_Vector;
3189 -- We create a vector object with a capacity that matches the specified
3190 -- Length, but we do not allow the vector capacity (the length of the
3191 -- internal array) to exceed the number of values in Index_Type'Range
3192 -- (otherwise, there would be no way to refer to those components via an
3193 -- index). We must therefore check whether the specified Length would
3194 -- create a Last index value greater than Index_Type'Last.
3196 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3198 -- We perform a two-part test. First we determine whether the
3199 -- computed Last value lies in the base range of the type, and then
3200 -- determine whether it lies in the range of the index (sub)type.
3202 -- Last must satisfy this relation:
3203 -- First + Length - 1 <= Last
3204 -- We regroup terms:
3205 -- First - 1 <= Last - Length
3206 -- Which can rewrite as:
3207 -- No_Index <= Last - Length
3209 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3210 raise Constraint_Error with "Length is out of range";
3213 -- We now know that the computed value of Last is within the base
3214 -- range of the type, so it is safe to compute its value:
3216 Last := No_Index + Index_Type'Base (Length);
3218 -- Finally we test whether the value is within the range of the
3219 -- generic actual index subtype:
3221 if Last > Index_Type'Last then
3222 raise Constraint_Error with "Length is out of range";
3225 elsif Index_Type'First <= 0 then
3226 -- Here we can compute Last directly, in the normal way. We know that
3227 -- No_Index is less than 0, so there is no danger of overflow when
3228 -- adding the (positive) value of Length.
3230 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
3232 if Index > Count_Type'Base (Index_Type'Last) then
3233 raise Constraint_Error with "Length is out of range";
3236 -- We know that the computed value (having type Count_Type) of Last
3237 -- is within the range of the generic actual index subtype, so it is
3238 -- safe to convert to Index_Type:
3240 Last := Index_Type'Base (Index);
3243 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3244 -- must test the length indirectly (by working backwards from the
3245 -- largest possible value of Last), in order to prevent overflow.
3247 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3249 if Index < Count_Type'Base (No_Index) then
3250 raise Constraint_Error with "Length is out of range";
3253 -- We have determined that the value of Length would not create a
3254 -- Last index value outside of the range of Index_Type, so we can now
3255 -- safely compute its value.
3257 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3260 Elements := new Elements_Type'(Last, EA => (others => New_Item));
3262 return Vector'(Controlled with Elements, Last, 0, 0);
3265 --------------------
3266 -- Update_Element --
3267 --------------------
3269 procedure Update_Element
3270 (Container : in out Vector;
3272 Process : not null access procedure (Element : in out Element_Type))
3274 B : Natural renames Container.Busy;
3275 L : Natural renames Container.Lock;
3278 if Index > Container.Last then
3279 raise Constraint_Error with "Index is out of range";
3286 Process (Container.Elements.EA (Index));
3298 procedure Update_Element
3299 (Container : in out Vector;
3301 Process : not null access procedure (Element : in out Element_Type))
3304 if Position.Container = null then
3305 raise Constraint_Error with "Position cursor has no element";
3308 if Position.Container /= Container'Unrestricted_Access then
3309 raise Program_Error with "Position cursor denotes wrong container";
3312 Update_Element (Container, Position.Index, Process);
3320 (Stream : not null access Root_Stream_Type'Class;
3324 Count_Type'Base'Write (Stream, Length (Container));
3326 for J in Index_Type'First .. Container.Last loop
3327 Element_Type'Write (Stream, Container.Elements.EA (J));
3332 (Stream : not null access Root_Stream_Type'Class;
3336 raise Program_Error with "attempt to stream vector cursor";
3340 (Stream : not null access Root_Stream_Type'Class;
3341 Item : Reference_Type)
3344 raise Program_Error with "attempt to stream reference";
3348 (Stream : not null access Root_Stream_Type'Class;
3349 Item : Constant_Reference_Type)
3352 raise Program_Error with "attempt to stream reference";
3355 end Ada.Containers.Vectors;