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);
399 procedure Adjust (Control : in out Reference_Control_Type) is
401 if Control.Container /= null then
403 C : Vector renames Control.Container.all;
404 B : Natural renames C.Busy;
405 L : Natural renames C.Lock;
417 procedure Append (Container : in out Vector; New_Item : Vector) is
419 if Is_Empty (New_Item) then
423 if Container.Last = Index_Type'Last then
424 raise Constraint_Error with "vector is already at its maximum length";
434 (Container : in out Vector;
435 New_Item : Element_Type;
436 Count : Count_Type := 1)
443 if Container.Last = Index_Type'Last then
444 raise Constraint_Error with "vector is already at its maximum length";
458 procedure Assign (Target : in out Vector; Source : Vector) is
460 if Target'Address = Source'Address then
465 Target.Append (Source);
472 function Capacity (Container : Vector) return Count_Type is
474 if Container.Elements = null then
477 return Container.Elements.EA'Length;
485 procedure Clear (Container : in out Vector) is
487 if Container.Busy > 0 then
488 raise Program_Error with
489 "attempt to tamper with cursors (vector is busy)";
491 Container.Last := No_Index;
495 ------------------------
496 -- Constant_Reference --
497 ------------------------
499 function Constant_Reference
500 (Container : aliased Vector;
501 Position : Cursor) return Constant_Reference_Type
504 if Position.Container = null then
505 raise Constraint_Error with "Position cursor has no element";
508 if Position.Container /= Container'Unrestricted_Access then
509 raise Program_Error with "Position cursor denotes wrong container";
512 if Position.Index > Position.Container.Last then
513 raise Constraint_Error with "Position cursor is out of range";
517 C : Vector renames Position.Container.all;
518 B : Natural renames C.Busy;
519 L : Natural renames C.Lock;
521 return R : constant Constant_Reference_Type :=
523 Container.Elements.EA (Position.Index)'Access,
525 (Controlled with Container'Unrestricted_Access))
531 end Constant_Reference;
533 function Constant_Reference
534 (Container : aliased Vector;
535 Index : Index_Type) return Constant_Reference_Type
538 if Index > Container.Last then
539 raise Constraint_Error with "Index is out of range";
542 C : Vector renames Container'Unrestricted_Access.all;
543 B : Natural renames C.Busy;
544 L : Natural renames C.Lock;
546 return R : constant Constant_Reference_Type :=
547 (Element => Container.Elements.EA (Index)'Access,
549 (Controlled with Container'Unrestricted_Access))
556 end Constant_Reference;
564 Item : Element_Type) return Boolean
567 return Find_Index (Container, Item) /= No_Index;
576 Capacity : Count_Type := 0) return Vector
584 elsif Capacity >= Source.Length then
589 with "Requested capacity is less than Source length";
592 return Target : Vector do
593 Target.Reserve_Capacity (C);
594 Target.Assign (Source);
603 (Container : in out Vector;
604 Index : Extended_Index;
605 Count : Count_Type := 1)
607 Old_Last : constant Index_Type'Base := Container.Last;
608 New_Last : Index_Type'Base;
609 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
610 J : Index_Type'Base; -- first index of items that slide down
613 -- Delete removes items from the vector, the number of which is the
614 -- minimum of the specified Count and the items (if any) that exist from
615 -- Index to Container.Last. There are no constraints on the specified
616 -- value of Count (it can be larger than what's available at this
617 -- position in the vector, for example), but there are constraints on
618 -- the allowed values of the Index.
620 -- As a precondition on the generic actual Index_Type, the base type
621 -- must include Index_Type'Pred (Index_Type'First); this is the value
622 -- that Container.Last assumes when the vector is empty. However, we do
623 -- not allow that as the value for Index when specifying which items
624 -- should be deleted, so we must manually check. (That the user is
625 -- allowed to specify the value at all here is a consequence of the
626 -- declaration of the Extended_Index subtype, which includes the values
627 -- in the base range that immediately precede and immediately follow the
628 -- values in the Index_Type.)
630 if Index < Index_Type'First then
631 raise Constraint_Error with "Index is out of range (too small)";
634 -- We do allow a value greater than Container.Last to be specified as
635 -- the Index, but only if it's immediately greater. This allows the
636 -- corner case of deleting no items from the back end of the vector to
637 -- be treated as a no-op. (It is assumed that specifying an index value
638 -- greater than Last + 1 indicates some deeper flaw in the caller's
639 -- algorithm, so that case is treated as a proper error.)
641 if Index > Old_Last then
642 if Index > Old_Last + 1 then
643 raise Constraint_Error with "Index is out of range (too large)";
649 -- Here and elsewhere we treat deleting 0 items from the container as a
650 -- no-op, even when the container is busy, so we simply return.
656 -- The tampering bits exist to prevent an item from being deleted (or
657 -- otherwise harmfully manipulated) while it is being visited. Query,
658 -- Update, and Iterate increment the busy count on entry, and decrement
659 -- the count on exit. Delete checks the count to determine whether it is
660 -- being called while the associated callback procedure is executing.
662 if Container.Busy > 0 then
663 raise Program_Error with
664 "attempt to tamper with cursors (vector is busy)";
667 -- We first calculate what's available for deletion starting at
668 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
669 -- Count_Type'Base as the type for intermediate values. (See function
670 -- Length for more information.)
672 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
673 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
676 Count2 := Count_Type'Base (Old_Last - Index + 1);
679 -- If more elements are requested (Count) for deletion than are
680 -- available (Count2) for deletion beginning at Index, then everything
681 -- from Index is deleted. There are no elements to slide down, and so
682 -- all we need to do is set the value of Container.Last.
684 if Count >= Count2 then
685 Container.Last := Index - 1;
689 -- There are some elements aren't being deleted (the requested count was
690 -- less than the available count), so we must slide them down to
691 -- Index. We first calculate the index values of the respective array
692 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
693 -- type for intermediate calculations. For the elements that slide down,
694 -- index value New_Last is the last index value of their new home, and
695 -- index value J is the first index of their old home.
697 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
698 New_Last := Old_Last - Index_Type'Base (Count);
699 J := Index + Index_Type'Base (Count);
702 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
703 J := Index_Type'Base (Count_Type'Base (Index) + Count);
706 -- The internal elements array isn't guaranteed to exist unless we have
707 -- elements, but we have that guarantee here because we know we have
708 -- elements to slide. The array index values for each slice have
709 -- already been determined, so we just slide down to Index the elements
710 -- that weren't deleted.
713 EA : Elements_Array renames Container.Elements.EA;
716 EA (Index .. New_Last) := EA (J .. Old_Last);
717 Container.Last := New_Last;
722 (Container : in out Vector;
723 Position : in out Cursor;
724 Count : Count_Type := 1)
726 pragma Warnings (Off, Position);
729 if Position.Container = null then
730 raise Constraint_Error with "Position cursor has no element";
733 if Position.Container /= Container'Unrestricted_Access then
734 raise Program_Error with "Position cursor denotes wrong container";
737 if Position.Index > Container.Last then
738 raise Program_Error with "Position index is out of range";
741 Delete (Container, Position.Index, Count);
742 Position := No_Element;
749 procedure Delete_First
750 (Container : in out Vector;
751 Count : Count_Type := 1)
758 if Count >= Length (Container) then
763 Delete (Container, Index_Type'First, Count);
770 procedure Delete_Last
771 (Container : in out Vector;
772 Count : Count_Type := 1)
775 -- It is not permitted to delete items while the container is busy (for
776 -- example, we're in the middle of a passive iteration). However, we
777 -- always treat deleting 0 items as a no-op, even when we're busy, so we
778 -- simply return without checking.
784 -- The tampering bits exist to prevent an item from being deleted (or
785 -- otherwise harmfully manipulated) while it is being visited. Query,
786 -- Update, and Iterate increment the busy count on entry, and decrement
787 -- the count on exit. Delete_Last checks the count to determine whether
788 -- it is being called while the associated callback procedure is
791 if Container.Busy > 0 then
792 raise Program_Error with
793 "attempt to tamper with cursors (vector is busy)";
796 -- There is no restriction on how large Count can be when deleting
797 -- items. If it is equal or greater than the current length, then this
798 -- is equivalent to clearing the vector. (In particular, there's no need
799 -- for us to actually calculate the new value for Last.)
801 -- If the requested count is less than the current length, then we must
802 -- calculate the new value for Last. For the type we use the widest of
803 -- Index_Type'Base and Count_Type'Base for the intermediate values of
804 -- our calculation. (See the comments in Length for more information.)
806 if Count >= Container.Length then
807 Container.Last := No_Index;
809 elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
810 Container.Last := Container.Last - Index_Type'Base (Count);
814 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
824 Index : Index_Type) return Element_Type
827 if Index > Container.Last then
828 raise Constraint_Error with "Index is out of range";
831 return Container.Elements.EA (Index);
834 function Element (Position : Cursor) return Element_Type is
836 if Position.Container = null then
837 raise Constraint_Error with "Position cursor has no element";
838 elsif Position.Index > Position.Container.Last then
839 raise Constraint_Error with "Position cursor is out of range";
841 return Position.Container.Elements.EA (Position.Index);
849 procedure Finalize (Container : in out Vector) is
850 X : Elements_Access := Container.Elements;
853 if Container.Busy > 0 then
854 raise Program_Error with
855 "attempt to tamper with cursors (vector is busy)";
858 Container.Elements := null;
859 Container.Last := No_Index;
863 procedure Finalize (Object : in out Iterator) is
864 B : Natural renames Object.Container.Busy;
869 procedure Finalize (Control : in out Reference_Control_Type) is
871 if Control.Container /= null then
873 C : Vector renames Control.Container.all;
874 B : Natural renames C.Busy;
875 L : Natural renames C.Lock;
881 Control.Container := null;
892 Position : Cursor := No_Element) return Cursor
895 if Position.Container /= null then
896 if Position.Container /= Container'Unrestricted_Access then
897 raise Program_Error with "Position cursor denotes wrong container";
900 if Position.Index > Container.Last then
901 raise Program_Error with "Position index is out of range";
905 for J in Position.Index .. Container.Last loop
906 if Container.Elements.EA (J) = Item then
907 return (Container'Unrestricted_Access, J);
921 Index : Index_Type := Index_Type'First) return Extended_Index
924 for Indx in Index .. Container.Last loop
925 if Container.Elements.EA (Indx) = Item then
937 function First (Container : Vector) return Cursor is
939 if Is_Empty (Container) then
942 return (Container'Unrestricted_Access, Index_Type'First);
946 function First (Object : Iterator) return Cursor is
948 -- The value of the iterator object's Index component influences the
949 -- behavior of the First (and Last) selector function.
951 -- When the Index component is No_Index, this means the iterator
952 -- object was constructed without a start expression, in which case the
953 -- (forward) iteration starts from the (logical) beginning of the entire
954 -- sequence of items (corresponding to Container.First, for a forward
957 -- Otherwise, this is iteration over a partial sequence of items.
958 -- When the Index component isn't No_Index, the iterator object was
959 -- constructed with a start expression, that specifies the position
960 -- from which the (forward) partial iteration begins.
962 if Object.Index = No_Index then
963 return First (Object.Container.all);
965 return Cursor'(Object.Container, Object.Index);
973 function First_Element (Container : Vector) return Element_Type is
975 if Container.Last = No_Index then
976 raise Constraint_Error with "Container is empty";
978 return Container.Elements.EA (Index_Type'First);
986 function First_Index (Container : Vector) return Index_Type is
987 pragma Unreferenced (Container);
989 return Index_Type'First;
992 ---------------------
993 -- Generic_Sorting --
994 ---------------------
996 package body Generic_Sorting is
1002 function Is_Sorted (Container : Vector) return Boolean is
1004 if Container.Last <= Index_Type'First then
1009 EA : Elements_Array renames Container.Elements.EA;
1011 for J in Index_Type'First .. Container.Last - 1 loop
1012 if EA (J + 1) < EA (J) then
1025 procedure Merge (Target, Source : in out Vector) is
1026 I : Index_Type'Base := Target.Last;
1027 J : Index_Type'Base;
1030 -- The semantics of Merge changed slightly per AI05-0021. It was
1031 -- originally the case that if Target and Source denoted the same
1032 -- container object, then the GNAT implementation of Merge did
1033 -- nothing. However, it was argued that RM05 did not precisely
1034 -- specify the semantics for this corner case. The decision of the
1035 -- ARG was that if Target and Source denote the same non-empty
1036 -- container object, then Program_Error is raised.
1038 if Source.Last < Index_Type'First then -- Source is empty
1042 if Target'Address = Source'Address then
1043 raise Program_Error with
1044 "Target and Source denote same non-empty container";
1047 if Target.Last < Index_Type'First then -- Target is empty
1048 Move (Target => Target, Source => Source);
1052 if Source.Busy > 0 then
1053 raise Program_Error with
1054 "attempt to tamper with cursors (vector is busy)";
1057 Target.Set_Length (Length (Target) + Length (Source));
1060 TA : Elements_Array renames Target.Elements.EA;
1061 SA : Elements_Array renames Source.Elements.EA;
1065 while Source.Last >= Index_Type'First loop
1066 pragma Assert (Source.Last <= Index_Type'First
1067 or else not (SA (Source.Last) <
1068 SA (Source.Last - 1)));
1070 if I < Index_Type'First then
1071 TA (Index_Type'First .. J) :=
1072 SA (Index_Type'First .. Source.Last);
1074 Source.Last := No_Index;
1078 pragma Assert (I <= Index_Type'First
1079 or else not (TA (I) < TA (I - 1)));
1081 if SA (Source.Last) < TA (I) then
1086 TA (J) := SA (Source.Last);
1087 Source.Last := Source.Last - 1;
1099 procedure Sort (Container : in out Vector) is
1101 new Generic_Array_Sort
1102 (Index_Type => Index_Type,
1103 Element_Type => Element_Type,
1104 Array_Type => Elements_Array,
1108 if Container.Last <= Index_Type'First then
1112 -- The exception behavior for the vector container must match that
1113 -- for the list container, so we check for cursor tampering here
1114 -- (which will catch more things) instead of for element tampering
1115 -- (which will catch fewer things). It's true that the elements of
1116 -- this vector container could be safely moved around while (say) an
1117 -- iteration is taking place (iteration only increments the busy
1118 -- counter), and so technically all we would need here is a test for
1119 -- element tampering (indicated by the lock counter), that's simply
1120 -- an artifact of our array-based implementation. Logically Sort
1121 -- requires a check for cursor tampering.
1123 if Container.Busy > 0 then
1124 raise Program_Error with
1125 "attempt to tamper with cursors (vector is busy)";
1128 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1131 end Generic_Sorting;
1137 function Has_Element (Position : Cursor) return Boolean is
1139 return Position /= No_Element;
1147 (Container : in out Vector;
1148 Before : Extended_Index;
1149 New_Item : Element_Type;
1150 Count : Count_Type := 1)
1152 Old_Length : constant Count_Type := Container.Length;
1154 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1155 New_Length : Count_Type'Base; -- sum of current length and Count
1156 New_Last : Index_Type'Base; -- last index of vector after insertion
1158 Index : Index_Type'Base; -- scratch for intermediate values
1159 J : Count_Type'Base; -- scratch
1161 New_Capacity : Count_Type'Base; -- length of new, expanded array
1162 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1163 Dst : Elements_Access; -- new, expanded internal array
1166 -- As a precondition on the generic actual Index_Type, the base type
1167 -- must include Index_Type'Pred (Index_Type'First); this is the value
1168 -- that Container.Last assumes when the vector is empty. However, we do
1169 -- not allow that as the value for Index when specifying where the new
1170 -- items should be inserted, so we must manually check. (That the user
1171 -- is allowed to specify the value at all here is a consequence of the
1172 -- declaration of the Extended_Index subtype, which includes the values
1173 -- in the base range that immediately precede and immediately follow the
1174 -- values in the Index_Type.)
1176 if Before < Index_Type'First then
1177 raise Constraint_Error with
1178 "Before index is out of range (too small)";
1181 -- We do allow a value greater than Container.Last to be specified as
1182 -- the Index, but only if it's immediately greater. This allows for the
1183 -- case of appending items to the back end of the vector. (It is assumed
1184 -- that specifying an index value greater than Last + 1 indicates some
1185 -- deeper flaw in the caller's algorithm, so that case is treated as a
1188 if Before > Container.Last
1189 and then Before > Container.Last + 1
1191 raise Constraint_Error with
1192 "Before index is out of range (too large)";
1195 -- We treat inserting 0 items into the container as a no-op, even when
1196 -- the container is busy, so we simply return.
1202 -- There are two constraints we need to satisfy. The first constraint is
1203 -- that a container cannot have more than Count_Type'Last elements, so
1204 -- we must check the sum of the current length and the insertion count.
1205 -- Note: we cannot simply add these values, because of the possibility
1208 if Old_Length > Count_Type'Last - Count then
1209 raise Constraint_Error with "Count is out of range";
1212 -- It is now safe compute the length of the new vector, without fear of
1215 New_Length := Old_Length + Count;
1217 -- The second constraint is that the new Last index value cannot exceed
1218 -- Index_Type'Last. In each branch below, we calculate the maximum
1219 -- length (computed from the range of values in Index_Type), and then
1220 -- compare the new length to the maximum length. If the new length is
1221 -- acceptable, then we compute the new last index from that.
1223 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1225 -- We have to handle the case when there might be more values in the
1226 -- range of Index_Type than in the range of Count_Type.
1228 if Index_Type'First <= 0 then
1230 -- We know that No_Index (the same as Index_Type'First - 1) is
1231 -- less than 0, so it is safe to compute the following sum without
1232 -- fear of overflow.
1234 Index := No_Index + Index_Type'Base (Count_Type'Last);
1236 if Index <= Index_Type'Last then
1238 -- We have determined that range of Index_Type has at least as
1239 -- many values as in Count_Type, so Count_Type'Last is the
1240 -- maximum number of items that are allowed.
1242 Max_Length := Count_Type'Last;
1245 -- The range of Index_Type has fewer values than in Count_Type,
1246 -- so the maximum number of items is computed from the range of
1249 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1253 -- No_Index is equal or greater than 0, so we can safely compute
1254 -- the difference without fear of overflow (which we would have to
1255 -- worry about if No_Index were less than 0, but that case is
1258 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1261 elsif Index_Type'First <= 0 then
1263 -- We know that No_Index (the same as Index_Type'First - 1) is less
1264 -- than 0, so it is safe to compute the following sum without fear of
1267 J := Count_Type'Base (No_Index) + Count_Type'Last;
1269 if J <= Count_Type'Base (Index_Type'Last) then
1271 -- We have determined that range of Index_Type has at least as
1272 -- many values as in Count_Type, so Count_Type'Last is the maximum
1273 -- number of items that are allowed.
1275 Max_Length := Count_Type'Last;
1278 -- The range of Index_Type has fewer values than Count_Type does,
1279 -- so the maximum number of items is computed from the range of
1283 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1287 -- No_Index is equal or greater than 0, so we can safely compute the
1288 -- difference without fear of overflow (which we would have to worry
1289 -- about if No_Index were less than 0, but that case is handled
1293 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1296 -- We have just computed the maximum length (number of items). We must
1297 -- now compare the requested length to the maximum length, as we do not
1298 -- allow a vector expand beyond the maximum (because that would create
1299 -- an internal array with a last index value greater than
1300 -- Index_Type'Last, with no way to index those elements).
1302 if New_Length > Max_Length then
1303 raise Constraint_Error with "Count is out of range";
1306 -- New_Last is the last index value of the items in the container after
1307 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1308 -- compute its value from the New_Length.
1310 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1311 New_Last := No_Index + Index_Type'Base (New_Length);
1313 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1316 if Container.Elements = null then
1317 pragma Assert (Container.Last = No_Index);
1319 -- This is the simplest case, with which we must always begin: we're
1320 -- inserting items into an empty vector that hasn't allocated an
1321 -- internal array yet. Note that we don't need to check the busy bit
1322 -- here, because an empty container cannot be busy.
1324 -- In order to preserve container invariants, we allocate the new
1325 -- internal array first, before setting the Last index value, in case
1326 -- the allocation fails (which can happen either because there is no
1327 -- storage available, or because element initialization fails).
1329 Container.Elements := new Elements_Type'
1331 EA => (others => New_Item));
1333 -- The allocation of the new, internal array succeeded, so it is now
1334 -- safe to update the Last index, restoring container invariants.
1336 Container.Last := New_Last;
1341 -- The tampering bits exist to prevent an item from being harmfully
1342 -- manipulated while it is being visited. Query, Update, and Iterate
1343 -- increment the busy count on entry, and decrement the count on
1344 -- exit. Insert checks the count to determine whether it is being called
1345 -- while the associated callback procedure is executing.
1347 if Container.Busy > 0 then
1348 raise Program_Error with
1349 "attempt to tamper with cursors (vector is busy)";
1352 -- An internal array has already been allocated, so we must determine
1353 -- whether there is enough unused storage for the new items.
1355 if New_Length <= Container.Elements.EA'Length then
1357 -- In this case, we're inserting elements into a vector that has
1358 -- already allocated an internal array, and the existing array has
1359 -- enough unused storage for the new items.
1362 EA : Elements_Array renames Container.Elements.EA;
1365 if Before > Container.Last then
1367 -- The new items are being appended to the vector, so no
1368 -- sliding of existing elements is required.
1370 EA (Before .. New_Last) := (others => New_Item);
1373 -- The new items are being inserted before some existing
1374 -- elements, so we must slide the existing elements up to their
1375 -- new home. We use the wider of Index_Type'Base and
1376 -- Count_Type'Base as the type for intermediate index values.
1378 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1379 Index := Before + Index_Type'Base (Count);
1382 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1385 EA (Index .. New_Last) := EA (Before .. Container.Last);
1386 EA (Before .. Index - 1) := (others => New_Item);
1390 Container.Last := New_Last;
1394 -- In this case, we're inserting elements into a vector that has already
1395 -- allocated an internal array, but the existing array does not have
1396 -- enough storage, so we must allocate a new, longer array. In order to
1397 -- guarantee that the amortized insertion cost is O(1), we always
1398 -- allocate an array whose length is some power-of-two factor of the
1399 -- current array length. (The new array cannot have a length less than
1400 -- the New_Length of the container, but its last index value cannot be
1401 -- greater than Index_Type'Last.)
1403 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1404 while New_Capacity < New_Length loop
1405 if New_Capacity > Count_Type'Last / 2 then
1406 New_Capacity := Count_Type'Last;
1410 New_Capacity := 2 * New_Capacity;
1413 if New_Capacity > Max_Length then
1415 -- We have reached the limit of capacity, so no further expansion
1416 -- will occur. (This is not a problem, as there is never a need to
1417 -- have more capacity than the maximum container length.)
1419 New_Capacity := Max_Length;
1422 -- We have computed the length of the new internal array (and this is
1423 -- what "vector capacity" means), so use that to compute its last index.
1425 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1426 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1430 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1433 -- Now we allocate the new, longer internal array. If the allocation
1434 -- fails, we have not changed any container state, so no side-effect
1435 -- will occur as a result of propagating the exception.
1437 Dst := new Elements_Type (Dst_Last);
1439 -- We have our new internal array. All that needs to be done now is to
1440 -- copy the existing items (if any) from the old array (the "source"
1441 -- array, object SA below) to the new array (the "destination" array,
1442 -- object DA below), and then deallocate the old array.
1445 SA : Elements_Array renames Container.Elements.EA; -- source
1446 DA : Elements_Array renames Dst.EA; -- destination
1449 DA (Index_Type'First .. Before - 1) :=
1450 SA (Index_Type'First .. Before - 1);
1452 if Before > Container.Last then
1453 DA (Before .. New_Last) := (others => New_Item);
1456 -- The new items are being inserted before some existing elements,
1457 -- so we must slide the existing elements up to their new home.
1459 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1460 Index := Before + Index_Type'Base (Count);
1463 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1466 DA (Before .. Index - 1) := (others => New_Item);
1467 DA (Index .. New_Last) := SA (Before .. Container.Last);
1476 -- We have successfully copied the items onto the new array, so the
1477 -- final thing to do is deallocate the old array.
1480 X : Elements_Access := Container.Elements;
1482 -- We first isolate the old internal array, removing it from the
1483 -- container and replacing it with the new internal array, before we
1484 -- deallocate the old array (which can fail if finalization of
1485 -- elements propagates an exception).
1487 Container.Elements := Dst;
1488 Container.Last := New_Last;
1490 -- The container invariants have been restored, so it is now safe to
1491 -- attempt to deallocate the old array.
1498 (Container : in out Vector;
1499 Before : Extended_Index;
1502 N : constant Count_Type := Length (New_Item);
1503 J : Index_Type'Base;
1506 -- Use Insert_Space to create the "hole" (the destination slice) into
1507 -- which we copy the source items.
1509 Insert_Space (Container, Before, Count => N);
1513 -- There's nothing else to do here (vetting of parameters was
1514 -- performed already in Insert_Space), so we simply return.
1519 -- We calculate the last index value of the destination slice using the
1520 -- wider of Index_Type'Base and count_Type'Base.
1522 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1523 J := (Before - 1) + Index_Type'Base (N);
1526 J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
1529 if Container'Address /= New_Item'Address then
1531 -- This is the simple case. New_Item denotes an object different
1532 -- from Container, so there's nothing special we need to do to copy
1533 -- the source items to their destination, because all of the source
1534 -- items are contiguous.
1536 Container.Elements.EA (Before .. J) :=
1537 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
1542 -- New_Item denotes the same object as Container, so an insertion has
1543 -- potentially split the source items. The destination is always the
1544 -- range [Before, J], but the source is [Index_Type'First, Before) and
1545 -- (J, Container.Last]. We perform the copy in two steps, using each of
1546 -- the two slices of the source items.
1549 L : constant Index_Type'Base := Before - 1;
1551 subtype Src_Index_Subtype is Index_Type'Base range
1552 Index_Type'First .. L;
1554 Src : Elements_Array renames
1555 Container.Elements.EA (Src_Index_Subtype);
1557 K : Index_Type'Base;
1560 -- We first copy the source items that precede the space we
1561 -- inserted. Index value K is the last index of that portion
1562 -- destination that receives this slice of the source. (If Before
1563 -- equals Index_Type'First, then this first source slice will be
1564 -- empty, which is harmless.)
1566 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1567 K := L + Index_Type'Base (Src'Length);
1570 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1573 Container.Elements.EA (Before .. K) := Src;
1575 if Src'Length = N then
1577 -- The new items were effectively appended to the container, so we
1578 -- have already copied all of the items that need to be copied.
1579 -- We return early here, even though the source slice below is
1580 -- empty (so the assignment would be harmless), because we want to
1581 -- avoid computing J + 1, which will overflow if J equals
1582 -- Index_Type'Base'Last.
1589 -- Note that we want to avoid computing J + 1 here, in case J equals
1590 -- Index_Type'Base'Last. We prevent that by returning early above,
1591 -- immediately after copying the first slice of the source, and
1592 -- determining that this second slice of the source is empty.
1594 F : constant Index_Type'Base := J + 1;
1596 subtype Src_Index_Subtype is Index_Type'Base range
1597 F .. Container.Last;
1599 Src : Elements_Array renames
1600 Container.Elements.EA (Src_Index_Subtype);
1602 K : Index_Type'Base;
1605 -- We next copy the source items that follow the space we inserted.
1606 -- Index value K is the first index of that portion of the
1607 -- destination that receives this slice of the source. (For the
1608 -- reasons given above, this slice is guaranteed to be non-empty.)
1610 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1611 K := F - Index_Type'Base (Src'Length);
1614 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1617 Container.Elements.EA (K .. J) := Src;
1622 (Container : in out Vector;
1626 Index : Index_Type'Base;
1629 if Before.Container /= null
1630 and then Before.Container /= Container'Unrestricted_Access
1632 raise Program_Error with "Before cursor denotes wrong container";
1635 if Is_Empty (New_Item) then
1639 if Before.Container = null
1640 or else Before.Index > Container.Last
1642 if Container.Last = Index_Type'Last then
1643 raise Constraint_Error with
1644 "vector is already at its maximum length";
1647 Index := Container.Last + 1;
1650 Index := Before.Index;
1653 Insert (Container, Index, New_Item);
1657 (Container : in out Vector;
1660 Position : out Cursor)
1662 Index : Index_Type'Base;
1665 if Before.Container /= null
1666 and then Before.Container /= Container'Unrestricted_Access
1668 raise Program_Error with "Before cursor denotes wrong container";
1671 if Is_Empty (New_Item) then
1672 if Before.Container = null
1673 or else Before.Index > Container.Last
1675 Position := No_Element;
1677 Position := (Container'Unrestricted_Access, Before.Index);
1683 if Before.Container = null
1684 or else Before.Index > Container.Last
1686 if Container.Last = Index_Type'Last then
1687 raise Constraint_Error with
1688 "vector is already at its maximum length";
1691 Index := Container.Last + 1;
1694 Index := Before.Index;
1697 Insert (Container, Index, New_Item);
1699 Position := (Container'Unrestricted_Access, Index);
1703 (Container : in out Vector;
1705 New_Item : Element_Type;
1706 Count : Count_Type := 1)
1708 Index : Index_Type'Base;
1711 if Before.Container /= null
1712 and then Before.Container /= Container'Unrestricted_Access
1714 raise Program_Error with "Before cursor denotes wrong container";
1721 if Before.Container = null
1722 or else Before.Index > Container.Last
1724 if Container.Last = Index_Type'Last then
1725 raise Constraint_Error with
1726 "vector is already at its maximum length";
1728 Index := Container.Last + 1;
1732 Index := Before.Index;
1735 Insert (Container, Index, New_Item, Count);
1739 (Container : in out Vector;
1741 New_Item : Element_Type;
1742 Position : out Cursor;
1743 Count : Count_Type := 1)
1745 Index : Index_Type'Base;
1748 if Before.Container /= null
1749 and then Before.Container /= Container'Unrestricted_Access
1751 raise Program_Error with "Before cursor denotes wrong container";
1755 if Before.Container = null
1756 or else Before.Index > Container.Last
1758 Position := No_Element;
1760 Position := (Container'Unrestricted_Access, Before.Index);
1766 if Before.Container = null
1767 or else Before.Index > Container.Last
1769 if Container.Last = Index_Type'Last then
1770 raise Constraint_Error with
1771 "vector is already at its maximum length";
1774 Index := Container.Last + 1;
1777 Index := Before.Index;
1780 Insert (Container, Index, New_Item, Count);
1782 Position := (Container'Unrestricted_Access, Index);
1786 (Container : in out Vector;
1787 Before : Extended_Index;
1788 Count : Count_Type := 1)
1790 New_Item : Element_Type; -- Default-initialized value
1791 pragma Warnings (Off, New_Item);
1794 Insert (Container, Before, New_Item, Count);
1798 (Container : in out Vector;
1800 Position : out Cursor;
1801 Count : Count_Type := 1)
1803 New_Item : Element_Type; -- Default-initialized value
1804 pragma Warnings (Off, New_Item);
1807 Insert (Container, Before, New_Item, Position, Count);
1814 procedure Insert_Space
1815 (Container : in out Vector;
1816 Before : Extended_Index;
1817 Count : Count_Type := 1)
1819 Old_Length : constant Count_Type := Container.Length;
1821 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1822 New_Length : Count_Type'Base; -- sum of current length and Count
1823 New_Last : Index_Type'Base; -- last index of vector after insertion
1825 Index : Index_Type'Base; -- scratch for intermediate values
1826 J : Count_Type'Base; -- scratch
1828 New_Capacity : Count_Type'Base; -- length of new, expanded array
1829 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1830 Dst : Elements_Access; -- new, expanded internal array
1833 -- As a precondition on the generic actual Index_Type, the base type
1834 -- must include Index_Type'Pred (Index_Type'First); this is the value
1835 -- that Container.Last assumes when the vector is empty. However, we do
1836 -- not allow that as the value for Index when specifying where the new
1837 -- items should be inserted, so we must manually check. (That the user
1838 -- is allowed to specify the value at all here is a consequence of the
1839 -- declaration of the Extended_Index subtype, which includes the values
1840 -- in the base range that immediately precede and immediately follow the
1841 -- values in the Index_Type.)
1843 if Before < Index_Type'First then
1844 raise Constraint_Error with
1845 "Before index is out of range (too small)";
1848 -- We do allow a value greater than Container.Last to be specified as
1849 -- the Index, but only if it's immediately greater. This allows for the
1850 -- case of appending items to the back end of the vector. (It is assumed
1851 -- that specifying an index value greater than Last + 1 indicates some
1852 -- deeper flaw in the caller's algorithm, so that case is treated as a
1855 if Before > Container.Last
1856 and then Before > Container.Last + 1
1858 raise Constraint_Error with
1859 "Before index is out of range (too large)";
1862 -- We treat inserting 0 items into the container as a no-op, even when
1863 -- the container is busy, so we simply return.
1869 -- There are two constraints we need to satisfy. The first constraint is
1870 -- that a container cannot have more than Count_Type'Last elements, so
1871 -- we must check the sum of the current length and the insertion count.
1872 -- Note: we cannot simply add these values, because of the possibility
1875 if Old_Length > Count_Type'Last - Count then
1876 raise Constraint_Error with "Count is out of range";
1879 -- It is now safe compute the length of the new vector, without fear of
1882 New_Length := Old_Length + Count;
1884 -- The second constraint is that the new Last index value cannot exceed
1885 -- Index_Type'Last. In each branch below, we calculate the maximum
1886 -- length (computed from the range of values in Index_Type), and then
1887 -- compare the new length to the maximum length. If the new length is
1888 -- acceptable, then we compute the new last index from that.
1890 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1892 -- We have to handle the case when there might be more values in the
1893 -- range of Index_Type than in the range of Count_Type.
1895 if Index_Type'First <= 0 then
1897 -- We know that No_Index (the same as Index_Type'First - 1) is
1898 -- less than 0, so it is safe to compute the following sum without
1899 -- fear of overflow.
1901 Index := No_Index + Index_Type'Base (Count_Type'Last);
1903 if Index <= Index_Type'Last then
1905 -- We have determined that range of Index_Type has at least as
1906 -- many values as in Count_Type, so Count_Type'Last is the
1907 -- maximum number of items that are allowed.
1909 Max_Length := Count_Type'Last;
1912 -- The range of Index_Type has fewer values than in Count_Type,
1913 -- so the maximum number of items is computed from the range of
1916 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1920 -- No_Index is equal or greater than 0, so we can safely compute
1921 -- the difference without fear of overflow (which we would have to
1922 -- worry about if No_Index were less than 0, but that case is
1925 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1928 elsif Index_Type'First <= 0 then
1930 -- We know that No_Index (the same as Index_Type'First - 1) is less
1931 -- than 0, so it is safe to compute the following sum without fear of
1934 J := Count_Type'Base (No_Index) + Count_Type'Last;
1936 if J <= Count_Type'Base (Index_Type'Last) then
1938 -- We have determined that range of Index_Type has at least as
1939 -- many values as in Count_Type, so Count_Type'Last is the maximum
1940 -- number of items that are allowed.
1942 Max_Length := Count_Type'Last;
1945 -- The range of Index_Type has fewer values than Count_Type does,
1946 -- so the maximum number of items is computed from the range of
1950 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1954 -- No_Index is equal or greater than 0, so we can safely compute the
1955 -- difference without fear of overflow (which we would have to worry
1956 -- about if No_Index were less than 0, but that case is handled
1960 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1963 -- We have just computed the maximum length (number of items). We must
1964 -- now compare the requested length to the maximum length, as we do not
1965 -- allow a vector expand beyond the maximum (because that would create
1966 -- an internal array with a last index value greater than
1967 -- Index_Type'Last, with no way to index those elements).
1969 if New_Length > Max_Length then
1970 raise Constraint_Error with "Count is out of range";
1973 -- New_Last is the last index value of the items in the container after
1974 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1975 -- compute its value from the New_Length.
1977 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1978 New_Last := No_Index + Index_Type'Base (New_Length);
1981 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1984 if Container.Elements = null then
1985 pragma Assert (Container.Last = No_Index);
1987 -- This is the simplest case, with which we must always begin: we're
1988 -- inserting items into an empty vector that hasn't allocated an
1989 -- internal array yet. Note that we don't need to check the busy bit
1990 -- here, because an empty container cannot be busy.
1992 -- In order to preserve container invariants, we allocate the new
1993 -- internal array first, before setting the Last index value, in case
1994 -- the allocation fails (which can happen either because there is no
1995 -- storage available, or because default-valued element
1996 -- initialization fails).
1998 Container.Elements := new Elements_Type (New_Last);
2000 -- The allocation of the new, internal array succeeded, so it is now
2001 -- safe to update the Last index, restoring container invariants.
2003 Container.Last := New_Last;
2008 -- The tampering bits exist to prevent an item from being harmfully
2009 -- manipulated while it is being visited. Query, Update, and Iterate
2010 -- increment the busy count on entry, and decrement the count on
2011 -- exit. Insert checks the count to determine whether it is being called
2012 -- while the associated callback procedure is executing.
2014 if Container.Busy > 0 then
2015 raise Program_Error with
2016 "attempt to tamper with cursors (vector is busy)";
2019 -- An internal array has already been allocated, so we must determine
2020 -- whether there is enough unused storage for the new items.
2022 if New_Last <= Container.Elements.Last then
2024 -- In this case, we're inserting space into a vector that has already
2025 -- allocated an internal array, and the existing array has enough
2026 -- unused storage for the new items.
2029 EA : Elements_Array renames Container.Elements.EA;
2032 if Before <= Container.Last then
2034 -- The space is being inserted before some existing elements,
2035 -- so we must slide the existing elements up to their new
2036 -- home. We use the wider of Index_Type'Base and
2037 -- Count_Type'Base as the type for intermediate index values.
2039 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2040 Index := Before + Index_Type'Base (Count);
2043 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2046 EA (Index .. New_Last) := EA (Before .. Container.Last);
2050 Container.Last := New_Last;
2054 -- In this case, we're inserting space into a vector that has already
2055 -- allocated an internal array, but the existing array does not have
2056 -- enough storage, so we must allocate a new, longer array. In order to
2057 -- guarantee that the amortized insertion cost is O(1), we always
2058 -- allocate an array whose length is some power-of-two factor of the
2059 -- current array length. (The new array cannot have a length less than
2060 -- the New_Length of the container, but its last index value cannot be
2061 -- greater than Index_Type'Last.)
2063 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2064 while New_Capacity < New_Length loop
2065 if New_Capacity > Count_Type'Last / 2 then
2066 New_Capacity := Count_Type'Last;
2070 New_Capacity := 2 * New_Capacity;
2073 if New_Capacity > Max_Length then
2075 -- We have reached the limit of capacity, so no further expansion
2076 -- will occur. (This is not a problem, as there is never a need to
2077 -- have more capacity than the maximum container length.)
2079 New_Capacity := Max_Length;
2082 -- We have computed the length of the new internal array (and this is
2083 -- what "vector capacity" means), so use that to compute its last index.
2085 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2086 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2090 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2093 -- Now we allocate the new, longer internal array. If the allocation
2094 -- fails, we have not changed any container state, so no side-effect
2095 -- will occur as a result of propagating the exception.
2097 Dst := new Elements_Type (Dst_Last);
2099 -- We have our new internal array. All that needs to be done now is to
2100 -- copy the existing items (if any) from the old array (the "source"
2101 -- array, object SA below) to the new array (the "destination" array,
2102 -- object DA below), and then deallocate the old array.
2105 SA : Elements_Array renames Container.Elements.EA; -- source
2106 DA : Elements_Array renames Dst.EA; -- destination
2109 DA (Index_Type'First .. Before - 1) :=
2110 SA (Index_Type'First .. Before - 1);
2112 if Before <= Container.Last then
2114 -- The space is being inserted before some existing elements, so
2115 -- we must slide the existing elements up to their new home.
2117 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2118 Index := Before + Index_Type'Base (Count);
2121 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2124 DA (Index .. New_Last) := SA (Before .. Container.Last);
2133 -- We have successfully copied the items onto the new array, so the
2134 -- final thing to do is restore invariants, and deallocate the old
2138 X : Elements_Access := Container.Elements;
2141 -- We first isolate the old internal array, removing it from the
2142 -- container and replacing it with the new internal array, before we
2143 -- deallocate the old array (which can fail if finalization of
2144 -- elements propagates an exception).
2146 Container.Elements := Dst;
2147 Container.Last := New_Last;
2149 -- The container invariants have been restored, so it is now safe to
2150 -- attempt to deallocate the old array.
2156 procedure Insert_Space
2157 (Container : in out Vector;
2159 Position : out Cursor;
2160 Count : Count_Type := 1)
2162 Index : Index_Type'Base;
2165 if Before.Container /= null
2166 and then Before.Container /= Container'Unrestricted_Access
2168 raise Program_Error with "Before cursor denotes wrong container";
2172 if Before.Container = null
2173 or else Before.Index > Container.Last
2175 Position := No_Element;
2177 Position := (Container'Unrestricted_Access, Before.Index);
2183 if Before.Container = null
2184 or else Before.Index > Container.Last
2186 if Container.Last = Index_Type'Last then
2187 raise Constraint_Error with
2188 "vector is already at its maximum length";
2190 Index := Container.Last + 1;
2194 Index := Before.Index;
2197 Insert_Space (Container, Index, Count => Count);
2199 Position := (Container'Unrestricted_Access, Index);
2206 function Is_Empty (Container : Vector) return Boolean is
2208 return Container.Last < Index_Type'First;
2216 (Container : Vector;
2217 Process : not null access procedure (Position : Cursor))
2219 B : Natural renames Container'Unrestricted_Access.all.Busy;
2225 for Indx in Index_Type'First .. Container.Last loop
2226 Process (Cursor'(Container'Unrestricted_Access, Indx));
2238 (Container : Vector)
2239 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2241 V : constant Vector_Access := Container'Unrestricted_Access;
2242 B : Natural renames V.Busy;
2245 -- The value of its Index component influences the behavior of the First
2246 -- and Last selector functions of the iterator object. When the Index
2247 -- component is No_Index (as is the case here), this means the iterator
2248 -- object was constructed without a start expression. This is a complete
2249 -- iterator, meaning that the iteration starts from the (logical)
2250 -- beginning of the sequence of items.
2252 -- Note: For a forward iterator, Container.First is the beginning, and
2253 -- for a reverse iterator, Container.Last is the beginning.
2255 return It : constant Iterator :=
2256 (Limited_Controlled with
2265 (Container : Vector;
2267 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2269 V : constant Vector_Access := Container'Unrestricted_Access;
2270 B : Natural renames V.Busy;
2273 -- It was formerly the case that when Start = No_Element, the partial
2274 -- iterator was defined to behave the same as for a complete iterator,
2275 -- and iterate over the entire sequence of items. However, those
2276 -- semantics were unintuitive and arguably error-prone (it is too easy
2277 -- to accidentally create an endless loop), and so they were changed,
2278 -- per the ARG meeting in Denver on 2011/11. However, there was no
2279 -- consensus about what positive meaning this corner case should have,
2280 -- and so it was decided to simply raise an exception. This does imply,
2281 -- however, that it is not possible to use a partial iterator to specify
2282 -- an empty sequence of items.
2284 if Start.Container = null then
2285 raise Constraint_Error with
2286 "Start position for iterator equals No_Element";
2289 if Start.Container /= V then
2290 raise Program_Error with
2291 "Start cursor of Iterate designates wrong vector";
2294 if Start.Index > V.Last then
2295 raise Constraint_Error with
2296 "Start position for iterator equals No_Element";
2299 -- The value of its Index component influences the behavior of the First
2300 -- and Last selector functions of the iterator object. When the Index
2301 -- component is not No_Index (as is the case here), it means that this
2302 -- is a partial iteration, over a subset of the complete sequence of
2303 -- items. The iterator object was constructed with a start expression,
2304 -- indicating the position from which the iteration begins. Note that
2305 -- the start position has the same value irrespective of whether this
2306 -- is a forward or reverse iteration.
2308 return It : constant Iterator :=
2309 (Limited_Controlled with
2311 Index => Start.Index)
2321 function Last (Container : Vector) return Cursor is
2323 if Is_Empty (Container) then
2326 return (Container'Unrestricted_Access, Container.Last);
2330 function Last (Object : Iterator) return Cursor is
2332 -- The value of the iterator object's Index component influences the
2333 -- behavior of the Last (and First) selector function.
2335 -- When the Index component is No_Index, this means the iterator
2336 -- object was constructed without a start expression, in which case the
2337 -- (reverse) iteration starts from the (logical) beginning of the entire
2338 -- sequence (corresponding to Container.Last, for a reverse iterator).
2340 -- Otherwise, this is iteration over a partial sequence of items.
2341 -- When the Index component is not No_Index, the iterator object was
2342 -- constructed with a start expression, that specifies the position
2343 -- from which the (reverse) partial iteration begins.
2345 if Object.Index = No_Index then
2346 return Last (Object.Container.all);
2348 return Cursor'(Object.Container, Object.Index);
2356 function Last_Element (Container : Vector) return Element_Type is
2358 if Container.Last = No_Index then
2359 raise Constraint_Error with "Container is empty";
2361 return Container.Elements.EA (Container.Last);
2369 function Last_Index (Container : Vector) return Extended_Index is
2371 return Container.Last;
2378 function Length (Container : Vector) return Count_Type is
2379 L : constant Index_Type'Base := Container.Last;
2380 F : constant Index_Type := Index_Type'First;
2383 -- The base range of the index type (Index_Type'Base) might not include
2384 -- all values for length (Count_Type). Contrariwise, the index type
2385 -- might include values outside the range of length. Hence we use
2386 -- whatever type is wider for intermediate values when calculating
2387 -- length. Note that no matter what the index type is, the maximum
2388 -- length to which a vector is allowed to grow is always the minimum
2389 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2391 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2392 -- to have a base range of -128 .. 127, but the corresponding vector
2393 -- would have lengths in the range 0 .. 255. In this case we would need
2394 -- to use Count_Type'Base for intermediate values.
2396 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2397 -- vector would have a maximum length of 10, but the index values lie
2398 -- outside the range of Count_Type (which is only 32 bits). In this
2399 -- case we would need to use Index_Type'Base for intermediate values.
2401 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2402 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2404 return Count_Type (L - F + 1);
2413 (Target : in out Vector;
2414 Source : in out Vector)
2417 if Target'Address = Source'Address then
2421 if Target.Busy > 0 then
2422 raise Program_Error with
2423 "attempt to tamper with cursors (Target is busy)";
2426 if Source.Busy > 0 then
2427 raise Program_Error with
2428 "attempt to tamper with cursors (Source is busy)";
2432 Target_Elements : constant Elements_Access := Target.Elements;
2434 Target.Elements := Source.Elements;
2435 Source.Elements := Target_Elements;
2438 Target.Last := Source.Last;
2439 Source.Last := No_Index;
2446 function Next (Position : Cursor) return Cursor is
2448 if Position.Container = null then
2450 elsif Position.Index < Position.Container.Last then
2451 return (Position.Container, Position.Index + 1);
2457 function Next (Object : Iterator; Position : Cursor) return Cursor is
2459 if Position.Container = null then
2463 if Position.Container /= Object.Container then
2464 raise Program_Error with
2465 "Position cursor of Next designates wrong vector";
2468 return Next (Position);
2471 procedure Next (Position : in out Cursor) is
2473 if Position.Container = null then
2475 elsif Position.Index < Position.Container.Last then
2476 Position.Index := Position.Index + 1;
2478 Position := No_Element;
2486 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2488 Insert (Container, Index_Type'First, New_Item);
2492 (Container : in out Vector;
2493 New_Item : Element_Type;
2494 Count : Count_Type := 1)
2507 function Previous (Position : Cursor) return Cursor is
2509 if Position.Container = null then
2511 elsif Position.Index > Index_Type'First then
2512 return (Position.Container, Position.Index - 1);
2518 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2520 if Position.Container = null then
2524 if Position.Container /= Object.Container then
2525 raise Program_Error with
2526 "Position cursor of Previous designates wrong vector";
2529 return Previous (Position);
2532 procedure Previous (Position : in out Cursor) is
2534 if Position.Container = null then
2536 elsif Position.Index > Index_Type'First then
2537 Position.Index := Position.Index - 1;
2539 Position := No_Element;
2547 procedure Query_Element
2548 (Container : Vector;
2550 Process : not null access procedure (Element : Element_Type))
2552 V : Vector renames Container'Unrestricted_Access.all;
2553 B : Natural renames V.Busy;
2554 L : Natural renames V.Lock;
2557 if Index > Container.Last then
2558 raise Constraint_Error with "Index is out of range";
2565 Process (V.Elements.EA (Index));
2577 procedure Query_Element
2579 Process : not null access procedure (Element : Element_Type))
2582 if Position.Container = null then
2583 raise Constraint_Error with "Position cursor has no element";
2586 Query_Element (Position.Container.all, Position.Index, Process);
2594 (Stream : not null access Root_Stream_Type'Class;
2595 Container : out Vector)
2597 Length : Count_Type'Base;
2598 Last : Index_Type'Base := No_Index;
2603 Count_Type'Base'Read (Stream, Length);
2605 if Length > Capacity (Container) then
2606 Reserve_Capacity (Container, Capacity => Length);
2609 for J in Count_Type range 1 .. Length loop
2611 Element_Type'Read (Stream, Container.Elements.EA (Last));
2612 Container.Last := Last;
2617 (Stream : not null access Root_Stream_Type'Class;
2618 Position : out Cursor)
2621 raise Program_Error with "attempt to stream vector cursor";
2625 (Stream : not null access Root_Stream_Type'Class;
2626 Item : out Reference_Type)
2629 raise Program_Error with "attempt to stream reference";
2633 (Stream : not null access Root_Stream_Type'Class;
2634 Item : out Constant_Reference_Type)
2637 raise Program_Error with "attempt to stream reference";
2645 (Container : aliased in out Vector;
2646 Position : Cursor) return Reference_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 > Position.Container.Last then
2658 raise Constraint_Error with "Position cursor is out of range";
2662 C : Vector renames Position.Container.all;
2663 B : Natural renames C.Busy;
2664 L : Natural renames C.Lock;
2666 return R : constant Reference_Type :=
2668 Container.Elements.EA (Position.Index)'Access,
2669 Control => (Controlled with Position.Container))
2678 (Container : aliased in out Vector;
2679 Index : Index_Type) return Reference_Type
2682 if Index > Container.Last then
2683 raise Constraint_Error with "Index is out of range";
2686 C : Vector renames Container'Unrestricted_Access.all;
2687 B : Natural renames C.Busy;
2688 L : Natural renames C.Lock;
2690 return R : constant Reference_Type :=
2691 (Element => Container.Elements.EA (Index)'Access,
2693 (Controlled with Container'Unrestricted_Access))
2702 ---------------------
2703 -- Replace_Element --
2704 ---------------------
2706 procedure Replace_Element
2707 (Container : in out Vector;
2709 New_Item : Element_Type)
2712 if Index > Container.Last then
2713 raise Constraint_Error with "Index is out of range";
2716 if Container.Lock > 0 then
2717 raise Program_Error with
2718 "attempt to tamper with elements (vector is locked)";
2721 Container.Elements.EA (Index) := New_Item;
2722 end Replace_Element;
2724 procedure Replace_Element
2725 (Container : in out Vector;
2727 New_Item : Element_Type)
2730 if Position.Container = null then
2731 raise Constraint_Error with "Position cursor has no element";
2734 if Position.Container /= Container'Unrestricted_Access then
2735 raise Program_Error with "Position cursor denotes wrong container";
2738 if Position.Index > Container.Last then
2739 raise Constraint_Error with "Position cursor is out of range";
2742 if Container.Lock > 0 then
2743 raise Program_Error with
2744 "attempt to tamper with elements (vector is locked)";
2747 Container.Elements.EA (Position.Index) := New_Item;
2748 end Replace_Element;
2750 ----------------------
2751 -- Reserve_Capacity --
2752 ----------------------
2754 procedure Reserve_Capacity
2755 (Container : in out Vector;
2756 Capacity : Count_Type)
2758 N : constant Count_Type := Length (Container);
2760 Index : Count_Type'Base;
2761 Last : Index_Type'Base;
2764 -- Reserve_Capacity can be used to either expand the storage available
2765 -- for elements (this would be its typical use, in anticipation of
2766 -- future insertion), or to trim back storage. In the latter case,
2767 -- storage can only be trimmed back to the limit of the container
2768 -- length. Note that Reserve_Capacity neither deletes (active) elements
2769 -- nor inserts elements; it only affects container capacity, never
2770 -- container length.
2772 if Capacity = 0 then
2774 -- This is a request to trim back storage, to the minimum amount
2775 -- possible given the current state of the container.
2779 -- The container is empty, so in this unique case we can
2780 -- deallocate the entire internal array. Note that an empty
2781 -- container can never be busy, so there's no need to check the
2785 X : Elements_Access := Container.Elements;
2788 -- First we remove the internal array from the container, to
2789 -- handle the case when the deallocation raises an exception.
2791 Container.Elements := null;
2793 -- Container invariants have been restored, so it is now safe
2794 -- to attempt to deallocate the internal array.
2799 elsif N < Container.Elements.EA'Length then
2801 -- The container is not empty, and the current length is less than
2802 -- the current capacity, so there's storage available to trim. In
2803 -- this case, we allocate a new internal array having a length
2804 -- that exactly matches the number of items in the
2805 -- container. (Reserve_Capacity does not delete active elements,
2806 -- so this is the best we can do with respect to minimizing
2809 if Container.Busy > 0 then
2810 raise Program_Error with
2811 "attempt to tamper with cursors (vector is busy)";
2815 subtype Src_Index_Subtype is Index_Type'Base range
2816 Index_Type'First .. Container.Last;
2818 Src : Elements_Array renames
2819 Container.Elements.EA (Src_Index_Subtype);
2821 X : Elements_Access := Container.Elements;
2824 -- Although we have isolated the old internal array that we're
2825 -- going to deallocate, we don't deallocate it until we have
2826 -- successfully allocated a new one. If there is an exception
2827 -- during allocation (either because there is not enough
2828 -- storage, or because initialization of the elements fails),
2829 -- we let it propagate without causing any side-effect.
2831 Container.Elements := new Elements_Type'(Container.Last, Src);
2833 -- We have successfully allocated a new internal array (with a
2834 -- smaller length than the old one, and containing a copy of
2835 -- just the active elements in the container), so it is now
2836 -- safe to attempt to deallocate the old array. The old array
2837 -- has been isolated, and container invariants have been
2838 -- restored, so if the deallocation fails (because finalization
2839 -- of the elements fails), we simply let it propagate.
2848 -- Reserve_Capacity can be used to expand the storage available for
2849 -- elements, but we do not let the capacity grow beyond the number of
2850 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2851 -- to refer to the elements with an index value greater than
2852 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2853 -- the Last index value of the new internal array, in a way that avoids
2854 -- any possibility of overflow.
2856 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2858 -- We perform a two-part test. First we determine whether the
2859 -- computed Last value lies in the base range of the type, and then
2860 -- determine whether it lies in the range of the index (sub)type.
2862 -- Last must satisfy this relation:
2863 -- First + Length - 1 <= Last
2864 -- We regroup terms:
2865 -- First - 1 <= Last - Length
2866 -- Which can rewrite as:
2867 -- No_Index <= Last - Length
2869 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
2870 raise Constraint_Error with "Capacity is out of range";
2873 -- We now know that the computed value of Last is within the base
2874 -- range of the type, so it is safe to compute its value:
2876 Last := No_Index + Index_Type'Base (Capacity);
2878 -- Finally we test whether the value is within the range of the
2879 -- generic actual index subtype:
2881 if Last > Index_Type'Last then
2882 raise Constraint_Error with "Capacity is out of range";
2885 elsif Index_Type'First <= 0 then
2887 -- Here we can compute Last directly, in the normal way. We know that
2888 -- No_Index is less than 0, so there is no danger of overflow when
2889 -- adding the (positive) value of Capacity.
2891 Index := Count_Type'Base (No_Index) + Capacity; -- Last
2893 if Index > Count_Type'Base (Index_Type'Last) then
2894 raise Constraint_Error with "Capacity is out of range";
2897 -- We know that the computed value (having type Count_Type) of Last
2898 -- is within the range of the generic actual index subtype, so it is
2899 -- safe to convert to Index_Type:
2901 Last := Index_Type'Base (Index);
2904 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2905 -- must test the length indirectly (by working backwards from the
2906 -- largest possible value of Last), in order to prevent overflow.
2908 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
2910 if Index < Count_Type'Base (No_Index) then
2911 raise Constraint_Error with "Capacity is out of range";
2914 -- We have determined that the value of Capacity would not create a
2915 -- Last index value outside of the range of Index_Type, so we can now
2916 -- safely compute its value.
2918 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
2921 -- The requested capacity is non-zero, but we don't know yet whether
2922 -- this is a request for expansion or contraction of storage.
2924 if Container.Elements = null then
2926 -- The container is empty (it doesn't even have an internal array),
2927 -- so this represents a request to allocate (expand) storage having
2928 -- the given capacity.
2930 Container.Elements := new Elements_Type (Last);
2934 if Capacity <= N then
2936 -- This is a request to trim back storage, but only to the limit of
2937 -- what's already in the container. (Reserve_Capacity never deletes
2938 -- active elements, it only reclaims excess storage.)
2940 if N < Container.Elements.EA'Length then
2942 -- The container is not empty (because the requested capacity is
2943 -- positive, and less than or equal to the container length), and
2944 -- the current length is less than the current capacity, so
2945 -- there's storage available to trim. In this case, we allocate a
2946 -- new internal array having a length that exactly matches the
2947 -- number of items in the container.
2949 if Container.Busy > 0 then
2950 raise Program_Error with
2951 "attempt to tamper with cursors (vector is busy)";
2955 subtype Src_Index_Subtype is Index_Type'Base range
2956 Index_Type'First .. Container.Last;
2958 Src : Elements_Array renames
2959 Container.Elements.EA (Src_Index_Subtype);
2961 X : Elements_Access := Container.Elements;
2964 -- Although we have isolated the old internal array that we're
2965 -- going to deallocate, we don't deallocate it until we have
2966 -- successfully allocated a new one. If there is an exception
2967 -- during allocation (either because there is not enough
2968 -- storage, or because initialization of the elements fails),
2969 -- we let it propagate without causing any side-effect.
2971 Container.Elements := new Elements_Type'(Container.Last, Src);
2973 -- We have successfully allocated a new internal array (with a
2974 -- smaller length than the old one, and containing a copy of
2975 -- just the active elements in the container), so it is now
2976 -- safe to attempt to deallocate the old array. The old array
2977 -- has been isolated, and container invariants have been
2978 -- restored, so if the deallocation fails (because finalization
2979 -- of the elements fails), we simply let it propagate.
2988 -- The requested capacity is larger than the container length (the
2989 -- number of active elements). Whether this represents a request for
2990 -- expansion or contraction of the current capacity depends on what the
2991 -- current capacity is.
2993 if Capacity = Container.Elements.EA'Length then
2995 -- The requested capacity matches the existing capacity, so there's
2996 -- nothing to do here. We treat this case as a no-op, and simply
2997 -- return without checking the busy bit.
3002 -- There is a change in the capacity of a non-empty container, so a new
3003 -- internal array will be allocated. (The length of the new internal
3004 -- array could be less or greater than the old internal array. We know
3005 -- only that the length of the new internal array is greater than the
3006 -- number of active elements in the container.) We must check whether
3007 -- the container is busy before doing anything else.
3009 if Container.Busy > 0 then
3010 raise Program_Error with
3011 "attempt to tamper with cursors (vector is busy)";
3014 -- We now allocate a new internal array, having a length different from
3015 -- its current value.
3018 E : Elements_Access := new Elements_Type (Last);
3021 -- We have successfully allocated the new internal array. We first
3022 -- attempt to copy the existing elements from the old internal array
3023 -- ("src" elements) onto the new internal array ("tgt" elements).
3026 subtype Index_Subtype is Index_Type'Base range
3027 Index_Type'First .. Container.Last;
3029 Src : Elements_Array renames
3030 Container.Elements.EA (Index_Subtype);
3032 Tgt : Elements_Array renames E.EA (Index_Subtype);
3043 -- We have successfully copied the existing elements onto the new
3044 -- internal array, so now we can attempt to deallocate the old one.
3047 X : Elements_Access := Container.Elements;
3050 -- First we isolate the old internal array, and replace it in the
3051 -- container with the new internal array.
3053 Container.Elements := E;
3055 -- Container invariants have been restored, so it is now safe to
3056 -- attempt to deallocate the old internal array.
3061 end Reserve_Capacity;
3063 ----------------------
3064 -- Reverse_Elements --
3065 ----------------------
3067 procedure Reverse_Elements (Container : in out Vector) is
3069 if Container.Length <= 1 then
3073 -- The exception behavior for the vector container must match that for
3074 -- the list container, so we check for cursor tampering here (which will
3075 -- catch more things) instead of for element tampering (which will catch
3076 -- fewer things). It's true that the elements of this vector container
3077 -- could be safely moved around while (say) an iteration is taking place
3078 -- (iteration only increments the busy counter), and so technically
3079 -- all we would need here is a test for element tampering (indicated
3080 -- by the lock counter), that's simply an artifact of our array-based
3081 -- implementation. Logically Reverse_Elements requires a check for
3082 -- cursor tampering.
3084 if Container.Busy > 0 then
3085 raise Program_Error with
3086 "attempt to tamper with cursors (vector is busy)";
3092 E : Elements_Type renames Container.Elements.all;
3095 K := Index_Type'First;
3096 J := Container.Last;
3099 EK : constant Element_Type := E.EA (K);
3101 E.EA (K) := E.EA (J);
3109 end Reverse_Elements;
3115 function Reverse_Find
3116 (Container : Vector;
3117 Item : Element_Type;
3118 Position : Cursor := No_Element) return Cursor
3120 Last : Index_Type'Base;
3123 if Position.Container /= null
3124 and then Position.Container /= Container'Unrestricted_Access
3126 raise Program_Error with "Position cursor denotes wrong container";
3130 (if Position.Container = null or else Position.Index > Container.Last
3132 else Position.Index);
3134 for Indx in reverse Index_Type'First .. Last loop
3135 if Container.Elements.EA (Indx) = Item then
3136 return (Container'Unrestricted_Access, Indx);
3143 ------------------------
3144 -- Reverse_Find_Index --
3145 ------------------------
3147 function Reverse_Find_Index
3148 (Container : Vector;
3149 Item : Element_Type;
3150 Index : Index_Type := Index_Type'Last) return Extended_Index
3152 Last : constant Index_Type'Base :=
3153 Index_Type'Min (Container.Last, Index);
3156 for Indx in reverse Index_Type'First .. Last loop
3157 if Container.Elements.EA (Indx) = Item then
3163 end Reverse_Find_Index;
3165 ---------------------
3166 -- Reverse_Iterate --
3167 ---------------------
3169 procedure Reverse_Iterate
3170 (Container : Vector;
3171 Process : not null access procedure (Position : Cursor))
3173 V : Vector renames Container'Unrestricted_Access.all;
3174 B : Natural renames V.Busy;
3180 for Indx in reverse Index_Type'First .. Container.Last loop
3181 Process (Cursor'(Container'Unrestricted_Access, Indx));
3190 end Reverse_Iterate;
3196 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
3197 Count : constant Count_Type'Base := Container.Length - Length;
3200 -- Set_Length allows the user to set the length explicitly, instead
3201 -- of implicitly as a side-effect of deletion or insertion. If the
3202 -- requested length is less then the current length, this is equivalent
3203 -- to deleting items from the back end of the vector. If the requested
3204 -- length is greater than the current length, then this is equivalent
3205 -- to inserting "space" (nonce items) at the end.
3208 Container.Delete_Last (Count);
3210 elsif Container.Last >= Index_Type'Last then
3211 raise Constraint_Error with "vector is already at its maximum length";
3214 Container.Insert_Space (Container.Last + 1, -Count);
3222 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3224 if I > Container.Last then
3225 raise Constraint_Error with "I index is out of range";
3228 if J > Container.Last then
3229 raise Constraint_Error with "J index is out of range";
3236 if Container.Lock > 0 then
3237 raise Program_Error with
3238 "attempt to tamper with elements (vector is locked)";
3242 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3244 Container.Elements.EA (I) := Container.Elements.EA (J);
3245 Container.Elements.EA (J) := EI_Copy;
3249 procedure Swap (Container : in out Vector; I, J : Cursor) is
3251 if I.Container = null then
3252 raise Constraint_Error with "I cursor has no element";
3255 if J.Container = null then
3256 raise Constraint_Error with "J cursor has no element";
3259 if I.Container /= Container'Unrestricted_Access then
3260 raise Program_Error with "I cursor denotes wrong container";
3263 if J.Container /= Container'Unrestricted_Access then
3264 raise Program_Error with "J cursor denotes wrong container";
3267 Swap (Container, I.Index, J.Index);
3275 (Container : Vector;
3276 Index : Extended_Index) return Cursor
3279 if Index not in Index_Type'First .. Container.Last then
3282 return (Container'Unrestricted_Access, Index);
3290 function To_Index (Position : Cursor) return Extended_Index is
3292 if Position.Container = null then
3296 if Position.Index <= Position.Container.Last then
3297 return Position.Index;
3307 function To_Vector (Length : Count_Type) return Vector is
3308 Index : Count_Type'Base;
3309 Last : Index_Type'Base;
3310 Elements : Elements_Access;
3314 return Empty_Vector;
3317 -- We create a vector object with a capacity that matches the specified
3318 -- Length, but we do not allow the vector capacity (the length of the
3319 -- internal array) to exceed the number of values in Index_Type'Range
3320 -- (otherwise, there would be no way to refer to those components via an
3321 -- index). We must therefore check whether the specified Length would
3322 -- create a Last index value greater than Index_Type'Last.
3324 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3326 -- We perform a two-part test. First we determine whether the
3327 -- computed Last value lies in the base range of the type, and then
3328 -- determine whether it lies in the range of the index (sub)type.
3330 -- Last must satisfy this relation:
3331 -- First + Length - 1 <= Last
3332 -- We regroup terms:
3333 -- First - 1 <= Last - Length
3334 -- Which can rewrite as:
3335 -- No_Index <= Last - Length
3337 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3338 raise Constraint_Error with "Length is out of range";
3341 -- We now know that the computed value of Last is within the base
3342 -- range of the type, so it is safe to compute its value:
3344 Last := No_Index + Index_Type'Base (Length);
3346 -- Finally we test whether the value is within the range of the
3347 -- generic actual index subtype:
3349 if Last > Index_Type'Last then
3350 raise Constraint_Error with "Length is out of range";
3353 elsif Index_Type'First <= 0 then
3355 -- Here we can compute Last directly, in the normal way. We know that
3356 -- No_Index is less than 0, so there is no danger of overflow when
3357 -- adding the (positive) value of Length.
3359 Index := Count_Type'Base (No_Index) + Length; -- Last
3361 if Index > Count_Type'Base (Index_Type'Last) then
3362 raise Constraint_Error with "Length is out of range";
3365 -- We know that the computed value (having type Count_Type) of Last
3366 -- is within the range of the generic actual index subtype, so it is
3367 -- safe to convert to Index_Type:
3369 Last := Index_Type'Base (Index);
3372 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3373 -- must test the length indirectly (by working backwards from the
3374 -- largest possible value of Last), in order to prevent overflow.
3376 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3378 if Index < Count_Type'Base (No_Index) then
3379 raise Constraint_Error with "Length is out of range";
3382 -- We have determined that the value of Length would not create a
3383 -- Last index value outside of the range of Index_Type, so we can now
3384 -- safely compute its value.
3386 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3389 Elements := new Elements_Type (Last);
3391 return Vector'(Controlled with Elements, Last, 0, 0);
3395 (New_Item : Element_Type;
3396 Length : Count_Type) return Vector
3398 Index : Count_Type'Base;
3399 Last : Index_Type'Base;
3400 Elements : Elements_Access;
3404 return Empty_Vector;
3407 -- We create a vector object with a capacity that matches the specified
3408 -- Length, but we do not allow the vector capacity (the length of the
3409 -- internal array) to exceed the number of values in Index_Type'Range
3410 -- (otherwise, there would be no way to refer to those components via an
3411 -- index). We must therefore check whether the specified Length would
3412 -- create a Last index value greater than Index_Type'Last.
3414 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3416 -- We perform a two-part test. First we determine whether the
3417 -- computed Last value lies in the base range of the type, and then
3418 -- determine whether it lies in the range of the index (sub)type.
3420 -- Last must satisfy this relation:
3421 -- First + Length - 1 <= Last
3422 -- We regroup terms:
3423 -- First - 1 <= Last - Length
3424 -- Which can rewrite as:
3425 -- No_Index <= Last - Length
3427 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3428 raise Constraint_Error with "Length is out of range";
3431 -- We now know that the computed value of Last is within the base
3432 -- range of the type, so it is safe to compute its value:
3434 Last := No_Index + Index_Type'Base (Length);
3436 -- Finally we test whether the value is within the range of the
3437 -- generic actual index subtype:
3439 if Last > Index_Type'Last then
3440 raise Constraint_Error with "Length is out of range";
3443 elsif Index_Type'First <= 0 then
3445 -- Here we can compute Last directly, in the normal way. We know that
3446 -- No_Index is less than 0, so there is no danger of overflow when
3447 -- adding the (positive) value of Length.
3449 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
3451 if Index > Count_Type'Base (Index_Type'Last) then
3452 raise Constraint_Error with "Length is out of range";
3455 -- We know that the computed value (having type Count_Type) of Last
3456 -- is within the range of the generic actual index subtype, so it is
3457 -- safe to convert to Index_Type:
3459 Last := Index_Type'Base (Index);
3462 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3463 -- must test the length indirectly (by working backwards from the
3464 -- largest possible value of Last), in order to prevent overflow.
3466 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3468 if Index < Count_Type'Base (No_Index) then
3469 raise Constraint_Error with "Length is out of range";
3472 -- We have determined that the value of Length would not create a
3473 -- Last index value outside of the range of Index_Type, so we can now
3474 -- safely compute its value.
3476 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3479 Elements := new Elements_Type'(Last, EA => (others => New_Item));
3481 return Vector'(Controlled with Elements, Last, 0, 0);
3484 --------------------
3485 -- Update_Element --
3486 --------------------
3488 procedure Update_Element
3489 (Container : in out Vector;
3491 Process : not null access procedure (Element : in out Element_Type))
3493 B : Natural renames Container.Busy;
3494 L : Natural renames Container.Lock;
3497 if Index > Container.Last then
3498 raise Constraint_Error with "Index is out of range";
3505 Process (Container.Elements.EA (Index));
3517 procedure Update_Element
3518 (Container : in out Vector;
3520 Process : not null access procedure (Element : in out Element_Type))
3523 if Position.Container = null then
3524 raise Constraint_Error with "Position cursor has no element";
3525 elsif Position.Container /= Container'Unrestricted_Access then
3526 raise Program_Error with "Position cursor denotes wrong container";
3528 Update_Element (Container, Position.Index, Process);
3537 (Stream : not null access Root_Stream_Type'Class;
3541 Count_Type'Base'Write (Stream, Length (Container));
3543 for J in Index_Type'First .. Container.Last loop
3544 Element_Type'Write (Stream, Container.Elements.EA (J));
3549 (Stream : not null access Root_Stream_Type'Class;
3553 raise Program_Error with "attempt to stream vector cursor";
3557 (Stream : not null access Root_Stream_Type'Class;
3558 Item : Reference_Type)
3561 raise Program_Error with "attempt to stream reference";
3565 (Stream : not null access Root_Stream_Type'Class;
3566 Item : Constant_Reference_Type)
3569 raise Program_Error with "attempt to stream reference";
3572 end Ada.Containers.Vectors;