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,
1050 -- Start of processing for Sort
1053 if Container.Last <= Index_Type'First then
1057 -- The exception behavior for the vector container must match that
1058 -- for the list container, so we check for cursor tampering here
1059 -- (which will catch more things) instead of for element tampering
1060 -- (which will catch fewer things). It's true that the elements of
1061 -- this vector container could be safely moved around while (say) an
1062 -- iteration is taking place (iteration only increments the busy
1063 -- counter), and so technically all we would need here is a test for
1064 -- element tampering (indicated by the lock counter), that's simply
1065 -- an artifact of our array-based implementation. Logically Sort
1066 -- requires a check for cursor tampering.
1068 if Container.Busy > 0 then
1069 raise Program_Error with
1070 "attempt to tamper with cursors (vector is busy)";
1073 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1076 end Generic_Sorting;
1082 function Has_Element (Position : Cursor) return Boolean is
1084 return Position /= No_Element;
1092 (Container : in out Vector;
1093 Before : Extended_Index;
1094 New_Item : Element_Type;
1095 Count : Count_Type := 1)
1097 Old_Length : constant Count_Type := Container.Length;
1099 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1100 New_Length : Count_Type'Base; -- sum of current length and Count
1101 New_Last : Index_Type'Base; -- last index of vector after insertion
1103 Index : Index_Type'Base; -- scratch for intermediate values
1104 J : Count_Type'Base; -- scratch
1106 New_Capacity : Count_Type'Base; -- length of new, expanded array
1107 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1108 Dst : Elements_Access; -- new, expanded internal array
1111 -- As a precondition on the generic actual Index_Type, the base type
1112 -- must include Index_Type'Pred (Index_Type'First); this is the value
1113 -- that Container.Last assumes when the vector is empty. However, we do
1114 -- not allow that as the value for Index when specifying where the new
1115 -- items should be inserted, so we must manually check. (That the user
1116 -- is allowed to specify the value at all here is a consequence of the
1117 -- declaration of the Extended_Index subtype, which includes the values
1118 -- in the base range that immediately precede and immediately follow the
1119 -- values in the Index_Type.)
1121 if Before < Index_Type'First then
1122 raise Constraint_Error with
1123 "Before index is out of range (too small)";
1126 -- We do allow a value greater than Container.Last to be specified as
1127 -- the Index, but only if it's immediately greater. This allows for the
1128 -- case of appending items to the back end of the vector. (It is assumed
1129 -- that specifying an index value greater than Last + 1 indicates some
1130 -- deeper flaw in the caller's algorithm, so that case is treated as a
1133 if Before > Container.Last
1134 and then Before > Container.Last + 1
1136 raise Constraint_Error with
1137 "Before index is out of range (too large)";
1140 -- We treat inserting 0 items into the container as a no-op, even when
1141 -- the container is busy, so we simply return.
1147 -- There are two constraints we need to satisfy. The first constraint is
1148 -- that a container cannot have more than Count_Type'Last elements, so
1149 -- we must check the sum of the current length and the insertion count.
1150 -- Note: we cannot simply add these values, because of the possibility
1153 if Old_Length > Count_Type'Last - Count then
1154 raise Constraint_Error with "Count is out of range";
1157 -- It is now safe compute the length of the new vector, without fear of
1160 New_Length := Old_Length + Count;
1162 -- The second constraint is that the new Last index value cannot exceed
1163 -- Index_Type'Last. In each branch below, we calculate the maximum
1164 -- length (computed from the range of values in Index_Type), and then
1165 -- compare the new length to the maximum length. If the new length is
1166 -- acceptable, then we compute the new last index from that.
1168 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1170 -- We have to handle the case when there might be more values in the
1171 -- range of Index_Type than in the range of Count_Type.
1173 if Index_Type'First <= 0 then
1175 -- We know that No_Index (the same as Index_Type'First - 1) is
1176 -- less than 0, so it is safe to compute the following sum without
1177 -- fear of overflow.
1179 Index := No_Index + Index_Type'Base (Count_Type'Last);
1181 if Index <= Index_Type'Last then
1183 -- We have determined that range of Index_Type has at least as
1184 -- many values as in Count_Type, so Count_Type'Last is the
1185 -- maximum number of items that are allowed.
1187 Max_Length := Count_Type'Last;
1190 -- The range of Index_Type has fewer values than in Count_Type,
1191 -- so the maximum number of items is computed from the range of
1194 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1198 -- No_Index is equal or greater than 0, so we can safely compute
1199 -- the difference without fear of overflow (which we would have to
1200 -- worry about if No_Index were less than 0, but that case is
1203 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1206 elsif Index_Type'First <= 0 then
1208 -- We know that No_Index (the same as Index_Type'First - 1) is less
1209 -- than 0, so it is safe to compute the following sum without fear of
1212 J := Count_Type'Base (No_Index) + Count_Type'Last;
1214 if J <= Count_Type'Base (Index_Type'Last) then
1216 -- We have determined that range of Index_Type has at least as
1217 -- many values as in Count_Type, so Count_Type'Last is the maximum
1218 -- number of items that are allowed.
1220 Max_Length := Count_Type'Last;
1223 -- The range of Index_Type has fewer values than Count_Type does,
1224 -- so the maximum number of items is computed from the range of
1228 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1232 -- No_Index is equal or greater than 0, so we can safely compute the
1233 -- difference without fear of overflow (which we would have to worry
1234 -- about if No_Index were less than 0, but that case is handled
1238 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1241 -- We have just computed the maximum length (number of items). We must
1242 -- now compare the requested length to the maximum length, as we do not
1243 -- allow a vector expand beyond the maximum (because that would create
1244 -- an internal array with a last index value greater than
1245 -- Index_Type'Last, with no way to index those elements).
1247 if New_Length > Max_Length then
1248 raise Constraint_Error with "Count is out of range";
1251 -- New_Last is the last index value of the items in the container after
1252 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1253 -- compute its value from the New_Length.
1255 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1256 New_Last := No_Index + Index_Type'Base (New_Length);
1258 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1261 if Container.Elements = null then
1262 pragma Assert (Container.Last = No_Index);
1264 -- This is the simplest case, with which we must always begin: we're
1265 -- inserting items into an empty vector that hasn't allocated an
1266 -- internal array yet. Note that we don't need to check the busy bit
1267 -- here, because an empty container cannot be busy.
1269 -- In order to preserve container invariants, we allocate the new
1270 -- internal array first, before setting the Last index value, in case
1271 -- the allocation fails (which can happen either because there is no
1272 -- storage available, or because element initialization fails).
1274 Container.Elements := new Elements_Type'
1276 EA => (others => New_Item));
1278 -- The allocation of the new, internal array succeeded, so it is now
1279 -- safe to update the Last index, restoring container invariants.
1281 Container.Last := New_Last;
1286 -- The tampering bits exist to prevent an item from being harmfully
1287 -- manipulated while it is being visited. Query, Update, and Iterate
1288 -- increment the busy count on entry, and decrement the count on
1289 -- exit. Insert checks the count to determine whether it is being called
1290 -- while the associated callback procedure is executing.
1292 if Container.Busy > 0 then
1293 raise Program_Error with
1294 "attempt to tamper with cursors (vector is busy)";
1297 -- An internal array has already been allocated, so we must determine
1298 -- whether there is enough unused storage for the new items.
1300 if New_Length <= Container.Elements.EA'Length then
1302 -- In this case, we're inserting elements into a vector that has
1303 -- already allocated an internal array, and the existing array has
1304 -- enough unused storage for the new items.
1307 EA : Elements_Array renames Container.Elements.EA;
1310 if Before > Container.Last then
1312 -- The new items are being appended to the vector, so no
1313 -- sliding of existing elements is required.
1315 EA (Before .. New_Last) := (others => New_Item);
1318 -- The new items are being inserted before some existing
1319 -- elements, so we must slide the existing elements up to their
1320 -- new home. We use the wider of Index_Type'Base and
1321 -- Count_Type'Base as the type for intermediate index values.
1323 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1324 Index := Before + Index_Type'Base (Count);
1327 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1330 EA (Index .. New_Last) := EA (Before .. Container.Last);
1331 EA (Before .. Index - 1) := (others => New_Item);
1335 Container.Last := New_Last;
1339 -- In this case, we're inserting elements into a vector that has already
1340 -- allocated an internal array, but the existing array does not have
1341 -- enough storage, so we must allocate a new, longer array. In order to
1342 -- guarantee that the amortized insertion cost is O(1), we always
1343 -- allocate an array whose length is some power-of-two factor of the
1344 -- current array length. (The new array cannot have a length less than
1345 -- the New_Length of the container, but its last index value cannot be
1346 -- greater than Index_Type'Last.)
1348 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1349 while New_Capacity < New_Length loop
1350 if New_Capacity > Count_Type'Last / 2 then
1351 New_Capacity := Count_Type'Last;
1355 New_Capacity := 2 * New_Capacity;
1358 if New_Capacity > Max_Length then
1360 -- We have reached the limit of capacity, so no further expansion
1361 -- will occur. (This is not a problem, as there is never a need to
1362 -- have more capacity than the maximum container length.)
1364 New_Capacity := Max_Length;
1367 -- We have computed the length of the new internal array (and this is
1368 -- what "vector capacity" means), so use that to compute its last index.
1370 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1371 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1375 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1378 -- Now we allocate the new, longer internal array. If the allocation
1379 -- fails, we have not changed any container state, so no side-effect
1380 -- will occur as a result of propagating the exception.
1382 Dst := new Elements_Type (Dst_Last);
1384 -- We have our new internal array. All that needs to be done now is to
1385 -- copy the existing items (if any) from the old array (the "source"
1386 -- array, object SA below) to the new array (the "destination" array,
1387 -- object DA below), and then deallocate the old array.
1390 SA : Elements_Array renames Container.Elements.EA; -- source
1391 DA : Elements_Array renames Dst.EA; -- destination
1394 DA (Index_Type'First .. Before - 1) :=
1395 SA (Index_Type'First .. Before - 1);
1397 if Before > Container.Last then
1398 DA (Before .. New_Last) := (others => New_Item);
1401 -- The new items are being inserted before some existing elements,
1402 -- so we must slide the existing elements up to their new home.
1404 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1405 Index := Before + Index_Type'Base (Count);
1408 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1411 DA (Before .. Index - 1) := (others => New_Item);
1412 DA (Index .. New_Last) := SA (Before .. Container.Last);
1421 -- We have successfully copied the items onto the new array, so the
1422 -- final thing to do is deallocate the old array.
1425 X : Elements_Access := Container.Elements;
1427 -- We first isolate the old internal array, removing it from the
1428 -- container and replacing it with the new internal array, before we
1429 -- deallocate the old array (which can fail if finalization of
1430 -- elements propagates an exception).
1432 Container.Elements := Dst;
1433 Container.Last := New_Last;
1435 -- The container invariants have been restored, so it is now safe to
1436 -- attempt to deallocate the old array.
1443 (Container : in out Vector;
1444 Before : Extended_Index;
1447 N : constant Count_Type := Length (New_Item);
1448 J : Index_Type'Base;
1451 -- Use Insert_Space to create the "hole" (the destination slice) into
1452 -- which we copy the source items.
1454 Insert_Space (Container, Before, Count => N);
1458 -- There's nothing else to do here (vetting of parameters was
1459 -- performed already in Insert_Space), so we simply return.
1464 -- We calculate the last index value of the destination slice using the
1465 -- wider of Index_Type'Base and count_Type'Base.
1467 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1468 J := (Before - 1) + Index_Type'Base (N);
1471 J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
1474 if Container'Address /= New_Item'Address then
1476 -- This is the simple case. New_Item denotes an object different
1477 -- from Container, so there's nothing special we need to do to copy
1478 -- the source items to their destination, because all of the source
1479 -- items are contiguous.
1481 Container.Elements.EA (Before .. J) :=
1482 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
1487 -- New_Item denotes the same object as Container, so an insertion has
1488 -- potentially split the source items. The destination is always the
1489 -- range [Before, J], but the source is [Index_Type'First, Before) and
1490 -- (J, Container.Last]. We perform the copy in two steps, using each of
1491 -- the two slices of the source items.
1494 L : constant Index_Type'Base := Before - 1;
1496 subtype Src_Index_Subtype is Index_Type'Base range
1497 Index_Type'First .. L;
1499 Src : Elements_Array renames
1500 Container.Elements.EA (Src_Index_Subtype);
1502 K : Index_Type'Base;
1505 -- We first copy the source items that precede the space we
1506 -- inserted. Index value K is the last index of that portion
1507 -- destination that receives this slice of the source. (If Before
1508 -- equals Index_Type'First, then this first source slice will be
1509 -- empty, which is harmless.)
1511 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1512 K := L + Index_Type'Base (Src'Length);
1515 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1518 Container.Elements.EA (Before .. K) := Src;
1520 if Src'Length = N then
1522 -- The new items were effectively appended to the container, so we
1523 -- have already copied all of the items that need to be copied.
1524 -- We return early here, even though the source slice below is
1525 -- empty (so the assignment would be harmless), because we want to
1526 -- avoid computing J + 1, which will overflow if J equals
1527 -- Index_Type'Base'Last.
1534 -- Note that we want to avoid computing J + 1 here, in case J equals
1535 -- Index_Type'Base'Last. We prevent that by returning early above,
1536 -- immediately after copying the first slice of the source, and
1537 -- determining that this second slice of the source is empty.
1539 F : constant Index_Type'Base := J + 1;
1541 subtype Src_Index_Subtype is Index_Type'Base range
1542 F .. Container.Last;
1544 Src : Elements_Array renames
1545 Container.Elements.EA (Src_Index_Subtype);
1547 K : Index_Type'Base;
1550 -- We next copy the source items that follow the space we inserted.
1551 -- Index value K is the first index of that portion of the
1552 -- destination that receives this slice of the source. (For the
1553 -- reasons given above, this slice is guaranteed to be non-empty.)
1555 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1556 K := F - Index_Type'Base (Src'Length);
1559 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1562 Container.Elements.EA (K .. J) := Src;
1567 (Container : in out Vector;
1571 Index : Index_Type'Base;
1574 if Before.Container /= null
1575 and then Before.Container /= Container'Unrestricted_Access
1577 raise Program_Error with "Before cursor denotes wrong container";
1580 if Is_Empty (New_Item) then
1584 if Before.Container = null
1585 or else Before.Index > Container.Last
1587 if Container.Last = Index_Type'Last then
1588 raise Constraint_Error with
1589 "vector is already at its maximum length";
1592 Index := Container.Last + 1;
1595 Index := Before.Index;
1598 Insert (Container, Index, New_Item);
1602 (Container : in out Vector;
1605 Position : out Cursor)
1607 Index : Index_Type'Base;
1610 if Before.Container /= null
1611 and then Before.Container /= Container'Unrestricted_Access
1613 raise Program_Error with "Before cursor denotes wrong container";
1616 if Is_Empty (New_Item) then
1617 if Before.Container = null
1618 or else Before.Index > Container.Last
1620 Position := No_Element;
1622 Position := (Container'Unrestricted_Access, Before.Index);
1628 if Before.Container = null
1629 or else Before.Index > Container.Last
1631 if Container.Last = Index_Type'Last then
1632 raise Constraint_Error with
1633 "vector is already at its maximum length";
1636 Index := Container.Last + 1;
1639 Index := Before.Index;
1642 Insert (Container, Index, New_Item);
1644 Position := (Container'Unrestricted_Access, Index);
1648 (Container : in out Vector;
1650 New_Item : Element_Type;
1651 Count : Count_Type := 1)
1653 Index : Index_Type'Base;
1656 if Before.Container /= null
1657 and then Before.Container /= Container'Unrestricted_Access
1659 raise Program_Error with "Before cursor denotes wrong container";
1666 if Before.Container = null
1667 or else Before.Index > Container.Last
1669 if Container.Last = Index_Type'Last then
1670 raise Constraint_Error with
1671 "vector is already at its maximum length";
1673 Index := Container.Last + 1;
1677 Index := Before.Index;
1680 Insert (Container, Index, New_Item, Count);
1684 (Container : in out Vector;
1686 New_Item : Element_Type;
1687 Position : out Cursor;
1688 Count : Count_Type := 1)
1690 Index : Index_Type'Base;
1693 if Before.Container /= null
1694 and then Before.Container /= Container'Unrestricted_Access
1696 raise Program_Error with "Before cursor denotes wrong container";
1700 if Before.Container = null
1701 or else Before.Index > Container.Last
1703 Position := No_Element;
1705 Position := (Container'Unrestricted_Access, Before.Index);
1711 if Before.Container = null
1712 or else Before.Index > Container.Last
1714 if Container.Last = Index_Type'Last then
1715 raise Constraint_Error with
1716 "vector is already at its maximum length";
1719 Index := Container.Last + 1;
1722 Index := Before.Index;
1725 Insert (Container, Index, New_Item, Count);
1727 Position := (Container'Unrestricted_Access, Index);
1731 (Container : in out Vector;
1732 Before : Extended_Index;
1733 Count : Count_Type := 1)
1735 New_Item : Element_Type; -- Default-initialized value
1736 pragma Warnings (Off, New_Item);
1739 Insert (Container, Before, New_Item, Count);
1743 (Container : in out Vector;
1745 Position : out Cursor;
1746 Count : Count_Type := 1)
1748 New_Item : Element_Type; -- Default-initialized value
1749 pragma Warnings (Off, New_Item);
1752 Insert (Container, Before, New_Item, Position, Count);
1759 procedure Insert_Space
1760 (Container : in out Vector;
1761 Before : Extended_Index;
1762 Count : Count_Type := 1)
1764 Old_Length : constant Count_Type := Container.Length;
1766 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1767 New_Length : Count_Type'Base; -- sum of current length and Count
1768 New_Last : Index_Type'Base; -- last index of vector after insertion
1770 Index : Index_Type'Base; -- scratch for intermediate values
1771 J : Count_Type'Base; -- scratch
1773 New_Capacity : Count_Type'Base; -- length of new, expanded array
1774 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1775 Dst : Elements_Access; -- new, expanded internal array
1778 -- As a precondition on the generic actual Index_Type, the base type
1779 -- must include Index_Type'Pred (Index_Type'First); this is the value
1780 -- that Container.Last assumes when the vector is empty. However, we do
1781 -- not allow that as the value for Index when specifying where the new
1782 -- items should be inserted, so we must manually check. (That the user
1783 -- is allowed to specify the value at all here is a consequence of the
1784 -- declaration of the Extended_Index subtype, which includes the values
1785 -- in the base range that immediately precede and immediately follow the
1786 -- values in the Index_Type.)
1788 if Before < Index_Type'First then
1789 raise Constraint_Error with
1790 "Before index is out of range (too small)";
1793 -- We do allow a value greater than Container.Last to be specified as
1794 -- the Index, but only if it's immediately greater. This allows for the
1795 -- case of appending items to the back end of the vector. (It is assumed
1796 -- that specifying an index value greater than Last + 1 indicates some
1797 -- deeper flaw in the caller's algorithm, so that case is treated as a
1800 if Before > Container.Last
1801 and then Before > Container.Last + 1
1803 raise Constraint_Error with
1804 "Before index is out of range (too large)";
1807 -- We treat inserting 0 items into the container as a no-op, even when
1808 -- the container is busy, so we simply return.
1814 -- There are two constraints we need to satisfy. The first constraint is
1815 -- that a container cannot have more than Count_Type'Last elements, so
1816 -- we must check the sum of the current length and the insertion count.
1817 -- Note: we cannot simply add these values, because of the possibility
1820 if Old_Length > Count_Type'Last - Count then
1821 raise Constraint_Error with "Count is out of range";
1824 -- It is now safe compute the length of the new vector, without fear of
1827 New_Length := Old_Length + Count;
1829 -- The second constraint is that the new Last index value cannot exceed
1830 -- Index_Type'Last. In each branch below, we calculate the maximum
1831 -- length (computed from the range of values in Index_Type), and then
1832 -- compare the new length to the maximum length. If the new length is
1833 -- acceptable, then we compute the new last index from that.
1835 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1837 -- We have to handle the case when there might be more values in the
1838 -- range of Index_Type than in the range of Count_Type.
1840 if Index_Type'First <= 0 then
1842 -- We know that No_Index (the same as Index_Type'First - 1) is
1843 -- less than 0, so it is safe to compute the following sum without
1844 -- fear of overflow.
1846 Index := No_Index + Index_Type'Base (Count_Type'Last);
1848 if Index <= Index_Type'Last then
1850 -- We have determined that range of Index_Type has at least as
1851 -- many values as in Count_Type, so Count_Type'Last is the
1852 -- maximum number of items that are allowed.
1854 Max_Length := Count_Type'Last;
1857 -- The range of Index_Type has fewer values than in Count_Type,
1858 -- so the maximum number of items is computed from the range of
1861 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1865 -- No_Index is equal or greater than 0, so we can safely compute
1866 -- the difference without fear of overflow (which we would have to
1867 -- worry about if No_Index were less than 0, but that case is
1870 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1873 elsif Index_Type'First <= 0 then
1875 -- We know that No_Index (the same as Index_Type'First - 1) is less
1876 -- than 0, so it is safe to compute the following sum without fear of
1879 J := Count_Type'Base (No_Index) + Count_Type'Last;
1881 if J <= Count_Type'Base (Index_Type'Last) then
1883 -- We have determined that range of Index_Type has at least as
1884 -- many values as in Count_Type, so Count_Type'Last is the maximum
1885 -- number of items that are allowed.
1887 Max_Length := Count_Type'Last;
1890 -- The range of Index_Type has fewer values than Count_Type does,
1891 -- so the maximum number of items is computed from the range of
1895 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1899 -- No_Index is equal or greater than 0, so we can safely compute the
1900 -- difference without fear of overflow (which we would have to worry
1901 -- about if No_Index were less than 0, but that case is handled
1905 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1908 -- We have just computed the maximum length (number of items). We must
1909 -- now compare the requested length to the maximum length, as we do not
1910 -- allow a vector expand beyond the maximum (because that would create
1911 -- an internal array with a last index value greater than
1912 -- Index_Type'Last, with no way to index those elements).
1914 if New_Length > Max_Length then
1915 raise Constraint_Error with "Count is out of range";
1918 -- New_Last is the last index value of the items in the container after
1919 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1920 -- compute its value from the New_Length.
1922 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1923 New_Last := No_Index + Index_Type'Base (New_Length);
1926 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1929 if Container.Elements = null then
1930 pragma Assert (Container.Last = No_Index);
1932 -- This is the simplest case, with which we must always begin: we're
1933 -- inserting items into an empty vector that hasn't allocated an
1934 -- internal array yet. Note that we don't need to check the busy bit
1935 -- here, because an empty container cannot be busy.
1937 -- In order to preserve container invariants, we allocate the new
1938 -- internal array first, before setting the Last index value, in case
1939 -- the allocation fails (which can happen either because there is no
1940 -- storage available, or because default-valued element
1941 -- initialization fails).
1943 Container.Elements := new Elements_Type (New_Last);
1945 -- The allocation of the new, internal array succeeded, so it is now
1946 -- safe to update the Last index, restoring container invariants.
1948 Container.Last := New_Last;
1953 -- The tampering bits exist to prevent an item from being harmfully
1954 -- manipulated while it is being visited. Query, Update, and Iterate
1955 -- increment the busy count on entry, and decrement the count on
1956 -- exit. Insert checks the count to determine whether it is being called
1957 -- while the associated callback procedure is executing.
1959 if Container.Busy > 0 then
1960 raise Program_Error with
1961 "attempt to tamper with cursors (vector is busy)";
1964 -- An internal array has already been allocated, so we must determine
1965 -- whether there is enough unused storage for the new items.
1967 if New_Last <= Container.Elements.Last then
1969 -- In this case, we're inserting space into a vector that has already
1970 -- allocated an internal array, and the existing array has enough
1971 -- unused storage for the new items.
1974 EA : Elements_Array renames Container.Elements.EA;
1977 if Before <= Container.Last then
1979 -- The space is being inserted before some existing elements,
1980 -- so we must slide the existing elements up to their new
1981 -- home. We use the wider of Index_Type'Base and
1982 -- Count_Type'Base as the type for intermediate index values.
1984 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1985 Index := Before + Index_Type'Base (Count);
1988 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1991 EA (Index .. New_Last) := EA (Before .. Container.Last);
1995 Container.Last := New_Last;
1999 -- In this case, we're inserting space into a vector that has already
2000 -- allocated an internal array, but the existing array does not have
2001 -- enough storage, so we must allocate a new, longer array. In order to
2002 -- guarantee that the amortized insertion cost is O(1), we always
2003 -- allocate an array whose length is some power-of-two factor of the
2004 -- current array length. (The new array cannot have a length less than
2005 -- the New_Length of the container, but its last index value cannot be
2006 -- greater than Index_Type'Last.)
2008 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2009 while New_Capacity < New_Length loop
2010 if New_Capacity > Count_Type'Last / 2 then
2011 New_Capacity := Count_Type'Last;
2015 New_Capacity := 2 * New_Capacity;
2018 if New_Capacity > Max_Length then
2020 -- We have reached the limit of capacity, so no further expansion
2021 -- will occur. (This is not a problem, as there is never a need to
2022 -- have more capacity than the maximum container length.)
2024 New_Capacity := Max_Length;
2027 -- We have computed the length of the new internal array (and this is
2028 -- what "vector capacity" means), so use that to compute its last index.
2030 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2031 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2035 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2038 -- Now we allocate the new, longer internal array. If the allocation
2039 -- fails, we have not changed any container state, so no side-effect
2040 -- will occur as a result of propagating the exception.
2042 Dst := new Elements_Type (Dst_Last);
2044 -- We have our new internal array. All that needs to be done now is to
2045 -- copy the existing items (if any) from the old array (the "source"
2046 -- array, object SA below) to the new array (the "destination" array,
2047 -- object DA below), and then deallocate the old array.
2050 SA : Elements_Array renames Container.Elements.EA; -- source
2051 DA : Elements_Array renames Dst.EA; -- destination
2054 DA (Index_Type'First .. Before - 1) :=
2055 SA (Index_Type'First .. Before - 1);
2057 if Before <= Container.Last then
2059 -- The space is being inserted before some existing elements, so
2060 -- we must slide the existing elements up to their new home.
2062 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2063 Index := Before + Index_Type'Base (Count);
2066 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2069 DA (Index .. New_Last) := SA (Before .. Container.Last);
2078 -- We have successfully copied the items onto the new array, so the
2079 -- final thing to do is restore invariants, and deallocate the old
2083 X : Elements_Access := Container.Elements;
2086 -- We first isolate the old internal array, removing it from the
2087 -- container and replacing it with the new internal array, before we
2088 -- deallocate the old array (which can fail if finalization of
2089 -- elements propagates an exception).
2091 Container.Elements := Dst;
2092 Container.Last := New_Last;
2094 -- The container invariants have been restored, so it is now safe to
2095 -- attempt to deallocate the old array.
2101 procedure Insert_Space
2102 (Container : in out Vector;
2104 Position : out Cursor;
2105 Count : Count_Type := 1)
2107 Index : Index_Type'Base;
2110 if Before.Container /= null
2111 and then Before.Container /= Container'Unrestricted_Access
2113 raise Program_Error with "Before cursor denotes wrong container";
2117 if Before.Container = null
2118 or else Before.Index > Container.Last
2120 Position := No_Element;
2122 Position := (Container'Unrestricted_Access, Before.Index);
2128 if Before.Container = null
2129 or else Before.Index > Container.Last
2131 if Container.Last = Index_Type'Last then
2132 raise Constraint_Error with
2133 "vector is already at its maximum length";
2135 Index := Container.Last + 1;
2139 Index := Before.Index;
2142 Insert_Space (Container, Index, Count => Count);
2144 Position := (Container'Unrestricted_Access, Index);
2151 function Is_Empty (Container : Vector) return Boolean is
2153 return Container.Last < Index_Type'First;
2161 (Container : Vector;
2162 Process : not null access procedure (Position : Cursor))
2164 B : Natural renames Container'Unrestricted_Access.all.Busy;
2170 for Indx in Index_Type'First .. Container.Last loop
2171 Process (Cursor'(Container'Unrestricted_Access, Indx));
2183 (Container : Vector)
2184 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2186 V : constant Vector_Access := Container'Unrestricted_Access;
2187 B : Natural renames V.Busy;
2190 -- The value of its Index component influences the behavior of the First
2191 -- and Last selector functions of the iterator object. When the Index
2192 -- component is No_Index (as is the case here), this means the iterator
2193 -- object was constructed without a start expression. This is a complete
2194 -- iterator, meaning that the iteration starts from the (logical)
2195 -- beginning of the sequence of items.
2197 -- Note: For a forward iterator, Container.First is the beginning, and
2198 -- for a reverse iterator, Container.Last is the beginning.
2200 return It : constant Iterator :=
2201 (Limited_Controlled with
2210 (Container : Vector;
2212 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2214 V : constant Vector_Access := Container'Unrestricted_Access;
2215 B : Natural renames V.Busy;
2218 -- It was formerly the case that when Start = No_Element, the partial
2219 -- iterator was defined to behave the same as for a complete iterator,
2220 -- and iterate over the entire sequence of items. However, those
2221 -- semantics were unintuitive and arguably error-prone (it is too easy
2222 -- to accidentally create an endless loop), and so they were changed,
2223 -- per the ARG meeting in Denver on 2011/11. However, there was no
2224 -- consensus about what positive meaning this corner case should have,
2225 -- and so it was decided to simply raise an exception. This does imply,
2226 -- however, that it is not possible to use a partial iterator to specify
2227 -- an empty sequence of items.
2229 if Start.Container = null then
2230 raise Constraint_Error with
2231 "Start position for iterator equals No_Element";
2234 if Start.Container /= V then
2235 raise Program_Error with
2236 "Start cursor of Iterate designates wrong vector";
2239 if Start.Index > V.Last then
2240 raise Constraint_Error with
2241 "Start position for iterator equals No_Element";
2244 -- The value of its Index component influences the behavior of the First
2245 -- and Last selector functions of the iterator object. When the Index
2246 -- component is not No_Index (as is the case here), it means that this
2247 -- is a partial iteration, over a subset of the complete sequence of
2248 -- items. The iterator object was constructed with a start expression,
2249 -- indicating the position from which the iteration begins. Note that
2250 -- the start position has the same value irrespective of whether this
2251 -- is a forward or reverse iteration.
2253 return It : constant Iterator :=
2254 (Limited_Controlled with
2256 Index => Start.Index)
2266 function Last (Container : Vector) return Cursor is
2268 if Is_Empty (Container) then
2271 return (Container'Unrestricted_Access, Container.Last);
2275 function Last (Object : Iterator) return Cursor is
2277 -- The value of the iterator object's Index component influences the
2278 -- behavior of the Last (and First) selector function.
2280 -- When the Index component is No_Index, this means the iterator
2281 -- object was constructed without a start expression, in which case the
2282 -- (reverse) iteration starts from the (logical) beginning of the entire
2283 -- sequence (corresponding to Container.Last, for a reverse iterator).
2285 -- Otherwise, this is iteration over a partial sequence of items.
2286 -- When the Index component is not No_Index, the iterator object was
2287 -- constructed with a start expression, that specifies the position
2288 -- from which the (reverse) partial iteration begins.
2290 if Object.Index = No_Index then
2291 return Last (Object.Container.all);
2293 return Cursor'(Object.Container, Object.Index);
2301 function Last_Element (Container : Vector) return Element_Type is
2303 if Container.Last = No_Index then
2304 raise Constraint_Error with "Container is empty";
2306 return Container.Elements.EA (Container.Last);
2314 function Last_Index (Container : Vector) return Extended_Index is
2316 return Container.Last;
2323 function Length (Container : Vector) return Count_Type is
2324 L : constant Index_Type'Base := Container.Last;
2325 F : constant Index_Type := Index_Type'First;
2328 -- The base range of the index type (Index_Type'Base) might not include
2329 -- all values for length (Count_Type). Contrariwise, the index type
2330 -- might include values outside the range of length. Hence we use
2331 -- whatever type is wider for intermediate values when calculating
2332 -- length. Note that no matter what the index type is, the maximum
2333 -- length to which a vector is allowed to grow is always the minimum
2334 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2336 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2337 -- to have a base range of -128 .. 127, but the corresponding vector
2338 -- would have lengths in the range 0 .. 255. In this case we would need
2339 -- to use Count_Type'Base for intermediate values.
2341 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2342 -- vector would have a maximum length of 10, but the index values lie
2343 -- outside the range of Count_Type (which is only 32 bits). In this
2344 -- case we would need to use Index_Type'Base for intermediate values.
2346 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2347 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2349 return Count_Type (L - F + 1);
2358 (Target : in out Vector;
2359 Source : in out Vector)
2362 if Target'Address = Source'Address then
2366 if Target.Busy > 0 then
2367 raise Program_Error with
2368 "attempt to tamper with cursors (Target is busy)";
2371 if Source.Busy > 0 then
2372 raise Program_Error with
2373 "attempt to tamper with cursors (Source is busy)";
2377 Target_Elements : constant Elements_Access := Target.Elements;
2379 Target.Elements := Source.Elements;
2380 Source.Elements := Target_Elements;
2383 Target.Last := Source.Last;
2384 Source.Last := No_Index;
2391 function Next (Position : Cursor) return Cursor is
2393 if Position.Container = null then
2395 elsif Position.Index < Position.Container.Last then
2396 return (Position.Container, Position.Index + 1);
2402 function Next (Object : Iterator; Position : Cursor) return Cursor is
2404 if Position.Container = null then
2408 if Position.Container /= Object.Container then
2409 raise Program_Error with
2410 "Position cursor of Next designates wrong vector";
2413 return Next (Position);
2416 procedure Next (Position : in out Cursor) is
2418 if Position.Container = null then
2420 elsif Position.Index < Position.Container.Last then
2421 Position.Index := Position.Index + 1;
2423 Position := No_Element;
2431 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2433 Insert (Container, Index_Type'First, New_Item);
2437 (Container : in out Vector;
2438 New_Item : Element_Type;
2439 Count : Count_Type := 1)
2452 function Previous (Position : Cursor) return Cursor is
2454 if Position.Container = null then
2456 elsif Position.Index > Index_Type'First then
2457 return (Position.Container, Position.Index - 1);
2463 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2465 if Position.Container = null then
2469 if Position.Container /= Object.Container then
2470 raise Program_Error with
2471 "Position cursor of Previous designates wrong vector";
2474 return Previous (Position);
2477 procedure Previous (Position : in out Cursor) is
2479 if Position.Container = null then
2481 elsif Position.Index > Index_Type'First then
2482 Position.Index := Position.Index - 1;
2484 Position := No_Element;
2492 procedure Query_Element
2493 (Container : Vector;
2495 Process : not null access procedure (Element : Element_Type))
2497 V : Vector renames Container'Unrestricted_Access.all;
2498 B : Natural renames V.Busy;
2499 L : Natural renames V.Lock;
2502 if Index > Container.Last then
2503 raise Constraint_Error with "Index is out of range";
2510 Process (V.Elements.EA (Index));
2522 procedure Query_Element
2524 Process : not null access procedure (Element : Element_Type))
2527 if Position.Container = null then
2528 raise Constraint_Error with "Position cursor has no element";
2531 Query_Element (Position.Container.all, Position.Index, Process);
2539 (Stream : not null access Root_Stream_Type'Class;
2540 Container : out Vector)
2542 Length : Count_Type'Base;
2543 Last : Index_Type'Base := No_Index;
2548 Count_Type'Base'Read (Stream, Length);
2550 if Length > Capacity (Container) then
2551 Reserve_Capacity (Container, Capacity => Length);
2554 for J in Count_Type range 1 .. Length loop
2556 Element_Type'Read (Stream, Container.Elements.EA (Last));
2557 Container.Last := Last;
2562 (Stream : not null access Root_Stream_Type'Class;
2563 Position : out Cursor)
2566 raise Program_Error with "attempt to stream vector cursor";
2570 (Stream : not null access Root_Stream_Type'Class;
2571 Item : out Reference_Type)
2574 raise Program_Error with "attempt to stream reference";
2578 (Stream : not null access Root_Stream_Type'Class;
2579 Item : out Constant_Reference_Type)
2582 raise Program_Error with "attempt to stream reference";
2590 (Container : aliased in out Vector;
2591 Position : Cursor) return Reference_Type
2594 if Position.Container = null then
2595 raise Constraint_Error with "Position cursor has no element";
2598 if Position.Container /= Container'Unrestricted_Access then
2599 raise Program_Error with "Position cursor denotes wrong container";
2602 if Position.Index > Position.Container.Last then
2603 raise Constraint_Error with "Position cursor is out of range";
2606 return (Element => Container.Elements.EA (Position.Index)'Access);
2610 (Container : aliased in out Vector;
2611 Index : Index_Type) return Reference_Type
2614 if Index > Container.Last then
2615 raise Constraint_Error with "Index is out of range";
2617 return (Element => Container.Elements.EA (Index)'Access);
2621 ---------------------
2622 -- Replace_Element --
2623 ---------------------
2625 procedure Replace_Element
2626 (Container : in out Vector;
2628 New_Item : Element_Type)
2631 if Index > Container.Last then
2632 raise Constraint_Error with "Index is out of range";
2635 if Container.Lock > 0 then
2636 raise Program_Error with
2637 "attempt to tamper with elements (vector is locked)";
2640 Container.Elements.EA (Index) := New_Item;
2641 end Replace_Element;
2643 procedure Replace_Element
2644 (Container : in out Vector;
2646 New_Item : Element_Type)
2649 if Position.Container = null then
2650 raise Constraint_Error with "Position cursor has no element";
2653 if Position.Container /= Container'Unrestricted_Access then
2654 raise Program_Error with "Position cursor denotes wrong container";
2657 if Position.Index > Container.Last then
2658 raise Constraint_Error with "Position cursor is out of range";
2661 if Container.Lock > 0 then
2662 raise Program_Error with
2663 "attempt to tamper with elements (vector is locked)";
2666 Container.Elements.EA (Position.Index) := New_Item;
2667 end Replace_Element;
2669 ----------------------
2670 -- Reserve_Capacity --
2671 ----------------------
2673 procedure Reserve_Capacity
2674 (Container : in out Vector;
2675 Capacity : Count_Type)
2677 N : constant Count_Type := Length (Container);
2679 Index : Count_Type'Base;
2680 Last : Index_Type'Base;
2683 -- Reserve_Capacity can be used to either expand the storage available
2684 -- for elements (this would be its typical use, in anticipation of
2685 -- future insertion), or to trim back storage. In the latter case,
2686 -- storage can only be trimmed back to the limit of the container
2687 -- length. Note that Reserve_Capacity neither deletes (active) elements
2688 -- nor inserts elements; it only affects container capacity, never
2689 -- container length.
2691 if Capacity = 0 then
2693 -- This is a request to trim back storage, to the minimum amount
2694 -- possible given the current state of the container.
2698 -- The container is empty, so in this unique case we can
2699 -- deallocate the entire internal array. Note that an empty
2700 -- container can never be busy, so there's no need to check the
2704 X : Elements_Access := Container.Elements;
2707 -- First we remove the internal array from the container, to
2708 -- handle the case when the deallocation raises an exception.
2710 Container.Elements := null;
2712 -- Container invariants have been restored, so it is now safe
2713 -- to attempt to deallocate the internal array.
2718 elsif N < Container.Elements.EA'Length then
2720 -- The container is not empty, and the current length is less than
2721 -- the current capacity, so there's storage available to trim. In
2722 -- this case, we allocate a new internal array having a length
2723 -- that exactly matches the number of items in the
2724 -- container. (Reserve_Capacity does not delete active elements,
2725 -- so this is the best we can do with respect to minimizing
2728 if Container.Busy > 0 then
2729 raise Program_Error with
2730 "attempt to tamper with cursors (vector is busy)";
2734 subtype Src_Index_Subtype is Index_Type'Base range
2735 Index_Type'First .. Container.Last;
2737 Src : Elements_Array renames
2738 Container.Elements.EA (Src_Index_Subtype);
2740 X : Elements_Access := Container.Elements;
2743 -- Although we have isolated the old internal array that we're
2744 -- going to deallocate, we don't deallocate it until we have
2745 -- successfully allocated a new one. If there is an exception
2746 -- during allocation (either because there is not enough
2747 -- storage, or because initialization of the elements fails),
2748 -- we let it propagate without causing any side-effect.
2750 Container.Elements := new Elements_Type'(Container.Last, Src);
2752 -- We have successfully allocated a new internal array (with a
2753 -- smaller length than the old one, and containing a copy of
2754 -- just the active elements in the container), so it is now
2755 -- safe to attempt to deallocate the old array. The old array
2756 -- has been isolated, and container invariants have been
2757 -- restored, so if the deallocation fails (because finalization
2758 -- of the elements fails), we simply let it propagate.
2767 -- Reserve_Capacity can be used to expand the storage available for
2768 -- elements, but we do not let the capacity grow beyond the number of
2769 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2770 -- to refer to the elements with an index value greater than
2771 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2772 -- the Last index value of the new internal array, in a way that avoids
2773 -- any possibility of overflow.
2775 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2777 -- We perform a two-part test. First we determine whether the
2778 -- computed Last value lies in the base range of the type, and then
2779 -- determine whether it lies in the range of the index (sub)type.
2781 -- Last must satisfy this relation:
2782 -- First + Length - 1 <= Last
2783 -- We regroup terms:
2784 -- First - 1 <= Last - Length
2785 -- Which can rewrite as:
2786 -- No_Index <= Last - Length
2788 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
2789 raise Constraint_Error with "Capacity is out of range";
2792 -- We now know that the computed value of Last is within the base
2793 -- range of the type, so it is safe to compute its value:
2795 Last := No_Index + Index_Type'Base (Capacity);
2797 -- Finally we test whether the value is within the range of the
2798 -- generic actual index subtype:
2800 if Last > Index_Type'Last then
2801 raise Constraint_Error with "Capacity is out of range";
2804 elsif Index_Type'First <= 0 then
2806 -- Here we can compute Last directly, in the normal way. We know that
2807 -- No_Index is less than 0, so there is no danger of overflow when
2808 -- adding the (positive) value of Capacity.
2810 Index := Count_Type'Base (No_Index) + Capacity; -- Last
2812 if Index > Count_Type'Base (Index_Type'Last) then
2813 raise Constraint_Error with "Capacity is out of range";
2816 -- We know that the computed value (having type Count_Type) of Last
2817 -- is within the range of the generic actual index subtype, so it is
2818 -- safe to convert to Index_Type:
2820 Last := Index_Type'Base (Index);
2823 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2824 -- must test the length indirectly (by working backwards from the
2825 -- largest possible value of Last), in order to prevent overflow.
2827 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
2829 if Index < Count_Type'Base (No_Index) then
2830 raise Constraint_Error with "Capacity is out of range";
2833 -- We have determined that the value of Capacity would not create a
2834 -- Last index value outside of the range of Index_Type, so we can now
2835 -- safely compute its value.
2837 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
2840 -- The requested capacity is non-zero, but we don't know yet whether
2841 -- this is a request for expansion or contraction of storage.
2843 if Container.Elements = null then
2845 -- The container is empty (it doesn't even have an internal array),
2846 -- so this represents a request to allocate (expand) storage having
2847 -- the given capacity.
2849 Container.Elements := new Elements_Type (Last);
2853 if Capacity <= N then
2855 -- This is a request to trim back storage, but only to the limit of
2856 -- what's already in the container. (Reserve_Capacity never deletes
2857 -- active elements, it only reclaims excess storage.)
2859 if N < Container.Elements.EA'Length then
2861 -- The container is not empty (because the requested capacity is
2862 -- positive, and less than or equal to the container length), and
2863 -- the current length is less than the current capacity, so
2864 -- there's storage available to trim. In this case, we allocate a
2865 -- new internal array having a length that exactly matches the
2866 -- number of items in the container.
2868 if Container.Busy > 0 then
2869 raise Program_Error with
2870 "attempt to tamper with cursors (vector is busy)";
2874 subtype Src_Index_Subtype is Index_Type'Base range
2875 Index_Type'First .. Container.Last;
2877 Src : Elements_Array renames
2878 Container.Elements.EA (Src_Index_Subtype);
2880 X : Elements_Access := Container.Elements;
2883 -- Although we have isolated the old internal array that we're
2884 -- going to deallocate, we don't deallocate it until we have
2885 -- successfully allocated a new one. If there is an exception
2886 -- during allocation (either because there is not enough
2887 -- storage, or because initialization of the elements fails),
2888 -- we let it propagate without causing any side-effect.
2890 Container.Elements := new Elements_Type'(Container.Last, Src);
2892 -- We have successfully allocated a new internal array (with a
2893 -- smaller length than the old one, and containing a copy of
2894 -- just the active elements in the container), so it is now
2895 -- safe to attempt to deallocate the old array. The old array
2896 -- has been isolated, and container invariants have been
2897 -- restored, so if the deallocation fails (because finalization
2898 -- of the elements fails), we simply let it propagate.
2907 -- The requested capacity is larger than the container length (the
2908 -- number of active elements). Whether this represents a request for
2909 -- expansion or contraction of the current capacity depends on what the
2910 -- current capacity is.
2912 if Capacity = Container.Elements.EA'Length then
2914 -- The requested capacity matches the existing capacity, so there's
2915 -- nothing to do here. We treat this case as a no-op, and simply
2916 -- return without checking the busy bit.
2921 -- There is a change in the capacity of a non-empty container, so a new
2922 -- internal array will be allocated. (The length of the new internal
2923 -- array could be less or greater than the old internal array. We know
2924 -- only that the length of the new internal array is greater than the
2925 -- number of active elements in the container.) We must check whether
2926 -- the container is busy before doing anything else.
2928 if Container.Busy > 0 then
2929 raise Program_Error with
2930 "attempt to tamper with cursors (vector is busy)";
2933 -- We now allocate a new internal array, having a length different from
2934 -- its current value.
2937 E : Elements_Access := new Elements_Type (Last);
2940 -- We have successfully allocated the new internal array. We first
2941 -- attempt to copy the existing elements from the old internal array
2942 -- ("src" elements) onto the new internal array ("tgt" elements).
2945 subtype Index_Subtype is Index_Type'Base range
2946 Index_Type'First .. Container.Last;
2948 Src : Elements_Array renames
2949 Container.Elements.EA (Index_Subtype);
2951 Tgt : Elements_Array renames E.EA (Index_Subtype);
2962 -- We have successfully copied the existing elements onto the new
2963 -- internal array, so now we can attempt to deallocate the old one.
2966 X : Elements_Access := Container.Elements;
2969 -- First we isolate the old internal array, and replace it in the
2970 -- container with the new internal array.
2972 Container.Elements := E;
2974 -- Container invariants have been restored, so it is now safe to
2975 -- attempt to deallocate the old internal array.
2980 end Reserve_Capacity;
2982 ----------------------
2983 -- Reverse_Elements --
2984 ----------------------
2986 procedure Reverse_Elements (Container : in out Vector) is
2988 if Container.Length <= 1 then
2992 -- The exception behavior for the vector container must match that for
2993 -- the list container, so we check for cursor tampering here (which will
2994 -- catch more things) instead of for element tampering (which will catch
2995 -- fewer things). It's true that the elements of this vector container
2996 -- could be safely moved around while (say) an iteration is taking place
2997 -- (iteration only increments the busy counter), and so technically all
2998 -- we would need here is a test for element tampering (indicated by the
2999 -- lock counter), that's simply an artifact of our array-based
3000 -- implementation. Logically Reverse_Elements requires a check for
3001 -- cursor tampering.
3003 if Container.Busy > 0 then
3004 raise Program_Error with
3005 "attempt to tamper with cursors (vector is busy)";
3010 E : Elements_Type renames Container.Elements.all;
3013 I := Index_Type'First;
3014 J := Container.Last;
3017 EI : constant Element_Type := E.EA (I);
3020 E.EA (I) := E.EA (J);
3028 end Reverse_Elements;
3034 function Reverse_Find
3035 (Container : Vector;
3036 Item : Element_Type;
3037 Position : Cursor := No_Element) return Cursor
3039 Last : Index_Type'Base;
3042 if Position.Container /= null
3043 and then Position.Container /= Container'Unrestricted_Access
3045 raise Program_Error with "Position cursor denotes wrong container";
3049 (if Position.Container = null or else Position.Index > Container.Last
3051 else Position.Index);
3053 for Indx in reverse Index_Type'First .. Last loop
3054 if Container.Elements.EA (Indx) = Item then
3055 return (Container'Unrestricted_Access, Indx);
3062 ------------------------
3063 -- Reverse_Find_Index --
3064 ------------------------
3066 function Reverse_Find_Index
3067 (Container : Vector;
3068 Item : Element_Type;
3069 Index : Index_Type := Index_Type'Last) return Extended_Index
3071 Last : constant Index_Type'Base :=
3072 Index_Type'Min (Container.Last, Index);
3075 for Indx in reverse Index_Type'First .. Last loop
3076 if Container.Elements.EA (Indx) = Item then
3082 end Reverse_Find_Index;
3084 ---------------------
3085 -- Reverse_Iterate --
3086 ---------------------
3088 procedure Reverse_Iterate
3089 (Container : Vector;
3090 Process : not null access procedure (Position : Cursor))
3092 V : Vector renames Container'Unrestricted_Access.all;
3093 B : Natural renames V.Busy;
3099 for Indx in reverse Index_Type'First .. Container.Last loop
3100 Process (Cursor'(Container'Unrestricted_Access, Indx));
3109 end Reverse_Iterate;
3115 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
3116 Count : constant Count_Type'Base := Container.Length - Length;
3119 -- Set_Length allows the user to set the length explicitly, instead of
3120 -- implicitly as a side-effect of deletion or insertion. If the
3121 -- requested length is less then the current length, this is equivalent
3122 -- to deleting items from the back end of the vector. If the requested
3123 -- length is greater than the current length, then this is equivalent to
3124 -- inserting "space" (nonce items) at the end.
3127 Container.Delete_Last (Count);
3129 elsif Container.Last >= Index_Type'Last then
3130 raise Constraint_Error with "vector is already at its maximum length";
3133 Container.Insert_Space (Container.Last + 1, -Count);
3141 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3143 if I > Container.Last then
3144 raise Constraint_Error with "I index is out of range";
3147 if J > Container.Last then
3148 raise Constraint_Error with "J index is out of range";
3155 if Container.Lock > 0 then
3156 raise Program_Error with
3157 "attempt to tamper with elements (vector is locked)";
3161 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3163 Container.Elements.EA (I) := Container.Elements.EA (J);
3164 Container.Elements.EA (J) := EI_Copy;
3168 procedure Swap (Container : in out Vector; I, J : Cursor) is
3170 if I.Container = null then
3171 raise Constraint_Error with "I cursor has no element";
3174 if J.Container = null then
3175 raise Constraint_Error with "J cursor has no element";
3178 if I.Container /= Container'Unrestricted_Access then
3179 raise Program_Error with "I cursor denotes wrong container";
3182 if J.Container /= Container'Unrestricted_Access then
3183 raise Program_Error with "J cursor denotes wrong container";
3186 Swap (Container, I.Index, J.Index);
3194 (Container : Vector;
3195 Index : Extended_Index) return Cursor
3198 if Index not in Index_Type'First .. Container.Last then
3201 return (Container'Unrestricted_Access, Index);
3209 function To_Index (Position : Cursor) return Extended_Index is
3211 if Position.Container = null then
3215 if Position.Index <= Position.Container.Last then
3216 return Position.Index;
3226 function To_Vector (Length : Count_Type) return Vector is
3227 Index : Count_Type'Base;
3228 Last : Index_Type'Base;
3229 Elements : Elements_Access;
3233 return Empty_Vector;
3236 -- We create a vector object with a capacity that matches the specified
3237 -- Length, but we do not allow the vector capacity (the length of the
3238 -- internal array) to exceed the number of values in Index_Type'Range
3239 -- (otherwise, there would be no way to refer to those components via an
3240 -- index). We must therefore check whether the specified Length would
3241 -- create a Last index value greater than Index_Type'Last.
3243 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3245 -- We perform a two-part test. First we determine whether the
3246 -- computed Last value lies in the base range of the type, and then
3247 -- determine whether it lies in the range of the index (sub)type.
3249 -- Last must satisfy this relation:
3250 -- First + Length - 1 <= Last
3251 -- We regroup terms:
3252 -- First - 1 <= Last - Length
3253 -- Which can rewrite as:
3254 -- No_Index <= Last - Length
3256 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3257 raise Constraint_Error with "Length is out of range";
3260 -- We now know that the computed value of Last is within the base
3261 -- range of the type, so it is safe to compute its value:
3263 Last := No_Index + Index_Type'Base (Length);
3265 -- Finally we test whether the value is within the range of the
3266 -- generic actual index subtype:
3268 if Last > Index_Type'Last then
3269 raise Constraint_Error with "Length is out of range";
3272 elsif Index_Type'First <= 0 then
3274 -- Here we can compute Last directly, in the normal way. We know that
3275 -- No_Index is less than 0, so there is no danger of overflow when
3276 -- adding the (positive) value of Length.
3278 Index := Count_Type'Base (No_Index) + Length; -- Last
3280 if Index > Count_Type'Base (Index_Type'Last) then
3281 raise Constraint_Error with "Length is out of range";
3284 -- We know that the computed value (having type Count_Type) of Last
3285 -- is within the range of the generic actual index subtype, so it is
3286 -- safe to convert to Index_Type:
3288 Last := Index_Type'Base (Index);
3291 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3292 -- must test the length indirectly (by working backwards from the
3293 -- largest possible value of Last), in order to prevent overflow.
3295 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3297 if Index < Count_Type'Base (No_Index) then
3298 raise Constraint_Error with "Length is out of range";
3301 -- We have determined that the value of Length would not create a
3302 -- Last index value outside of the range of Index_Type, so we can now
3303 -- safely compute its value.
3305 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3308 Elements := new Elements_Type (Last);
3310 return Vector'(Controlled with Elements, Last, 0, 0);
3314 (New_Item : Element_Type;
3315 Length : Count_Type) return Vector
3317 Index : Count_Type'Base;
3318 Last : Index_Type'Base;
3319 Elements : Elements_Access;
3323 return Empty_Vector;
3326 -- We create a vector object with a capacity that matches the specified
3327 -- Length, but we do not allow the vector capacity (the length of the
3328 -- internal array) to exceed the number of values in Index_Type'Range
3329 -- (otherwise, there would be no way to refer to those components via an
3330 -- index). We must therefore check whether the specified Length would
3331 -- create a Last index value greater than Index_Type'Last.
3333 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3335 -- We perform a two-part test. First we determine whether the
3336 -- computed Last value lies in the base range of the type, and then
3337 -- determine whether it lies in the range of the index (sub)type.
3339 -- Last must satisfy this relation:
3340 -- First + Length - 1 <= Last
3341 -- We regroup terms:
3342 -- First - 1 <= Last - Length
3343 -- Which can rewrite as:
3344 -- No_Index <= Last - Length
3346 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3347 raise Constraint_Error with "Length is out of range";
3350 -- We now know that the computed value of Last is within the base
3351 -- range of the type, so it is safe to compute its value:
3353 Last := No_Index + Index_Type'Base (Length);
3355 -- Finally we test whether the value is within the range of the
3356 -- generic actual index subtype:
3358 if Last > Index_Type'Last then
3359 raise Constraint_Error with "Length is out of range";
3362 elsif Index_Type'First <= 0 then
3363 -- Here we can compute Last directly, in the normal way. We know that
3364 -- No_Index is less than 0, so there is no danger of overflow when
3365 -- adding the (positive) value of Length.
3367 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
3369 if Index > Count_Type'Base (Index_Type'Last) then
3370 raise Constraint_Error with "Length is out of range";
3373 -- We know that the computed value (having type Count_Type) of Last
3374 -- is within the range of the generic actual index subtype, so it is
3375 -- safe to convert to Index_Type:
3377 Last := Index_Type'Base (Index);
3380 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3381 -- must test the length indirectly (by working backwards from the
3382 -- largest possible value of Last), in order to prevent overflow.
3384 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3386 if Index < Count_Type'Base (No_Index) then
3387 raise Constraint_Error with "Length is out of range";
3390 -- We have determined that the value of Length would not create a
3391 -- Last index value outside of the range of Index_Type, so we can now
3392 -- safely compute its value.
3394 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3397 Elements := new Elements_Type'(Last, EA => (others => New_Item));
3399 return Vector'(Controlled with Elements, Last, 0, 0);
3402 --------------------
3403 -- Update_Element --
3404 --------------------
3406 procedure Update_Element
3407 (Container : in out Vector;
3409 Process : not null access procedure (Element : in out Element_Type))
3411 B : Natural renames Container.Busy;
3412 L : Natural renames Container.Lock;
3415 if Index > Container.Last then
3416 raise Constraint_Error with "Index is out of range";
3423 Process (Container.Elements.EA (Index));
3435 procedure Update_Element
3436 (Container : in out Vector;
3438 Process : not null access procedure (Element : in out Element_Type))
3441 if Position.Container = null then
3442 raise Constraint_Error with "Position cursor has no element";
3445 if Position.Container /= Container'Unrestricted_Access then
3446 raise Program_Error with "Position cursor denotes wrong container";
3449 Update_Element (Container, Position.Index, Process);
3457 (Stream : not null access Root_Stream_Type'Class;
3461 Count_Type'Base'Write (Stream, Length (Container));
3463 for J in Index_Type'First .. Container.Last loop
3464 Element_Type'Write (Stream, Container.Elements.EA (J));
3469 (Stream : not null access Root_Stream_Type'Class;
3473 raise Program_Error with "attempt to stream vector cursor";
3477 (Stream : not null access Root_Stream_Type'Class;
3478 Item : Reference_Type)
3481 raise Program_Error with "attempt to stream reference";
3485 (Stream : not null access Root_Stream_Type'Class;
3486 Item : Constant_Reference_Type)
3489 raise Program_Error with "attempt to stream reference";
3492 end Ada.Containers.Vectors;