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-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada.Containers.Generic_Array_Sort;
31 with Ada.Unchecked_Deallocation;
33 with System; use type System.Address;
35 package body Ada.Containers.Vectors is
38 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
40 type Iterator is new Limited_Controlled and
41 Vector_Iterator_Interfaces.Reversible_Iterator with
43 Container : Vector_Access;
44 Index : Index_Type'Base;
47 overriding procedure Finalize (Object : in out Iterator);
49 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 index 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 : constant Elements_Access :=
91 new Elements_Type'(Right.Last, RE);
94 return (Controlled with Elements, Right.Last, 0, 0);
100 LE : Elements_Array renames
101 Left.Elements.EA (Index_Type'First .. Left.Last);
103 Elements : constant Elements_Access :=
104 new Elements_Type'(Left.Last, LE);
107 return (Controlled with Elements, Left.Last, 0, 0);
112 -- Neither of the vector parameters is empty, so must compute the length
113 -- of the result vector and its last index. (This is the harder case,
114 -- because our computations must avoid overflow.)
116 -- There are two constraints we need to satisfy. The first constraint is
117 -- that a container cannot have more than Count_Type'Last elements, so
118 -- we must check the sum of the combined lengths. Note that we cannot
119 -- simply add the lengths, because of the possibility of overflow.
121 if LN > Count_Type'Last - RN then
122 raise Constraint_Error with "new length is out of range";
125 -- It is now safe compute the length of the new vector, without fear of
130 -- The second constraint is that the new Last index value cannot
131 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
132 -- Count_Type'Base as the type for intermediate values.
134 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
136 -- We perform a two-part test. First we determine whether the
137 -- computed Last value lies in the base range of the type, and then
138 -- determine whether it lies in the range of the index (sub)type.
140 -- Last must satisfy this relation:
141 -- First + Length - 1 <= Last
143 -- First - 1 <= Last - Length
144 -- Which can rewrite as:
145 -- No_Index <= Last - Length
147 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
148 raise Constraint_Error with "new length is out of range";
151 -- We now know that the computed value of Last is within the base
152 -- range of the type, so it is safe to compute its value:
154 Last := No_Index + Index_Type'Base (N);
156 -- Finally we test whether the value is within the range of the
157 -- generic actual index subtype:
159 if Last > Index_Type'Last then
160 raise Constraint_Error with "new length is out of range";
163 elsif Index_Type'First <= 0 then
165 -- Here we can compute Last directly, in the normal way. We know that
166 -- No_Index is less than 0, so there is no danger of overflow when
167 -- adding the (positive) value of length.
169 J := Count_Type'Base (No_Index) + N; -- Last
171 if J > Count_Type'Base (Index_Type'Last) then
172 raise Constraint_Error with "new length is out of range";
175 -- We know that the computed value (having type Count_Type) of Last
176 -- is within the range of the generic actual index subtype, so it is
177 -- safe to convert to Index_Type:
179 Last := Index_Type'Base (J);
182 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
183 -- must test the length indirectly (by working backwards from the
184 -- largest possible value of Last), in order to prevent overflow.
186 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
188 if J < Count_Type'Base (No_Index) then
189 raise Constraint_Error with "new length is out of range";
192 -- We have determined that the result length would not create a Last
193 -- index value outside of the range of Index_Type, so we can now
194 -- safely compute its value.
196 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
200 LE : Elements_Array renames
201 Left.Elements.EA (Index_Type'First .. Left.Last);
203 RE : Elements_Array renames
204 Right.Elements.EA (Index_Type'First .. Right.Last);
206 Elements : constant Elements_Access :=
207 new Elements_Type'(Last, LE & RE);
210 return (Controlled with Elements, Last, 0, 0);
214 function "&" (Left : Vector; Right : Element_Type) return Vector is
216 -- We decide that the capacity of the result is the sum of the lengths
217 -- of the parameters. We could decide to make it larger, but we have no
218 -- basis for knowing how much larger, so we just allocate the minimum
219 -- amount of storage.
221 -- Handle easy case first, when the vector parameter (Left) is empty
223 if Left.Is_Empty then
225 Elements : constant Elements_Access :=
227 (Last => Index_Type'First,
228 EA => (others => Right));
231 return (Controlled with Elements, Index_Type'First, 0, 0);
235 -- The vector parameter is not empty, so we must compute the length of
236 -- the result vector and its last index, but in such a way that overflow
237 -- is avoided. We must satisfy two constraints: the new length cannot
238 -- exceed Count_Type'Last, and the new Last index cannot exceed
241 if Left.Length = Count_Type'Last then
242 raise Constraint_Error with "new length is out of range";
245 if Left.Last >= Index_Type'Last then
246 raise Constraint_Error with "new length is out of range";
250 Last : constant Index_Type := Left.Last + 1;
252 LE : Elements_Array renames
253 Left.Elements.EA (Index_Type'First .. Left.Last);
255 Elements : constant Elements_Access :=
256 new Elements_Type'(Last => Last, EA => LE & Right);
259 return (Controlled with Elements, Last, 0, 0);
263 function "&" (Left : Element_Type; Right : Vector) return Vector is
265 -- We decide that the capacity of the result is the sum of the lengths
266 -- of the parameters. We could decide to make it larger, but we have no
267 -- basis for knowing how much larger, so we just allocate the minimum
268 -- amount of storage.
270 -- Handle easy case first, when the vector parameter (Right) is empty
272 if Right.Is_Empty then
274 Elements : constant Elements_Access :=
276 (Last => Index_Type'First,
277 EA => (others => Left));
280 return (Controlled with Elements, Index_Type'First, 0, 0);
284 -- The vector parameter is not empty, so we must compute the length of
285 -- the result vector and its last index, but in such a way that overflow
286 -- is avoided. We must satisfy two constraints: the new length cannot
287 -- exceed Count_Type'Last, and the new Last index cannot exceed
290 if Right.Length = Count_Type'Last then
291 raise Constraint_Error with "new length is out of range";
294 if Right.Last >= Index_Type'Last then
295 raise Constraint_Error with "new length is out of range";
299 Last : constant Index_Type := Right.Last + 1;
301 RE : Elements_Array renames
302 Right.Elements.EA (Index_Type'First .. Right.Last);
304 Elements : constant Elements_Access :=
310 return (Controlled with Elements, Last, 0, 0);
314 function "&" (Left, Right : Element_Type) return Vector is
316 -- We decide that the capacity of the result is the sum of the lengths
317 -- of the parameters. We could decide to make it larger, but we have no
318 -- basis for knowing how much larger, so we just allocate the minimum
319 -- amount of storage.
321 -- We must compute the length of the result vector and its last index,
322 -- but in such a way that overflow is avoided. We must satisfy two
323 -- constraints: the new length cannot exceed Count_Type'Last (here, we
324 -- know that that condition is satisfied), and the new Last index cannot
325 -- exceed Index_Type'Last.
327 if Index_Type'First >= Index_Type'Last then
328 raise Constraint_Error with "new length is out of range";
332 Last : constant Index_Type := Index_Type'First + 1;
334 Elements : constant Elements_Access :=
337 EA => (Left, Right));
340 return (Controlled with Elements, Last, 0, 0);
348 overriding function "=" (Left, Right : Vector) return Boolean is
350 if Left'Address = Right'Address then
354 if Left.Last /= Right.Last then
358 for J in Index_Type range Index_Type'First .. Left.Last loop
359 if Left.Elements.EA (J) /= Right.Elements.EA (J) then
371 procedure Adjust (Container : in out Vector) is
373 if Container.Last = No_Index then
374 Container.Elements := null;
379 L : constant Index_Type := Container.Last;
380 EA : Elements_Array renames
381 Container.Elements.EA (Index_Type'First .. L);
384 Container.Elements := null;
388 -- Note: it may seem that the following assignment to Container.Last
389 -- is useless, since we assign it to L below. However this code is
390 -- used in case 'new Elements_Type' below raises an exception, to
391 -- keep Container in a consistent state.
393 Container.Last := No_Index;
394 Container.Elements := new Elements_Type'(L, EA);
403 procedure Append (Container : in out Vector; New_Item : Vector) is
405 if Is_Empty (New_Item) then
409 if Container.Last = Index_Type'Last then
410 raise Constraint_Error with "vector is already at its maximum length";
420 (Container : in out Vector;
421 New_Item : Element_Type;
422 Count : Count_Type := 1)
429 if Container.Last = Index_Type'Last then
430 raise Constraint_Error with "vector is already at its maximum length";
444 procedure Assign (Target : in out Vector; Source : Vector) is
446 if Target'Address = Source'Address then
451 Target.Append (Source);
458 function Capacity (Container : Vector) return Count_Type is
460 if Container.Elements = null then
463 return Container.Elements.EA'Length;
471 procedure Clear (Container : in out Vector) is
473 if Container.Busy > 0 then
474 raise Program_Error with
475 "attempt to tamper with cursors (vector is busy)";
477 Container.Last := No_Index;
481 ------------------------
482 -- Constant_Reference --
483 ------------------------
485 function Constant_Reference
486 (Container : aliased Vector;
487 Position : Cursor) return Constant_Reference_Type
490 if Position.Container = null then
491 raise Constraint_Error with "Position cursor has no element";
494 if Position.Container /= Container'Unrestricted_Access then
495 raise Program_Error with "Position cursor denotes wrong container";
498 if Position.Index > Position.Container.Last then
499 raise Constraint_Error with "Position cursor is out of range";
502 return (Element => Container.Elements.EA (Position.Index)'Access);
503 end Constant_Reference;
505 function Constant_Reference
506 (Container : aliased Vector;
507 Index : Index_Type) return Constant_Reference_Type
510 if Index > Container.Last then
511 raise Constraint_Error with "Index is out of range";
513 return (Element => Container.Elements.EA (Index)'Access);
515 end Constant_Reference;
523 Item : Element_Type) return Boolean
526 return Find_Index (Container, Item) /= No_Index;
535 Capacity : Count_Type := 0) return Vector
543 elsif Capacity >= Source.Length then
548 with "Requested capacity is less than Source length";
551 return Target : Vector do
552 Target.Reserve_Capacity (C);
553 Target.Assign (Source);
562 (Container : in out Vector;
563 Index : Extended_Index;
564 Count : Count_Type := 1)
566 Old_Last : constant Index_Type'Base := Container.Last;
567 New_Last : Index_Type'Base;
568 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
569 J : Index_Type'Base; -- first index of items that slide down
572 -- Delete removes items from the vector, the number of which is the
573 -- minimum of the specified Count and the items (if any) that exist from
574 -- Index to Container.Last. There are no constraints on the specified
575 -- value of Count (it can be larger than what's available at this
576 -- position in the vector, for example), but there are constraints on
577 -- the allowed values of the Index.
579 -- As a precondition on the generic actual Index_Type, the base type
580 -- must include Index_Type'Pred (Index_Type'First); this is the value
581 -- that Container.Last assumes when the vector is empty. However, we do
582 -- not allow that as the value for Index when specifying which items
583 -- should be deleted, so we must manually check. (That the user is
584 -- allowed to specify the value at all here is a consequence of the
585 -- declaration of the Extended_Index subtype, which includes the values
586 -- in the base range that immediately precede and immediately follow the
587 -- values in the Index_Type.)
589 if Index < Index_Type'First then
590 raise Constraint_Error with "Index is out of range (too small)";
593 -- We do allow a value greater than Container.Last to be specified as
594 -- the Index, but only if it's immediately greater. This allows the
595 -- corner case of deleting no items from the back end of the vector to
596 -- be treated as a no-op. (It is assumed that specifying an index value
597 -- greater than Last + 1 indicates some deeper flaw in the caller's
598 -- algorithm, so that case is treated as a proper error.)
600 if Index > Old_Last then
601 if Index > Old_Last + 1 then
602 raise Constraint_Error with "Index is out of range (too large)";
608 -- Here and elsewhere we treat deleting 0 items from the container as a
609 -- no-op, even when the container is busy, so we simply return.
615 -- The tampering bits exist to prevent an item from being deleted (or
616 -- otherwise harmfully manipulated) while it is being visited. Query,
617 -- Update, and Iterate increment the busy count on entry, and decrement
618 -- the count on exit. Delete checks the count to determine whether it is
619 -- being called while the associated callback procedure is executing.
621 if Container.Busy > 0 then
622 raise Program_Error with
623 "attempt to tamper with cursors (vector is busy)";
626 -- We first calculate what's available for deletion starting at
627 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
628 -- Count_Type'Base as the type for intermediate values. (See function
629 -- Length for more information.)
631 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
632 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
635 Count2 := Count_Type'Base (Old_Last - Index + 1);
638 -- If more elements are requested (Count) for deletion than are
639 -- available (Count2) for deletion beginning at Index, then everything
640 -- from Index is deleted. There are no elements to slide down, and so
641 -- all we need to do is set the value of Container.Last.
643 if Count >= Count2 then
644 Container.Last := Index - 1;
648 -- There are some elements aren't being deleted (the requested count was
649 -- less than the available count), so we must slide them down to
650 -- Index. We first calculate the index values of the respective array
651 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
652 -- type for intermediate calculations. For the elements that slide down,
653 -- index value New_Last is the last index value of their new home, and
654 -- index value J is the first index of their old home.
656 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
657 New_Last := Old_Last - Index_Type'Base (Count);
658 J := Index + Index_Type'Base (Count);
661 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
662 J := Index_Type'Base (Count_Type'Base (Index) + Count);
665 -- The internal elements array isn't guaranteed to exist unless we have
666 -- elements, but we have that guarantee here because we know we have
667 -- elements to slide. The array index values for each slice have
668 -- already been determined, so we just slide down to Index the elements
669 -- that weren't deleted.
672 EA : Elements_Array renames Container.Elements.EA;
675 EA (Index .. New_Last) := EA (J .. Old_Last);
676 Container.Last := New_Last;
681 (Container : in out Vector;
682 Position : in out Cursor;
683 Count : Count_Type := 1)
685 pragma Warnings (Off, Position);
688 if Position.Container = null then
689 raise Constraint_Error with "Position cursor has no element";
692 if Position.Container /= Container'Unrestricted_Access then
693 raise Program_Error with "Position cursor denotes wrong container";
696 if Position.Index > Container.Last then
697 raise Program_Error with "Position index is out of range";
700 Delete (Container, Position.Index, Count);
701 Position := No_Element;
708 procedure Delete_First
709 (Container : in out Vector;
710 Count : Count_Type := 1)
717 if Count >= Length (Container) then
722 Delete (Container, Index_Type'First, Count);
729 procedure Delete_Last
730 (Container : in out Vector;
731 Count : Count_Type := 1)
734 -- It is not permitted to delete items while the container is busy (for
735 -- example, we're in the middle of a passive iteration). However, we
736 -- always treat deleting 0 items as a no-op, even when we're busy, so we
737 -- simply return without checking.
743 -- The tampering bits exist to prevent an item from being deleted (or
744 -- otherwise harmfully manipulated) while it is being visited. Query,
745 -- Update, and Iterate increment the busy count on entry, and decrement
746 -- the count on exit. Delete_Last checks the count to determine whether
747 -- it is being called while the associated callback procedure is
750 if Container.Busy > 0 then
751 raise Program_Error with
752 "attempt to tamper with cursors (vector is busy)";
755 -- There is no restriction on how large Count can be when deleting
756 -- items. If it is equal or greater than the current length, then this
757 -- is equivalent to clearing the vector. (In particular, there's no need
758 -- for us to actually calculate the new value for Last.)
760 -- If the requested count is less than the current length, then we must
761 -- calculate the new value for Last. For the type we use the widest of
762 -- Index_Type'Base and Count_Type'Base for the intermediate values of
763 -- our calculation. (See the comments in Length for more information.)
765 if Count >= Container.Length then
766 Container.Last := No_Index;
768 elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
769 Container.Last := Container.Last - Index_Type'Base (Count);
773 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
783 Index : Index_Type) return Element_Type
786 if Index > Container.Last then
787 raise Constraint_Error with "Index is out of range";
790 return Container.Elements.EA (Index);
793 function Element (Position : Cursor) return Element_Type is
795 if Position.Container = null then
796 raise Constraint_Error with "Position cursor has no element";
797 elsif Position.Index > Position.Container.Last then
798 raise Constraint_Error with "Position cursor is out of range";
800 return Position.Container.Elements.EA (Position.Index);
808 procedure Finalize (Container : in out Vector) is
809 X : Elements_Access := Container.Elements;
812 if Container.Busy > 0 then
813 raise Program_Error with
814 "attempt to tamper with cursors (vector is busy)";
817 Container.Elements := null;
818 Container.Last := No_Index;
822 procedure Finalize (Object : in out Iterator) is
823 B : Natural renames Object.Container.Busy;
835 Position : Cursor := No_Element) return Cursor
838 if Position.Container /= null then
839 if Position.Container /= Container'Unrestricted_Access then
840 raise Program_Error with "Position cursor denotes wrong container";
843 if Position.Index > Container.Last then
844 raise Program_Error with "Position index is out of range";
848 for J in Position.Index .. Container.Last loop
849 if Container.Elements.EA (J) = Item then
850 return (Container'Unrestricted_Access, J);
864 Index : Index_Type := Index_Type'First) return Extended_Index
867 for Indx in Index .. Container.Last loop
868 if Container.Elements.EA (Indx) = Item then
880 function First (Container : Vector) return Cursor is
882 if Is_Empty (Container) then
885 return (Container'Unrestricted_Access, Index_Type'First);
889 function First (Object : Iterator) return Cursor is
891 -- The value of the iterator object's Index component influences the
892 -- behavior of the First (and Last) selector function.
894 -- When the Index component is No_Index, this means the iterator
895 -- object was constructed without a start expression, in which case the
896 -- (forward) iteration starts from the (logical) beginning of the entire
897 -- sequence of items (corresponding to Container.First, for a forward
900 -- Otherwise, this is iteration over a partial sequence of items.
901 -- When the Index component isn't No_Index, the iterator object was
902 -- constructed with a start expression, that specifies the position
903 -- from which the (forward) partial iteration begins.
905 if Object.Index = No_Index then
906 return First (Object.Container.all);
908 return Cursor'(Object.Container, Object.Index);
916 function First_Element (Container : Vector) return Element_Type is
918 if Container.Last = No_Index then
919 raise Constraint_Error with "Container is empty";
921 return Container.Elements.EA (Index_Type'First);
929 function First_Index (Container : Vector) return Index_Type is
930 pragma Unreferenced (Container);
932 return Index_Type'First;
935 ---------------------
936 -- Generic_Sorting --
937 ---------------------
939 package body Generic_Sorting is
945 function Is_Sorted (Container : Vector) return Boolean is
947 if Container.Last <= Index_Type'First then
952 EA : Elements_Array renames Container.Elements.EA;
954 for J in Index_Type'First .. Container.Last - 1 loop
955 if EA (J + 1) < EA (J) then
968 procedure Merge (Target, Source : in out Vector) is
969 I : Index_Type'Base := Target.Last;
973 -- The semantics of Merge changed slightly per AI05-0021. It was
974 -- originally the case that if Target and Source denoted the same
975 -- container object, then the GNAT implementation of Merge did
976 -- nothing. However, it was argued that RM05 did not precisely
977 -- specify the semantics for this corner case. The decision of the
978 -- ARG was that if Target and Source denote the same non-empty
979 -- container object, then Program_Error is raised.
981 if Source.Last < Index_Type'First then -- Source is empty
985 if Target'Address = Source'Address then
986 raise Program_Error with
987 "Target and Source denote same non-empty container";
990 if Target.Last < Index_Type'First then -- Target is empty
991 Move (Target => Target, Source => Source);
995 if Source.Busy > 0 then
996 raise Program_Error with
997 "attempt to tamper with cursors (vector is busy)";
1000 Target.Set_Length (Length (Target) + Length (Source));
1003 TA : Elements_Array renames Target.Elements.EA;
1004 SA : Elements_Array renames Source.Elements.EA;
1008 while Source.Last >= Index_Type'First loop
1009 pragma Assert (Source.Last <= Index_Type'First
1010 or else not (SA (Source.Last) <
1011 SA (Source.Last - 1)));
1013 if I < Index_Type'First then
1014 TA (Index_Type'First .. J) :=
1015 SA (Index_Type'First .. Source.Last);
1017 Source.Last := No_Index;
1021 pragma Assert (I <= Index_Type'First
1022 or else not (TA (I) < TA (I - 1)));
1024 if SA (Source.Last) < TA (I) then
1029 TA (J) := SA (Source.Last);
1030 Source.Last := Source.Last - 1;
1042 procedure Sort (Container : in out Vector) is
1044 new Generic_Array_Sort
1045 (Index_Type => Index_Type,
1046 Element_Type => Element_Type,
1047 Array_Type => Elements_Array,
1051 if Container.Last <= Index_Type'First then
1055 -- The exception behavior for the vector container must match that
1056 -- for the list container, so we check for cursor tampering here
1057 -- (which will catch more things) instead of for element tampering
1058 -- (which will catch fewer things). It's true that the elements of
1059 -- this vector container could be safely moved around while (say) an
1060 -- iteration is taking place (iteration only increments the busy
1061 -- counter), and so technically all we would need here is a test for
1062 -- element tampering (indicated by the lock counter), that's simply
1063 -- an artifact of our array-based implementation. Logically Sort
1064 -- requires a check for cursor tampering.
1066 if Container.Busy > 0 then
1067 raise Program_Error with
1068 "attempt to tamper with cursors (vector is busy)";
1071 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1074 end Generic_Sorting;
1080 function Has_Element (Position : Cursor) return Boolean is
1082 return Position /= No_Element;
1090 (Container : in out Vector;
1091 Before : Extended_Index;
1092 New_Item : Element_Type;
1093 Count : Count_Type := 1)
1095 Old_Length : constant Count_Type := Container.Length;
1097 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1098 New_Length : Count_Type'Base; -- sum of current length and Count
1099 New_Last : Index_Type'Base; -- last index of vector after insertion
1101 Index : Index_Type'Base; -- scratch for intermediate values
1102 J : Count_Type'Base; -- scratch
1104 New_Capacity : Count_Type'Base; -- length of new, expanded array
1105 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1106 Dst : Elements_Access; -- new, expanded internal array
1109 -- As a precondition on the generic actual Index_Type, the base type
1110 -- must include Index_Type'Pred (Index_Type'First); this is the value
1111 -- that Container.Last assumes when the vector is empty. However, we do
1112 -- not allow that as the value for Index when specifying where the new
1113 -- items should be inserted, so we must manually check. (That the user
1114 -- is allowed to specify the value at all here is a consequence of the
1115 -- declaration of the Extended_Index subtype, which includes the values
1116 -- in the base range that immediately precede and immediately follow the
1117 -- values in the Index_Type.)
1119 if Before < Index_Type'First then
1120 raise Constraint_Error with
1121 "Before index is out of range (too small)";
1124 -- We do allow a value greater than Container.Last to be specified as
1125 -- the Index, but only if it's immediately greater. This allows for the
1126 -- case of appending items to the back end of the vector. (It is assumed
1127 -- that specifying an index value greater than Last + 1 indicates some
1128 -- deeper flaw in the caller's algorithm, so that case is treated as a
1131 if Before > Container.Last
1132 and then Before > Container.Last + 1
1134 raise Constraint_Error with
1135 "Before index is out of range (too large)";
1138 -- We treat inserting 0 items into the container as a no-op, even when
1139 -- the container is busy, so we simply return.
1145 -- There are two constraints we need to satisfy. The first constraint is
1146 -- that a container cannot have more than Count_Type'Last elements, so
1147 -- we must check the sum of the current length and the insertion count.
1148 -- Note: we cannot simply add these values, because of the possibility
1151 if Old_Length > Count_Type'Last - Count then
1152 raise Constraint_Error with "Count is out of range";
1155 -- It is now safe compute the length of the new vector, without fear of
1158 New_Length := Old_Length + Count;
1160 -- The second constraint is that the new Last index value cannot exceed
1161 -- Index_Type'Last. In each branch below, we calculate the maximum
1162 -- length (computed from the range of values in Index_Type), and then
1163 -- compare the new length to the maximum length. If the new length is
1164 -- acceptable, then we compute the new last index from that.
1166 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1168 -- We have to handle the case when there might be more values in the
1169 -- range of Index_Type than in the range of Count_Type.
1171 if Index_Type'First <= 0 then
1173 -- We know that No_Index (the same as Index_Type'First - 1) is
1174 -- less than 0, so it is safe to compute the following sum without
1175 -- fear of overflow.
1177 Index := No_Index + Index_Type'Base (Count_Type'Last);
1179 if Index <= Index_Type'Last then
1181 -- We have determined that range of Index_Type has at least as
1182 -- many values as in Count_Type, so Count_Type'Last is the
1183 -- maximum number of items that are allowed.
1185 Max_Length := Count_Type'Last;
1188 -- The range of Index_Type has fewer values than in Count_Type,
1189 -- so the maximum number of items is computed from the range of
1192 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1196 -- No_Index is equal or greater than 0, so we can safely compute
1197 -- the difference without fear of overflow (which we would have to
1198 -- worry about if No_Index were less than 0, but that case is
1201 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1204 elsif Index_Type'First <= 0 then
1206 -- We know that No_Index (the same as Index_Type'First - 1) is less
1207 -- than 0, so it is safe to compute the following sum without fear of
1210 J := Count_Type'Base (No_Index) + Count_Type'Last;
1212 if J <= Count_Type'Base (Index_Type'Last) then
1214 -- We have determined that range of Index_Type has at least as
1215 -- many values as in Count_Type, so Count_Type'Last is the maximum
1216 -- number of items that are allowed.
1218 Max_Length := Count_Type'Last;
1221 -- The range of Index_Type has fewer values than Count_Type does,
1222 -- so the maximum number of items is computed from the range of
1226 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1230 -- No_Index is equal or greater than 0, so we can safely compute the
1231 -- difference without fear of overflow (which we would have to worry
1232 -- about if No_Index were less than 0, but that case is handled
1236 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1239 -- We have just computed the maximum length (number of items). We must
1240 -- now compare the requested length to the maximum length, as we do not
1241 -- allow a vector expand beyond the maximum (because that would create
1242 -- an internal array with a last index value greater than
1243 -- Index_Type'Last, with no way to index those elements).
1245 if New_Length > Max_Length then
1246 raise Constraint_Error with "Count is out of range";
1249 -- New_Last is the last index value of the items in the container after
1250 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1251 -- compute its value from the New_Length.
1253 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1254 New_Last := No_Index + Index_Type'Base (New_Length);
1256 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1259 if Container.Elements = null then
1260 pragma Assert (Container.Last = No_Index);
1262 -- This is the simplest case, with which we must always begin: we're
1263 -- inserting items into an empty vector that hasn't allocated an
1264 -- internal array yet. Note that we don't need to check the busy bit
1265 -- here, because an empty container cannot be busy.
1267 -- In order to preserve container invariants, we allocate the new
1268 -- internal array first, before setting the Last index value, in case
1269 -- the allocation fails (which can happen either because there is no
1270 -- storage available, or because element initialization fails).
1272 Container.Elements := new Elements_Type'
1274 EA => (others => New_Item));
1276 -- The allocation of the new, internal array succeeded, so it is now
1277 -- safe to update the Last index, restoring container invariants.
1279 Container.Last := New_Last;
1284 -- The tampering bits exist to prevent an item from being harmfully
1285 -- manipulated while it is being visited. Query, Update, and Iterate
1286 -- increment the busy count on entry, and decrement the count on
1287 -- exit. Insert checks the count to determine whether it is being called
1288 -- while the associated callback procedure is executing.
1290 if Container.Busy > 0 then
1291 raise Program_Error with
1292 "attempt to tamper with cursors (vector is busy)";
1295 -- An internal array has already been allocated, so we must determine
1296 -- whether there is enough unused storage for the new items.
1298 if New_Length <= Container.Elements.EA'Length then
1300 -- In this case, we're inserting elements into a vector that has
1301 -- already allocated an internal array, and the existing array has
1302 -- enough unused storage for the new items.
1305 EA : Elements_Array renames Container.Elements.EA;
1308 if Before > Container.Last then
1310 -- The new items are being appended to the vector, so no
1311 -- sliding of existing elements is required.
1313 EA (Before .. New_Last) := (others => New_Item);
1316 -- The new items are being inserted before some existing
1317 -- elements, so we must slide the existing elements up to their
1318 -- new home. We use the wider of Index_Type'Base and
1319 -- Count_Type'Base as the type for intermediate index values.
1321 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1322 Index := Before + Index_Type'Base (Count);
1325 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1328 EA (Index .. New_Last) := EA (Before .. Container.Last);
1329 EA (Before .. Index - 1) := (others => New_Item);
1333 Container.Last := New_Last;
1337 -- In this case, we're inserting elements into a vector that has already
1338 -- allocated an internal array, but the existing array does not have
1339 -- enough storage, so we must allocate a new, longer array. In order to
1340 -- guarantee that the amortized insertion cost is O(1), we always
1341 -- allocate an array whose length is some power-of-two factor of the
1342 -- current array length. (The new array cannot have a length less than
1343 -- the New_Length of the container, but its last index value cannot be
1344 -- greater than Index_Type'Last.)
1346 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1347 while New_Capacity < New_Length loop
1348 if New_Capacity > Count_Type'Last / 2 then
1349 New_Capacity := Count_Type'Last;
1353 New_Capacity := 2 * New_Capacity;
1356 if New_Capacity > Max_Length then
1358 -- We have reached the limit of capacity, so no further expansion
1359 -- will occur. (This is not a problem, as there is never a need to
1360 -- have more capacity than the maximum container length.)
1362 New_Capacity := Max_Length;
1365 -- We have computed the length of the new internal array (and this is
1366 -- what "vector capacity" means), so use that to compute its last index.
1368 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1369 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1373 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1376 -- Now we allocate the new, longer internal array. If the allocation
1377 -- fails, we have not changed any container state, so no side-effect
1378 -- will occur as a result of propagating the exception.
1380 Dst := new Elements_Type (Dst_Last);
1382 -- We have our new internal array. All that needs to be done now is to
1383 -- copy the existing items (if any) from the old array (the "source"
1384 -- array, object SA below) to the new array (the "destination" array,
1385 -- object DA below), and then deallocate the old array.
1388 SA : Elements_Array renames Container.Elements.EA; -- source
1389 DA : Elements_Array renames Dst.EA; -- destination
1392 DA (Index_Type'First .. Before - 1) :=
1393 SA (Index_Type'First .. Before - 1);
1395 if Before > Container.Last then
1396 DA (Before .. New_Last) := (others => New_Item);
1399 -- The new items are being inserted before some existing elements,
1400 -- so we must slide the existing elements up to their new home.
1402 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1403 Index := Before + Index_Type'Base (Count);
1406 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1409 DA (Before .. Index - 1) := (others => New_Item);
1410 DA (Index .. New_Last) := SA (Before .. Container.Last);
1419 -- We have successfully copied the items onto the new array, so the
1420 -- final thing to do is deallocate the old array.
1423 X : Elements_Access := Container.Elements;
1425 -- We first isolate the old internal array, removing it from the
1426 -- container and replacing it with the new internal array, before we
1427 -- deallocate the old array (which can fail if finalization of
1428 -- elements propagates an exception).
1430 Container.Elements := Dst;
1431 Container.Last := New_Last;
1433 -- The container invariants have been restored, so it is now safe to
1434 -- attempt to deallocate the old array.
1441 (Container : in out Vector;
1442 Before : Extended_Index;
1445 N : constant Count_Type := Length (New_Item);
1446 J : Index_Type'Base;
1449 -- Use Insert_Space to create the "hole" (the destination slice) into
1450 -- which we copy the source items.
1452 Insert_Space (Container, Before, Count => N);
1456 -- There's nothing else to do here (vetting of parameters was
1457 -- performed already in Insert_Space), so we simply return.
1462 -- We calculate the last index value of the destination slice using the
1463 -- wider of Index_Type'Base and count_Type'Base.
1465 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1466 J := (Before - 1) + Index_Type'Base (N);
1469 J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
1472 if Container'Address /= New_Item'Address then
1474 -- This is the simple case. New_Item denotes an object different
1475 -- from Container, so there's nothing special we need to do to copy
1476 -- the source items to their destination, because all of the source
1477 -- items are contiguous.
1479 Container.Elements.EA (Before .. J) :=
1480 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
1485 -- New_Item denotes the same object as Container, so an insertion has
1486 -- potentially split the source items. The destination is always the
1487 -- range [Before, J], but the source is [Index_Type'First, Before) and
1488 -- (J, Container.Last]. We perform the copy in two steps, using each of
1489 -- the two slices of the source items.
1492 L : constant Index_Type'Base := Before - 1;
1494 subtype Src_Index_Subtype is Index_Type'Base range
1495 Index_Type'First .. L;
1497 Src : Elements_Array renames
1498 Container.Elements.EA (Src_Index_Subtype);
1500 K : Index_Type'Base;
1503 -- We first copy the source items that precede the space we
1504 -- inserted. Index value K is the last index of that portion
1505 -- destination that receives this slice of the source. (If Before
1506 -- equals Index_Type'First, then this first source slice will be
1507 -- empty, which is harmless.)
1509 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1510 K := L + Index_Type'Base (Src'Length);
1513 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1516 Container.Elements.EA (Before .. K) := Src;
1518 if Src'Length = N then
1520 -- The new items were effectively appended to the container, so we
1521 -- have already copied all of the items that need to be copied.
1522 -- We return early here, even though the source slice below is
1523 -- empty (so the assignment would be harmless), because we want to
1524 -- avoid computing J + 1, which will overflow if J equals
1525 -- Index_Type'Base'Last.
1532 -- Note that we want to avoid computing J + 1 here, in case J equals
1533 -- Index_Type'Base'Last. We prevent that by returning early above,
1534 -- immediately after copying the first slice of the source, and
1535 -- determining that this second slice of the source is empty.
1537 F : constant Index_Type'Base := J + 1;
1539 subtype Src_Index_Subtype is Index_Type'Base range
1540 F .. Container.Last;
1542 Src : Elements_Array renames
1543 Container.Elements.EA (Src_Index_Subtype);
1545 K : Index_Type'Base;
1548 -- We next copy the source items that follow the space we inserted.
1549 -- Index value K is the first index of that portion of the
1550 -- destination that receives this slice of the source. (For the
1551 -- reasons given above, this slice is guaranteed to be non-empty.)
1553 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1554 K := F - Index_Type'Base (Src'Length);
1557 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1560 Container.Elements.EA (K .. J) := Src;
1565 (Container : in out Vector;
1569 Index : Index_Type'Base;
1572 if Before.Container /= null
1573 and then Before.Container /= Container'Unrestricted_Access
1575 raise Program_Error with "Before cursor denotes wrong container";
1578 if Is_Empty (New_Item) then
1582 if Before.Container = null
1583 or else Before.Index > Container.Last
1585 if Container.Last = Index_Type'Last then
1586 raise Constraint_Error with
1587 "vector is already at its maximum length";
1590 Index := Container.Last + 1;
1593 Index := Before.Index;
1596 Insert (Container, Index, New_Item);
1600 (Container : in out Vector;
1603 Position : out Cursor)
1605 Index : Index_Type'Base;
1608 if Before.Container /= null
1609 and then Before.Container /= Container'Unrestricted_Access
1611 raise Program_Error with "Before cursor denotes wrong container";
1614 if Is_Empty (New_Item) then
1615 if Before.Container = null
1616 or else Before.Index > Container.Last
1618 Position := No_Element;
1620 Position := (Container'Unrestricted_Access, Before.Index);
1626 if Before.Container = null
1627 or else Before.Index > Container.Last
1629 if Container.Last = Index_Type'Last then
1630 raise Constraint_Error with
1631 "vector is already at its maximum length";
1634 Index := Container.Last + 1;
1637 Index := Before.Index;
1640 Insert (Container, Index, New_Item);
1642 Position := (Container'Unrestricted_Access, Index);
1646 (Container : in out Vector;
1648 New_Item : Element_Type;
1649 Count : Count_Type := 1)
1651 Index : Index_Type'Base;
1654 if Before.Container /= null
1655 and then Before.Container /= Container'Unrestricted_Access
1657 raise Program_Error with "Before cursor denotes wrong container";
1664 if Before.Container = null
1665 or else Before.Index > Container.Last
1667 if Container.Last = Index_Type'Last then
1668 raise Constraint_Error with
1669 "vector is already at its maximum length";
1671 Index := Container.Last + 1;
1675 Index := Before.Index;
1678 Insert (Container, Index, New_Item, Count);
1682 (Container : in out Vector;
1684 New_Item : Element_Type;
1685 Position : out Cursor;
1686 Count : Count_Type := 1)
1688 Index : Index_Type'Base;
1691 if Before.Container /= null
1692 and then Before.Container /= Container'Unrestricted_Access
1694 raise Program_Error with "Before cursor denotes wrong container";
1698 if Before.Container = null
1699 or else Before.Index > Container.Last
1701 Position := No_Element;
1703 Position := (Container'Unrestricted_Access, Before.Index);
1709 if Before.Container = null
1710 or else Before.Index > Container.Last
1712 if Container.Last = Index_Type'Last then
1713 raise Constraint_Error with
1714 "vector is already at its maximum length";
1717 Index := Container.Last + 1;
1720 Index := Before.Index;
1723 Insert (Container, Index, New_Item, Count);
1725 Position := (Container'Unrestricted_Access, Index);
1729 (Container : in out Vector;
1730 Before : Extended_Index;
1731 Count : Count_Type := 1)
1733 New_Item : Element_Type; -- Default-initialized value
1734 pragma Warnings (Off, New_Item);
1737 Insert (Container, Before, New_Item, Count);
1741 (Container : in out Vector;
1743 Position : out Cursor;
1744 Count : Count_Type := 1)
1746 New_Item : Element_Type; -- Default-initialized value
1747 pragma Warnings (Off, New_Item);
1750 Insert (Container, Before, New_Item, Position, Count);
1757 procedure Insert_Space
1758 (Container : in out Vector;
1759 Before : Extended_Index;
1760 Count : Count_Type := 1)
1762 Old_Length : constant Count_Type := Container.Length;
1764 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1765 New_Length : Count_Type'Base; -- sum of current length and Count
1766 New_Last : Index_Type'Base; -- last index of vector after insertion
1768 Index : Index_Type'Base; -- scratch for intermediate values
1769 J : Count_Type'Base; -- scratch
1771 New_Capacity : Count_Type'Base; -- length of new, expanded array
1772 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1773 Dst : Elements_Access; -- new, expanded internal array
1776 -- As a precondition on the generic actual Index_Type, the base type
1777 -- must include Index_Type'Pred (Index_Type'First); this is the value
1778 -- that Container.Last assumes when the vector is empty. However, we do
1779 -- not allow that as the value for Index when specifying where the new
1780 -- items should be inserted, so we must manually check. (That the user
1781 -- is allowed to specify the value at all here is a consequence of the
1782 -- declaration of the Extended_Index subtype, which includes the values
1783 -- in the base range that immediately precede and immediately follow the
1784 -- values in the Index_Type.)
1786 if Before < Index_Type'First then
1787 raise Constraint_Error with
1788 "Before index is out of range (too small)";
1791 -- We do allow a value greater than Container.Last to be specified as
1792 -- the Index, but only if it's immediately greater. This allows for the
1793 -- case of appending items to the back end of the vector. (It is assumed
1794 -- that specifying an index value greater than Last + 1 indicates some
1795 -- deeper flaw in the caller's algorithm, so that case is treated as a
1798 if Before > Container.Last
1799 and then Before > Container.Last + 1
1801 raise Constraint_Error with
1802 "Before index is out of range (too large)";
1805 -- We treat inserting 0 items into the container as a no-op, even when
1806 -- the container is busy, so we simply return.
1812 -- There are two constraints we need to satisfy. The first constraint is
1813 -- that a container cannot have more than Count_Type'Last elements, so
1814 -- we must check the sum of the current length and the insertion count.
1815 -- Note: we cannot simply add these values, because of the possibility
1818 if Old_Length > Count_Type'Last - Count then
1819 raise Constraint_Error with "Count is out of range";
1822 -- It is now safe compute the length of the new vector, without fear of
1825 New_Length := Old_Length + Count;
1827 -- The second constraint is that the new Last index value cannot exceed
1828 -- Index_Type'Last. In each branch below, we calculate the maximum
1829 -- length (computed from the range of values in Index_Type), and then
1830 -- compare the new length to the maximum length. If the new length is
1831 -- acceptable, then we compute the new last index from that.
1833 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1835 -- We have to handle the case when there might be more values in the
1836 -- range of Index_Type than in the range of Count_Type.
1838 if Index_Type'First <= 0 then
1840 -- We know that No_Index (the same as Index_Type'First - 1) is
1841 -- less than 0, so it is safe to compute the following sum without
1842 -- fear of overflow.
1844 Index := No_Index + Index_Type'Base (Count_Type'Last);
1846 if Index <= Index_Type'Last then
1848 -- We have determined that range of Index_Type has at least as
1849 -- many values as in Count_Type, so Count_Type'Last is the
1850 -- maximum number of items that are allowed.
1852 Max_Length := Count_Type'Last;
1855 -- The range of Index_Type has fewer values than in Count_Type,
1856 -- so the maximum number of items is computed from the range of
1859 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1863 -- No_Index is equal or greater than 0, so we can safely compute
1864 -- the difference without fear of overflow (which we would have to
1865 -- worry about if No_Index were less than 0, but that case is
1868 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1871 elsif Index_Type'First <= 0 then
1873 -- We know that No_Index (the same as Index_Type'First - 1) is less
1874 -- than 0, so it is safe to compute the following sum without fear of
1877 J := Count_Type'Base (No_Index) + Count_Type'Last;
1879 if J <= Count_Type'Base (Index_Type'Last) then
1881 -- We have determined that range of Index_Type has at least as
1882 -- many values as in Count_Type, so Count_Type'Last is the maximum
1883 -- number of items that are allowed.
1885 Max_Length := Count_Type'Last;
1888 -- The range of Index_Type has fewer values than Count_Type does,
1889 -- so the maximum number of items is computed from the range of
1893 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1897 -- No_Index is equal or greater than 0, so we can safely compute the
1898 -- difference without fear of overflow (which we would have to worry
1899 -- about if No_Index were less than 0, but that case is handled
1903 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1906 -- We have just computed the maximum length (number of items). We must
1907 -- now compare the requested length to the maximum length, as we do not
1908 -- allow a vector expand beyond the maximum (because that would create
1909 -- an internal array with a last index value greater than
1910 -- Index_Type'Last, with no way to index those elements).
1912 if New_Length > Max_Length then
1913 raise Constraint_Error with "Count is out of range";
1916 -- New_Last is the last index value of the items in the container after
1917 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1918 -- compute its value from the New_Length.
1920 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1921 New_Last := No_Index + Index_Type'Base (New_Length);
1924 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1927 if Container.Elements = null then
1928 pragma Assert (Container.Last = No_Index);
1930 -- This is the simplest case, with which we must always begin: we're
1931 -- inserting items into an empty vector that hasn't allocated an
1932 -- internal array yet. Note that we don't need to check the busy bit
1933 -- here, because an empty container cannot be busy.
1935 -- In order to preserve container invariants, we allocate the new
1936 -- internal array first, before setting the Last index value, in case
1937 -- the allocation fails (which can happen either because there is no
1938 -- storage available, or because default-valued element
1939 -- initialization fails).
1941 Container.Elements := new Elements_Type (New_Last);
1943 -- The allocation of the new, internal array succeeded, so it is now
1944 -- safe to update the Last index, restoring container invariants.
1946 Container.Last := New_Last;
1951 -- The tampering bits exist to prevent an item from being harmfully
1952 -- manipulated while it is being visited. Query, Update, and Iterate
1953 -- increment the busy count on entry, and decrement the count on
1954 -- exit. Insert checks the count to determine whether it is being called
1955 -- while the associated callback procedure is executing.
1957 if Container.Busy > 0 then
1958 raise Program_Error with
1959 "attempt to tamper with cursors (vector is busy)";
1962 -- An internal array has already been allocated, so we must determine
1963 -- whether there is enough unused storage for the new items.
1965 if New_Last <= Container.Elements.Last then
1967 -- In this case, we're inserting space into a vector that has already
1968 -- allocated an internal array, and the existing array has enough
1969 -- unused storage for the new items.
1972 EA : Elements_Array renames Container.Elements.EA;
1975 if Before <= Container.Last then
1977 -- The space is being inserted before some existing elements,
1978 -- so we must slide the existing elements up to their new
1979 -- home. We use the wider of Index_Type'Base and
1980 -- Count_Type'Base as the type for intermediate index values.
1982 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1983 Index := Before + Index_Type'Base (Count);
1986 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1989 EA (Index .. New_Last) := EA (Before .. Container.Last);
1993 Container.Last := New_Last;
1997 -- In this case, we're inserting space into a vector that has already
1998 -- allocated an internal array, but the existing array does not have
1999 -- enough storage, so we must allocate a new, longer array. In order to
2000 -- guarantee that the amortized insertion cost is O(1), we always
2001 -- allocate an array whose length is some power-of-two factor of the
2002 -- current array length. (The new array cannot have a length less than
2003 -- the New_Length of the container, but its last index value cannot be
2004 -- greater than Index_Type'Last.)
2006 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2007 while New_Capacity < New_Length loop
2008 if New_Capacity > Count_Type'Last / 2 then
2009 New_Capacity := Count_Type'Last;
2013 New_Capacity := 2 * New_Capacity;
2016 if New_Capacity > Max_Length then
2018 -- We have reached the limit of capacity, so no further expansion
2019 -- will occur. (This is not a problem, as there is never a need to
2020 -- have more capacity than the maximum container length.)
2022 New_Capacity := Max_Length;
2025 -- We have computed the length of the new internal array (and this is
2026 -- what "vector capacity" means), so use that to compute its last index.
2028 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2029 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2033 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2036 -- Now we allocate the new, longer internal array. If the allocation
2037 -- fails, we have not changed any container state, so no side-effect
2038 -- will occur as a result of propagating the exception.
2040 Dst := new Elements_Type (Dst_Last);
2042 -- We have our new internal array. All that needs to be done now is to
2043 -- copy the existing items (if any) from the old array (the "source"
2044 -- array, object SA below) to the new array (the "destination" array,
2045 -- object DA below), and then deallocate the old array.
2048 SA : Elements_Array renames Container.Elements.EA; -- source
2049 DA : Elements_Array renames Dst.EA; -- destination
2052 DA (Index_Type'First .. Before - 1) :=
2053 SA (Index_Type'First .. Before - 1);
2055 if Before <= Container.Last then
2057 -- The space is being inserted before some existing elements, so
2058 -- we must slide the existing elements up to their new home.
2060 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2061 Index := Before + Index_Type'Base (Count);
2064 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2067 DA (Index .. New_Last) := SA (Before .. Container.Last);
2076 -- We have successfully copied the items onto the new array, so the
2077 -- final thing to do is restore invariants, and deallocate the old
2081 X : Elements_Access := Container.Elements;
2084 -- We first isolate the old internal array, removing it from the
2085 -- container and replacing it with the new internal array, before we
2086 -- deallocate the old array (which can fail if finalization of
2087 -- elements propagates an exception).
2089 Container.Elements := Dst;
2090 Container.Last := New_Last;
2092 -- The container invariants have been restored, so it is now safe to
2093 -- attempt to deallocate the old array.
2099 procedure Insert_Space
2100 (Container : in out Vector;
2102 Position : out Cursor;
2103 Count : Count_Type := 1)
2105 Index : Index_Type'Base;
2108 if Before.Container /= null
2109 and then Before.Container /= Container'Unrestricted_Access
2111 raise Program_Error with "Before cursor denotes wrong container";
2115 if Before.Container = null
2116 or else Before.Index > Container.Last
2118 Position := No_Element;
2120 Position := (Container'Unrestricted_Access, Before.Index);
2126 if Before.Container = null
2127 or else Before.Index > Container.Last
2129 if Container.Last = Index_Type'Last then
2130 raise Constraint_Error with
2131 "vector is already at its maximum length";
2133 Index := Container.Last + 1;
2137 Index := Before.Index;
2140 Insert_Space (Container, Index, Count => Count);
2142 Position := (Container'Unrestricted_Access, Index);
2149 function Is_Empty (Container : Vector) return Boolean is
2151 return Container.Last < Index_Type'First;
2159 (Container : Vector;
2160 Process : not null access procedure (Position : Cursor))
2162 B : Natural renames Container'Unrestricted_Access.all.Busy;
2168 for Indx in Index_Type'First .. Container.Last loop
2169 Process (Cursor'(Container'Unrestricted_Access, Indx));
2181 (Container : Vector)
2182 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2184 V : constant Vector_Access := Container'Unrestricted_Access;
2185 B : Natural renames V.Busy;
2188 -- The value of its Index component influences the behavior of the First
2189 -- and Last selector functions of the iterator object. When the Index
2190 -- component is No_Index (as is the case here), this means the iterator
2191 -- object was constructed without a start expression. This is a complete
2192 -- iterator, meaning that the iteration starts from the (logical)
2193 -- beginning of the sequence of items.
2195 -- Note: For a forward iterator, Container.First is the beginning, and
2196 -- for a reverse iterator, Container.Last is the beginning.
2198 return It : constant Iterator :=
2199 (Limited_Controlled with
2208 (Container : Vector;
2210 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2212 V : constant Vector_Access := Container'Unrestricted_Access;
2213 B : Natural renames V.Busy;
2216 -- It was formerly the case that when Start = No_Element, the partial
2217 -- iterator was defined to behave the same as for a complete iterator,
2218 -- and iterate over the entire sequence of items. However, those
2219 -- semantics were unintuitive and arguably error-prone (it is too easy
2220 -- to accidentally create an endless loop), and so they were changed,
2221 -- per the ARG meeting in Denver on 2011/11. However, there was no
2222 -- consensus about what positive meaning this corner case should have,
2223 -- and so it was decided to simply raise an exception. This does imply,
2224 -- however, that it is not possible to use a partial iterator to specify
2225 -- an empty sequence of items.
2227 if Start.Container = null then
2228 raise Constraint_Error with
2229 "Start position for iterator equals No_Element";
2232 if Start.Container /= V then
2233 raise Program_Error with
2234 "Start cursor of Iterate designates wrong vector";
2237 if Start.Index > V.Last then
2238 raise Constraint_Error with
2239 "Start position for iterator equals No_Element";
2242 -- The value of its Index component influences the behavior of the First
2243 -- and Last selector functions of the iterator object. When the Index
2244 -- component is not No_Index (as is the case here), it means that this
2245 -- is a partial iteration, over a subset of the complete sequence of
2246 -- items. The iterator object was constructed with a start expression,
2247 -- indicating the position from which the iteration begins. Note that
2248 -- the start position has the same value irrespective of whether this
2249 -- is a forward or reverse iteration.
2251 return It : constant Iterator :=
2252 (Limited_Controlled with
2254 Index => Start.Index)
2264 function Last (Container : Vector) return Cursor is
2266 if Is_Empty (Container) then
2269 return (Container'Unrestricted_Access, Container.Last);
2273 function Last (Object : Iterator) return Cursor is
2275 -- The value of the iterator object's Index component influences the
2276 -- behavior of the Last (and First) selector function.
2278 -- When the Index component is No_Index, this means the iterator
2279 -- object was constructed without a start expression, in which case the
2280 -- (reverse) iteration starts from the (logical) beginning of the entire
2281 -- sequence (corresponding to Container.Last, for a reverse iterator).
2283 -- Otherwise, this is iteration over a partial sequence of items.
2284 -- When the Index component is not No_Index, the iterator object was
2285 -- constructed with a start expression, that specifies the position
2286 -- from which the (reverse) partial iteration begins.
2288 if Object.Index = No_Index then
2289 return Last (Object.Container.all);
2291 return Cursor'(Object.Container, Object.Index);
2299 function Last_Element (Container : Vector) return Element_Type is
2301 if Container.Last = No_Index then
2302 raise Constraint_Error with "Container is empty";
2304 return Container.Elements.EA (Container.Last);
2312 function Last_Index (Container : Vector) return Extended_Index is
2314 return Container.Last;
2321 function Length (Container : Vector) return Count_Type is
2322 L : constant Index_Type'Base := Container.Last;
2323 F : constant Index_Type := Index_Type'First;
2326 -- The base range of the index type (Index_Type'Base) might not include
2327 -- all values for length (Count_Type). Contrariwise, the index type
2328 -- might include values outside the range of length. Hence we use
2329 -- whatever type is wider for intermediate values when calculating
2330 -- length. Note that no matter what the index type is, the maximum
2331 -- length to which a vector is allowed to grow is always the minimum
2332 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2334 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2335 -- to have a base range of -128 .. 127, but the corresponding vector
2336 -- would have lengths in the range 0 .. 255. In this case we would need
2337 -- to use Count_Type'Base for intermediate values.
2339 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2340 -- vector would have a maximum length of 10, but the index values lie
2341 -- outside the range of Count_Type (which is only 32 bits). In this
2342 -- case we would need to use Index_Type'Base for intermediate values.
2344 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2345 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2347 return Count_Type (L - F + 1);
2356 (Target : in out Vector;
2357 Source : in out Vector)
2360 if Target'Address = Source'Address then
2364 if Target.Busy > 0 then
2365 raise Program_Error with
2366 "attempt to tamper with cursors (Target is busy)";
2369 if Source.Busy > 0 then
2370 raise Program_Error with
2371 "attempt to tamper with cursors (Source is busy)";
2375 Target_Elements : constant Elements_Access := Target.Elements;
2377 Target.Elements := Source.Elements;
2378 Source.Elements := Target_Elements;
2381 Target.Last := Source.Last;
2382 Source.Last := No_Index;
2389 function Next (Position : Cursor) return Cursor is
2391 if Position.Container = null then
2393 elsif Position.Index < Position.Container.Last then
2394 return (Position.Container, Position.Index + 1);
2400 function Next (Object : Iterator; Position : Cursor) return Cursor is
2402 if Position.Container = null then
2406 if Position.Container /= Object.Container then
2407 raise Program_Error with
2408 "Position cursor of Next designates wrong vector";
2411 return Next (Position);
2414 procedure Next (Position : in out Cursor) is
2416 if Position.Container = null then
2418 elsif Position.Index < Position.Container.Last then
2419 Position.Index := Position.Index + 1;
2421 Position := No_Element;
2429 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2431 Insert (Container, Index_Type'First, New_Item);
2435 (Container : in out Vector;
2436 New_Item : Element_Type;
2437 Count : Count_Type := 1)
2450 function Previous (Position : Cursor) return Cursor is
2452 if Position.Container = null then
2454 elsif Position.Index > Index_Type'First then
2455 return (Position.Container, Position.Index - 1);
2461 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2463 if Position.Container = null then
2467 if Position.Container /= Object.Container then
2468 raise Program_Error with
2469 "Position cursor of Previous designates wrong vector";
2472 return Previous (Position);
2475 procedure Previous (Position : in out Cursor) is
2477 if Position.Container = null then
2479 elsif Position.Index > Index_Type'First then
2480 Position.Index := Position.Index - 1;
2482 Position := No_Element;
2490 procedure Query_Element
2491 (Container : Vector;
2493 Process : not null access procedure (Element : Element_Type))
2495 V : Vector renames Container'Unrestricted_Access.all;
2496 B : Natural renames V.Busy;
2497 L : Natural renames V.Lock;
2500 if Index > Container.Last then
2501 raise Constraint_Error with "Index is out of range";
2508 Process (V.Elements.EA (Index));
2520 procedure Query_Element
2522 Process : not null access procedure (Element : Element_Type))
2525 if Position.Container = null then
2526 raise Constraint_Error with "Position cursor has no element";
2529 Query_Element (Position.Container.all, Position.Index, Process);
2537 (Stream : not null access Root_Stream_Type'Class;
2538 Container : out Vector)
2540 Length : Count_Type'Base;
2541 Last : Index_Type'Base := No_Index;
2546 Count_Type'Base'Read (Stream, Length);
2548 if Length > Capacity (Container) then
2549 Reserve_Capacity (Container, Capacity => Length);
2552 for J in Count_Type range 1 .. Length loop
2554 Element_Type'Read (Stream, Container.Elements.EA (Last));
2555 Container.Last := Last;
2560 (Stream : not null access Root_Stream_Type'Class;
2561 Position : out Cursor)
2564 raise Program_Error with "attempt to stream vector cursor";
2568 (Stream : not null access Root_Stream_Type'Class;
2569 Item : out Reference_Type)
2572 raise Program_Error with "attempt to stream reference";
2576 (Stream : not null access Root_Stream_Type'Class;
2577 Item : out Constant_Reference_Type)
2580 raise Program_Error with "attempt to stream reference";
2588 (Container : aliased in out Vector;
2589 Position : Cursor) return Reference_Type
2592 if Position.Container = null then
2593 raise Constraint_Error with "Position cursor has no element";
2596 if Position.Container /= Container'Unrestricted_Access then
2597 raise Program_Error with "Position cursor denotes wrong container";
2600 if Position.Index > Position.Container.Last then
2601 raise Constraint_Error with "Position cursor is out of range";
2604 return (Element => Container.Elements.EA (Position.Index)'Access);
2608 (Container : aliased in out Vector;
2609 Index : Index_Type) return Reference_Type
2612 if Index > Container.Last then
2613 raise Constraint_Error with "Index is out of range";
2615 return (Element => Container.Elements.EA (Index)'Access);
2619 ---------------------
2620 -- Replace_Element --
2621 ---------------------
2623 procedure Replace_Element
2624 (Container : in out Vector;
2626 New_Item : Element_Type)
2629 if Index > Container.Last then
2630 raise Constraint_Error with "Index is out of range";
2633 if Container.Lock > 0 then
2634 raise Program_Error with
2635 "attempt to tamper with elements (vector is locked)";
2638 Container.Elements.EA (Index) := New_Item;
2639 end Replace_Element;
2641 procedure Replace_Element
2642 (Container : in out Vector;
2644 New_Item : Element_Type)
2647 if Position.Container = null then
2648 raise Constraint_Error with "Position cursor has no element";
2651 if Position.Container /= Container'Unrestricted_Access then
2652 raise Program_Error with "Position cursor denotes wrong container";
2655 if Position.Index > Container.Last then
2656 raise Constraint_Error with "Position cursor is out of range";
2659 if Container.Lock > 0 then
2660 raise Program_Error with
2661 "attempt to tamper with elements (vector is locked)";
2664 Container.Elements.EA (Position.Index) := New_Item;
2665 end Replace_Element;
2667 ----------------------
2668 -- Reserve_Capacity --
2669 ----------------------
2671 procedure Reserve_Capacity
2672 (Container : in out Vector;
2673 Capacity : Count_Type)
2675 N : constant Count_Type := Length (Container);
2677 Index : Count_Type'Base;
2678 Last : Index_Type'Base;
2681 -- Reserve_Capacity can be used to either expand the storage available
2682 -- for elements (this would be its typical use, in anticipation of
2683 -- future insertion), or to trim back storage. In the latter case,
2684 -- storage can only be trimmed back to the limit of the container
2685 -- length. Note that Reserve_Capacity neither deletes (active) elements
2686 -- nor inserts elements; it only affects container capacity, never
2687 -- container length.
2689 if Capacity = 0 then
2691 -- This is a request to trim back storage, to the minimum amount
2692 -- possible given the current state of the container.
2696 -- The container is empty, so in this unique case we can
2697 -- deallocate the entire internal array. Note that an empty
2698 -- container can never be busy, so there's no need to check the
2702 X : Elements_Access := Container.Elements;
2705 -- First we remove the internal array from the container, to
2706 -- handle the case when the deallocation raises an exception.
2708 Container.Elements := null;
2710 -- Container invariants have been restored, so it is now safe
2711 -- to attempt to deallocate the internal array.
2716 elsif N < Container.Elements.EA'Length then
2718 -- The container is not empty, and the current length is less than
2719 -- the current capacity, so there's storage available to trim. In
2720 -- this case, we allocate a new internal array having a length
2721 -- that exactly matches the number of items in the
2722 -- container. (Reserve_Capacity does not delete active elements,
2723 -- so this is the best we can do with respect to minimizing
2726 if Container.Busy > 0 then
2727 raise Program_Error with
2728 "attempt to tamper with cursors (vector is busy)";
2732 subtype Src_Index_Subtype is Index_Type'Base range
2733 Index_Type'First .. Container.Last;
2735 Src : Elements_Array renames
2736 Container.Elements.EA (Src_Index_Subtype);
2738 X : Elements_Access := Container.Elements;
2741 -- Although we have isolated the old internal array that we're
2742 -- going to deallocate, we don't deallocate it until we have
2743 -- successfully allocated a new one. If there is an exception
2744 -- during allocation (either because there is not enough
2745 -- storage, or because initialization of the elements fails),
2746 -- we let it propagate without causing any side-effect.
2748 Container.Elements := new Elements_Type'(Container.Last, Src);
2750 -- We have successfully allocated a new internal array (with a
2751 -- smaller length than the old one, and containing a copy of
2752 -- just the active elements in the container), so it is now
2753 -- safe to attempt to deallocate the old array. The old array
2754 -- has been isolated, and container invariants have been
2755 -- restored, so if the deallocation fails (because finalization
2756 -- of the elements fails), we simply let it propagate.
2765 -- Reserve_Capacity can be used to expand the storage available for
2766 -- elements, but we do not let the capacity grow beyond the number of
2767 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2768 -- to refer to the elements with an index value greater than
2769 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2770 -- the Last index value of the new internal array, in a way that avoids
2771 -- any possibility of overflow.
2773 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2775 -- We perform a two-part test. First we determine whether the
2776 -- computed Last value lies in the base range of the type, and then
2777 -- determine whether it lies in the range of the index (sub)type.
2779 -- Last must satisfy this relation:
2780 -- First + Length - 1 <= Last
2781 -- We regroup terms:
2782 -- First - 1 <= Last - Length
2783 -- Which can rewrite as:
2784 -- No_Index <= Last - Length
2786 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
2787 raise Constraint_Error with "Capacity is out of range";
2790 -- We now know that the computed value of Last is within the base
2791 -- range of the type, so it is safe to compute its value:
2793 Last := No_Index + Index_Type'Base (Capacity);
2795 -- Finally we test whether the value is within the range of the
2796 -- generic actual index subtype:
2798 if Last > Index_Type'Last then
2799 raise Constraint_Error with "Capacity is out of range";
2802 elsif Index_Type'First <= 0 then
2804 -- Here we can compute Last directly, in the normal way. We know that
2805 -- No_Index is less than 0, so there is no danger of overflow when
2806 -- adding the (positive) value of Capacity.
2808 Index := Count_Type'Base (No_Index) + Capacity; -- Last
2810 if Index > Count_Type'Base (Index_Type'Last) then
2811 raise Constraint_Error with "Capacity is out of range";
2814 -- We know that the computed value (having type Count_Type) of Last
2815 -- is within the range of the generic actual index subtype, so it is
2816 -- safe to convert to Index_Type:
2818 Last := Index_Type'Base (Index);
2821 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2822 -- must test the length indirectly (by working backwards from the
2823 -- largest possible value of Last), in order to prevent overflow.
2825 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
2827 if Index < Count_Type'Base (No_Index) then
2828 raise Constraint_Error with "Capacity is out of range";
2831 -- We have determined that the value of Capacity would not create a
2832 -- Last index value outside of the range of Index_Type, so we can now
2833 -- safely compute its value.
2835 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
2838 -- The requested capacity is non-zero, but we don't know yet whether
2839 -- this is a request for expansion or contraction of storage.
2841 if Container.Elements = null then
2843 -- The container is empty (it doesn't even have an internal array),
2844 -- so this represents a request to allocate (expand) storage having
2845 -- the given capacity.
2847 Container.Elements := new Elements_Type (Last);
2851 if Capacity <= N then
2853 -- This is a request to trim back storage, but only to the limit of
2854 -- what's already in the container. (Reserve_Capacity never deletes
2855 -- active elements, it only reclaims excess storage.)
2857 if N < Container.Elements.EA'Length then
2859 -- The container is not empty (because the requested capacity is
2860 -- positive, and less than or equal to the container length), and
2861 -- the current length is less than the current capacity, so
2862 -- there's storage available to trim. In this case, we allocate a
2863 -- new internal array having a length that exactly matches the
2864 -- number of items in the container.
2866 if Container.Busy > 0 then
2867 raise Program_Error with
2868 "attempt to tamper with cursors (vector is busy)";
2872 subtype Src_Index_Subtype is Index_Type'Base range
2873 Index_Type'First .. Container.Last;
2875 Src : Elements_Array renames
2876 Container.Elements.EA (Src_Index_Subtype);
2878 X : Elements_Access := Container.Elements;
2881 -- Although we have isolated the old internal array that we're
2882 -- going to deallocate, we don't deallocate it until we have
2883 -- successfully allocated a new one. If there is an exception
2884 -- during allocation (either because there is not enough
2885 -- storage, or because initialization of the elements fails),
2886 -- we let it propagate without causing any side-effect.
2888 Container.Elements := new Elements_Type'(Container.Last, Src);
2890 -- We have successfully allocated a new internal array (with a
2891 -- smaller length than the old one, and containing a copy of
2892 -- just the active elements in the container), so it is now
2893 -- safe to attempt to deallocate the old array. The old array
2894 -- has been isolated, and container invariants have been
2895 -- restored, so if the deallocation fails (because finalization
2896 -- of the elements fails), we simply let it propagate.
2905 -- The requested capacity is larger than the container length (the
2906 -- number of active elements). Whether this represents a request for
2907 -- expansion or contraction of the current capacity depends on what the
2908 -- current capacity is.
2910 if Capacity = Container.Elements.EA'Length then
2912 -- The requested capacity matches the existing capacity, so there's
2913 -- nothing to do here. We treat this case as a no-op, and simply
2914 -- return without checking the busy bit.
2919 -- There is a change in the capacity of a non-empty container, so a new
2920 -- internal array will be allocated. (The length of the new internal
2921 -- array could be less or greater than the old internal array. We know
2922 -- only that the length of the new internal array is greater than the
2923 -- number of active elements in the container.) We must check whether
2924 -- the container is busy before doing anything else.
2926 if Container.Busy > 0 then
2927 raise Program_Error with
2928 "attempt to tamper with cursors (vector is busy)";
2931 -- We now allocate a new internal array, having a length different from
2932 -- its current value.
2935 E : Elements_Access := new Elements_Type (Last);
2938 -- We have successfully allocated the new internal array. We first
2939 -- attempt to copy the existing elements from the old internal array
2940 -- ("src" elements) onto the new internal array ("tgt" elements).
2943 subtype Index_Subtype is Index_Type'Base range
2944 Index_Type'First .. Container.Last;
2946 Src : Elements_Array renames
2947 Container.Elements.EA (Index_Subtype);
2949 Tgt : Elements_Array renames E.EA (Index_Subtype);
2960 -- We have successfully copied the existing elements onto the new
2961 -- internal array, so now we can attempt to deallocate the old one.
2964 X : Elements_Access := Container.Elements;
2967 -- First we isolate the old internal array, and replace it in the
2968 -- container with the new internal array.
2970 Container.Elements := E;
2972 -- Container invariants have been restored, so it is now safe to
2973 -- attempt to deallocate the old internal array.
2978 end Reserve_Capacity;
2980 ----------------------
2981 -- Reverse_Elements --
2982 ----------------------
2984 procedure Reverse_Elements (Container : in out Vector) is
2986 if Container.Length <= 1 then
2990 -- The exception behavior for the vector container must match that for
2991 -- the list container, so we check for cursor tampering here (which will
2992 -- catch more things) instead of for element tampering (which will catch
2993 -- fewer things). It's true that the elements of this vector container
2994 -- could be safely moved around while (say) an iteration is taking place
2995 -- (iteration only increments the busy counter), and so technically
2996 -- all we would need here is a test for element tampering (indicated
2997 -- by the lock counter), that's simply an artifact of our array-based
2998 -- implementation. Logically Reverse_Elements requires a check for
2999 -- cursor tampering.
3001 if Container.Busy > 0 then
3002 raise Program_Error with
3003 "attempt to tamper with cursors (vector is busy)";
3009 E : Elements_Type renames Container.Elements.all;
3012 K := Index_Type'First;
3013 J := Container.Last;
3016 EK : constant Element_Type := E.EA (K);
3018 E.EA (K) := E.EA (J);
3026 end Reverse_Elements;
3032 function Reverse_Find
3033 (Container : Vector;
3034 Item : Element_Type;
3035 Position : Cursor := No_Element) return Cursor
3037 Last : Index_Type'Base;
3040 if Position.Container /= null
3041 and then Position.Container /= Container'Unrestricted_Access
3043 raise Program_Error with "Position cursor denotes wrong container";
3047 (if Position.Container = null or else Position.Index > Container.Last
3049 else Position.Index);
3051 for Indx in reverse Index_Type'First .. Last loop
3052 if Container.Elements.EA (Indx) = Item then
3053 return (Container'Unrestricted_Access, Indx);
3060 ------------------------
3061 -- Reverse_Find_Index --
3062 ------------------------
3064 function Reverse_Find_Index
3065 (Container : Vector;
3066 Item : Element_Type;
3067 Index : Index_Type := Index_Type'Last) return Extended_Index
3069 Last : constant Index_Type'Base :=
3070 Index_Type'Min (Container.Last, Index);
3073 for Indx in reverse Index_Type'First .. Last loop
3074 if Container.Elements.EA (Indx) = Item then
3080 end Reverse_Find_Index;
3082 ---------------------
3083 -- Reverse_Iterate --
3084 ---------------------
3086 procedure Reverse_Iterate
3087 (Container : Vector;
3088 Process : not null access procedure (Position : Cursor))
3090 V : Vector renames Container'Unrestricted_Access.all;
3091 B : Natural renames V.Busy;
3097 for Indx in reverse Index_Type'First .. Container.Last loop
3098 Process (Cursor'(Container'Unrestricted_Access, Indx));
3107 end Reverse_Iterate;
3113 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
3114 Count : constant Count_Type'Base := Container.Length - Length;
3117 -- Set_Length allows the user to set the length explicitly, instead
3118 -- of implicitly as a side-effect of deletion or insertion. If the
3119 -- requested length is less then the current length, this is equivalent
3120 -- to deleting items from the back end of the vector. If the requested
3121 -- length is greater than the current length, then this is equivalent
3122 -- to inserting "space" (nonce items) at the end.
3125 Container.Delete_Last (Count);
3127 elsif Container.Last >= Index_Type'Last then
3128 raise Constraint_Error with "vector is already at its maximum length";
3131 Container.Insert_Space (Container.Last + 1, -Count);
3139 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3141 if I > Container.Last then
3142 raise Constraint_Error with "I index is out of range";
3145 if J > Container.Last then
3146 raise Constraint_Error with "J index is out of range";
3153 if Container.Lock > 0 then
3154 raise Program_Error with
3155 "attempt to tamper with elements (vector is locked)";
3159 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3161 Container.Elements.EA (I) := Container.Elements.EA (J);
3162 Container.Elements.EA (J) := EI_Copy;
3166 procedure Swap (Container : in out Vector; I, J : Cursor) is
3168 if I.Container = null then
3169 raise Constraint_Error with "I cursor has no element";
3172 if J.Container = null then
3173 raise Constraint_Error with "J cursor has no element";
3176 if I.Container /= Container'Unrestricted_Access then
3177 raise Program_Error with "I cursor denotes wrong container";
3180 if J.Container /= Container'Unrestricted_Access then
3181 raise Program_Error with "J cursor denotes wrong container";
3184 Swap (Container, I.Index, J.Index);
3192 (Container : Vector;
3193 Index : Extended_Index) return Cursor
3196 if Index not in Index_Type'First .. Container.Last then
3199 return (Container'Unrestricted_Access, Index);
3207 function To_Index (Position : Cursor) return Extended_Index is
3209 if Position.Container = null then
3213 if Position.Index <= Position.Container.Last then
3214 return Position.Index;
3224 function To_Vector (Length : Count_Type) return Vector is
3225 Index : Count_Type'Base;
3226 Last : Index_Type'Base;
3227 Elements : Elements_Access;
3231 return Empty_Vector;
3234 -- We create a vector object with a capacity that matches the specified
3235 -- Length, but we do not allow the vector capacity (the length of the
3236 -- internal array) to exceed the number of values in Index_Type'Range
3237 -- (otherwise, there would be no way to refer to those components via an
3238 -- index). We must therefore check whether the specified Length would
3239 -- create a Last index value greater than Index_Type'Last.
3241 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3243 -- We perform a two-part test. First we determine whether the
3244 -- computed Last value lies in the base range of the type, and then
3245 -- determine whether it lies in the range of the index (sub)type.
3247 -- Last must satisfy this relation:
3248 -- First + Length - 1 <= Last
3249 -- We regroup terms:
3250 -- First - 1 <= Last - Length
3251 -- Which can rewrite as:
3252 -- No_Index <= Last - Length
3254 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3255 raise Constraint_Error with "Length is out of range";
3258 -- We now know that the computed value of Last is within the base
3259 -- range of the type, so it is safe to compute its value:
3261 Last := No_Index + Index_Type'Base (Length);
3263 -- Finally we test whether the value is within the range of the
3264 -- generic actual index subtype:
3266 if Last > Index_Type'Last then
3267 raise Constraint_Error with "Length is out of range";
3270 elsif Index_Type'First <= 0 then
3272 -- Here we can compute Last directly, in the normal way. We know that
3273 -- No_Index is less than 0, so there is no danger of overflow when
3274 -- adding the (positive) value of Length.
3276 Index := Count_Type'Base (No_Index) + Length; -- Last
3278 if Index > Count_Type'Base (Index_Type'Last) then
3279 raise Constraint_Error with "Length is out of range";
3282 -- We know that the computed value (having type Count_Type) of Last
3283 -- is within the range of the generic actual index subtype, so it is
3284 -- safe to convert to Index_Type:
3286 Last := Index_Type'Base (Index);
3289 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3290 -- must test the length indirectly (by working backwards from the
3291 -- largest possible value of Last), in order to prevent overflow.
3293 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3295 if Index < Count_Type'Base (No_Index) then
3296 raise Constraint_Error with "Length is out of range";
3299 -- We have determined that the value of Length would not create a
3300 -- Last index value outside of the range of Index_Type, so we can now
3301 -- safely compute its value.
3303 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3306 Elements := new Elements_Type (Last);
3308 return Vector'(Controlled with Elements, Last, 0, 0);
3312 (New_Item : Element_Type;
3313 Length : Count_Type) return Vector
3315 Index : Count_Type'Base;
3316 Last : Index_Type'Base;
3317 Elements : Elements_Access;
3321 return Empty_Vector;
3324 -- We create a vector object with a capacity that matches the specified
3325 -- Length, but we do not allow the vector capacity (the length of the
3326 -- internal array) to exceed the number of values in Index_Type'Range
3327 -- (otherwise, there would be no way to refer to those components via an
3328 -- index). We must therefore check whether the specified Length would
3329 -- create a Last index value greater than Index_Type'Last.
3331 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3333 -- We perform a two-part test. First we determine whether the
3334 -- computed Last value lies in the base range of the type, and then
3335 -- determine whether it lies in the range of the index (sub)type.
3337 -- Last must satisfy this relation:
3338 -- First + Length - 1 <= Last
3339 -- We regroup terms:
3340 -- First - 1 <= Last - Length
3341 -- Which can rewrite as:
3342 -- No_Index <= Last - Length
3344 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3345 raise Constraint_Error with "Length is out of range";
3348 -- We now know that the computed value of Last is within the base
3349 -- range of the type, so it is safe to compute its value:
3351 Last := No_Index + Index_Type'Base (Length);
3353 -- Finally we test whether the value is within the range of the
3354 -- generic actual index subtype:
3356 if Last > Index_Type'Last then
3357 raise Constraint_Error with "Length is out of range";
3360 elsif Index_Type'First <= 0 then
3362 -- Here we can compute Last directly, in the normal way. We know that
3363 -- No_Index is less than 0, so there is no danger of overflow when
3364 -- adding the (positive) value of Length.
3366 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
3368 if Index > Count_Type'Base (Index_Type'Last) then
3369 raise Constraint_Error with "Length is out of range";
3372 -- We know that the computed value (having type Count_Type) of Last
3373 -- is within the range of the generic actual index subtype, so it is
3374 -- safe to convert to Index_Type:
3376 Last := Index_Type'Base (Index);
3379 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3380 -- must test the length indirectly (by working backwards from the
3381 -- largest possible value of Last), in order to prevent overflow.
3383 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3385 if Index < Count_Type'Base (No_Index) then
3386 raise Constraint_Error with "Length is out of range";
3389 -- We have determined that the value of Length would not create a
3390 -- Last index value outside of the range of Index_Type, so we can now
3391 -- safely compute its value.
3393 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3396 Elements := new Elements_Type'(Last, EA => (others => New_Item));
3398 return Vector'(Controlled with Elements, Last, 0, 0);
3401 --------------------
3402 -- Update_Element --
3403 --------------------
3405 procedure Update_Element
3406 (Container : in out Vector;
3408 Process : not null access procedure (Element : in out Element_Type))
3410 B : Natural renames Container.Busy;
3411 L : Natural renames Container.Lock;
3414 if Index > Container.Last then
3415 raise Constraint_Error with "Index is out of range";
3422 Process (Container.Elements.EA (Index));
3434 procedure Update_Element
3435 (Container : in out Vector;
3437 Process : not null access procedure (Element : in out Element_Type))
3440 if Position.Container = null then
3441 raise Constraint_Error with "Position cursor has no element";
3442 elsif Position.Container /= Container'Unrestricted_Access then
3443 raise Program_Error with "Position cursor denotes wrong container";
3445 Update_Element (Container, Position.Index, Process);
3454 (Stream : not null access Root_Stream_Type'Class;
3458 Count_Type'Base'Write (Stream, Length (Container));
3460 for J in Index_Type'First .. Container.Last loop
3461 Element_Type'Write (Stream, Container.Elements.EA (J));
3466 (Stream : not null access Root_Stream_Type'Class;
3470 raise Program_Error with "attempt to stream vector cursor";
3474 (Stream : not null access Root_Stream_Type'Class;
3475 Item : Reference_Type)
3478 raise Program_Error with "attempt to stream reference";
3482 (Stream : not null access Root_Stream_Type'Class;
3483 Item : Constant_Reference_Type)
3486 raise Program_Error with "attempt to stream reference";
3489 end Ada.Containers.Vectors;