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-2015, 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
37 pragma Annotate (CodePeer, Skip_Analysis);
40 new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access);
42 type Iterator is new Limited_Controlled and
43 Vector_Iterator_Interfaces.Reversible_Iterator with
45 Container : Vector_Access;
46 Index : Index_Type'Base;
49 overriding procedure Finalize (Object : in out Iterator);
51 overriding function First (Object : Iterator) return Cursor;
52 overriding function Last (Object : Iterator) return Cursor;
54 overriding function Next
56 Position : Cursor) return Cursor;
58 overriding function Previous
60 Position : Cursor) return Cursor;
62 procedure Append_Slow_Path
63 (Container : in out Vector;
64 New_Item : Element_Type;
66 -- This is the slow path for Append. This is split out to minimize the size
67 -- of Append, because we have Inline (Append).
73 function "&" (Left, Right : Vector) return Vector is
74 LN : constant Count_Type := Length (Left);
75 RN : constant Count_Type := Length (Right);
76 N : Count_Type'Base; -- length of result
77 J : Count_Type'Base; -- for computing intermediate index values
78 Last : Index_Type'Base; -- Last index of result
81 -- We decide that the capacity of the result is the sum of the lengths
82 -- of the vector parameters. We could decide to make it larger, but we
83 -- have no basis for knowing how much larger, so we just allocate the
84 -- minimum amount of storage.
86 -- Here we handle the easy cases first, when one of the vector
87 -- parameters is empty. (We say "easy" because there's nothing to
88 -- compute, that can potentially overflow.)
96 RE : Elements_Array renames
97 Right.Elements.EA (Index_Type'First .. Right.Last);
98 Elements : constant Elements_Access :=
99 new Elements_Type'(Right.Last, RE);
101 return (Controlled with Elements, Right.Last, others => <>);
107 LE : Elements_Array renames
108 Left.Elements.EA (Index_Type'First .. Left.Last);
109 Elements : constant Elements_Access :=
110 new Elements_Type'(Left.Last, LE);
112 return (Controlled with Elements, Left.Last, others => <>);
117 -- Neither of the vector parameters is empty, so must compute the length
118 -- of the result vector and its last index. (This is the harder case,
119 -- because our computations must avoid overflow.)
121 -- There are two constraints we need to satisfy. The first constraint is
122 -- that a container cannot have more than Count_Type'Last elements, so
123 -- we must check the sum of the combined lengths. Note that we cannot
124 -- simply add the lengths, because of the possibility of overflow.
126 if LN > Count_Type'Last - RN then
127 raise Constraint_Error with "new length is out of range";
130 -- It is now safe compute the length of the new vector, without fear of
135 -- The second constraint is that the new Last index value cannot
136 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
137 -- Count_Type'Base as the type for intermediate values.
139 if Index_Type'Base'Last >= Count_Type_Last then
141 -- We perform a two-part test. First we determine whether the
142 -- computed Last value lies in the base range of the type, and then
143 -- determine whether it lies in the range of the index (sub)type.
145 -- Last must satisfy this relation:
146 -- First + Length - 1 <= Last
148 -- First - 1 <= Last - Length
149 -- Which can rewrite as:
150 -- No_Index <= Last - Length
152 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
153 raise Constraint_Error with "new length is out of range";
156 -- We now know that the computed value of Last is within the base
157 -- range of the type, so it is safe to compute its value:
159 Last := No_Index + Index_Type'Base (N);
161 -- Finally we test whether the value is within the range of the
162 -- generic actual index subtype:
164 if Last > Index_Type'Last then
165 raise Constraint_Error with "new length is out of range";
168 elsif Index_Type'First <= 0 then
170 -- Here we can compute Last directly, in the normal way. We know that
171 -- No_Index is less than 0, so there is no danger of overflow when
172 -- adding the (positive) value of length.
174 J := Count_Type'Base (No_Index) + N; -- Last
176 if J > Count_Type'Base (Index_Type'Last) then
177 raise Constraint_Error with "new length is out of range";
180 -- We know that the computed value (having type Count_Type) of Last
181 -- is within the range of the generic actual index subtype, so it is
182 -- safe to convert to Index_Type:
184 Last := Index_Type'Base (J);
187 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
188 -- must test the length indirectly (by working backwards from the
189 -- largest possible value of Last), in order to prevent overflow.
191 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
193 if J < Count_Type'Base (No_Index) then
194 raise Constraint_Error with "new length is out of range";
197 -- We have determined that the result length would not create a Last
198 -- index value outside of the range of Index_Type, so we can now
199 -- safely compute its value.
201 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
205 LE : Elements_Array renames
206 Left.Elements.EA (Index_Type'First .. Left.Last);
207 RE : Elements_Array renames
208 Right.Elements.EA (Index_Type'First .. Right.Last);
209 Elements : constant Elements_Access :=
210 new Elements_Type'(Last, LE & RE);
212 return (Controlled with Elements, Last, others => <>);
216 function "&" (Left : Vector; Right : Element_Type) return Vector is
218 -- We decide that the capacity of the result is the sum of the lengths
219 -- of the parameters. We could decide to make it larger, but we have no
220 -- basis for knowing how much larger, so we just allocate the minimum
221 -- amount of storage.
223 -- Handle easy case first, when the vector parameter (Left) is empty
225 if Left.Is_Empty then
227 Elements : constant Elements_Access :=
229 (Last => Index_Type'First,
230 EA => (others => Right));
233 return (Controlled with Elements, Index_Type'First, others => <>);
237 -- The vector parameter is not empty, so we must compute the length of
238 -- the result vector and its last index, but in such a way that overflow
239 -- is avoided. We must satisfy two constraints: the new length cannot
240 -- exceed Count_Type'Last, and the new Last index cannot exceed
243 if Left.Length = Count_Type'Last then
244 raise Constraint_Error with "new length is out of range";
247 if Left.Last >= Index_Type'Last then
248 raise Constraint_Error with "new length is out of range";
252 Last : constant Index_Type := Left.Last + 1;
253 LE : Elements_Array renames
254 Left.Elements.EA (Index_Type'First .. Left.Last);
255 Elements : constant Elements_Access :=
256 new Elements_Type'(Last => Last, EA => LE & Right);
258 return (Controlled with Elements, Last, others => <>);
262 function "&" (Left : Element_Type; Right : Vector) return Vector is
264 -- We decide that the capacity of the result is the sum of the lengths
265 -- of the parameters. We could decide to make it larger, but we have no
266 -- basis for knowing how much larger, so we just allocate the minimum
267 -- amount of storage.
269 -- Handle easy case first, when the vector parameter (Right) is empty
271 if Right.Is_Empty then
273 Elements : constant Elements_Access :=
275 (Last => Index_Type'First,
276 EA => (others => Left));
278 return (Controlled with Elements, Index_Type'First, others => <>);
282 -- The vector parameter is not empty, so we must compute the length of
283 -- the result vector and its last index, but in such a way that overflow
284 -- is avoided. We must satisfy two constraints: the new length cannot
285 -- exceed Count_Type'Last, and the new Last index cannot exceed
288 if Right.Length = Count_Type'Last then
289 raise Constraint_Error with "new length is out of range";
292 if Right.Last >= Index_Type'Last then
293 raise Constraint_Error with "new length is out of range";
297 Last : constant Index_Type := Right.Last + 1;
299 RE : Elements_Array renames
300 Right.Elements.EA (Index_Type'First .. Right.Last);
302 Elements : constant Elements_Access :=
308 return (Controlled with Elements, Last, others => <>);
312 function "&" (Left, Right : Element_Type) return Vector is
314 -- We decide that the capacity of the result is the sum of the lengths
315 -- of the parameters. We could decide to make it larger, but we have no
316 -- basis for knowing how much larger, so we just allocate the minimum
317 -- amount of storage.
319 -- We must compute the length of the result vector and its last index,
320 -- but in such a way that overflow is avoided. We must satisfy two
321 -- constraints: the new length cannot exceed Count_Type'Last (here, we
322 -- know that that condition is satisfied), and the new Last index cannot
323 -- exceed Index_Type'Last.
325 if Index_Type'First >= Index_Type'Last then
326 raise Constraint_Error with "new length is out of range";
330 Last : constant Index_Type := Index_Type'First + 1;
332 Elements : constant Elements_Access :=
335 EA => (Left, Right));
338 return (Controlled with Elements, Last, others => <>);
346 overriding function "=" (Left, Right : Vector) return Boolean is
347 BL : Natural renames Left'Unrestricted_Access.Busy;
348 LL : Natural renames Left'Unrestricted_Access.Lock;
350 BR : Natural renames Right'Unrestricted_Access.Busy;
351 LR : Natural renames Right'Unrestricted_Access.Lock;
356 if Left'Address = Right'Address then
360 if Left.Last /= Right.Last then
364 -- Per AI05-0022, the container implementation is required to detect
365 -- element tampering by a generic actual subprogram.
374 for J in Index_Type range Index_Type'First .. Left.Last loop
375 if Left.Elements.EA (J) /= Right.Elements.EA (J) then
404 procedure Adjust (Container : in out Vector) is
406 if Container.Last = No_Index then
407 Container.Elements := null;
412 L : constant Index_Type := Container.Last;
413 EA : Elements_Array renames
414 Container.Elements.EA (Index_Type'First .. L);
417 Container.Elements := null;
421 -- Note: it may seem that the following assignment to Container.Last
422 -- is useless, since we assign it to L below. However this code is
423 -- used in case 'new Elements_Type' below raises an exception, to
424 -- keep Container in a consistent state.
426 Container.Last := No_Index;
427 Container.Elements := new Elements_Type'(L, EA);
432 procedure Adjust (Control : in out Reference_Control_Type) is
434 if Control.Container /= null then
436 C : Vector renames Control.Container.all;
437 B : Natural renames C.Busy;
438 L : Natural renames C.Lock;
450 procedure Append (Container : in out Vector; New_Item : Vector) is
452 if Is_Empty (New_Item) then
454 elsif Container.Last = Index_Type'Last then
455 raise Constraint_Error with "vector is already at its maximum length";
457 Insert (Container, Container.Last + 1, New_Item);
462 (Container : in out Vector;
463 New_Item : Element_Type;
464 Count : Count_Type := 1)
467 -- In the general case, we pass the buck to Insert, but for efficiency,
468 -- we check for the usual case where Count = 1 and the vector has enough
469 -- room for at least one more element.
472 and then Container.Elements /= null
473 and then Container.Last /= Container.Elements.Last
475 if Container.Busy > 0 then
476 raise Program_Error with
477 "attempt to tamper with cursors (vector is busy)";
480 -- Increment Container.Last after assigning the New_Item, so we
481 -- leave the Container unmodified in case Finalize/Adjust raises
485 New_Last : constant Index_Type := Container.Last + 1;
487 Container.Elements.EA (New_Last) := New_Item;
488 Container.Last := New_Last;
492 Append_Slow_Path (Container, New_Item, Count);
496 ----------------------
497 -- Append_Slow_Path --
498 ----------------------
500 procedure Append_Slow_Path
501 (Container : in out Vector;
502 New_Item : Element_Type;
508 elsif Container.Last = Index_Type'Last then
509 raise Constraint_Error with "vector is already at its maximum length";
511 Insert (Container, Container.Last + 1, New_Item, Count);
513 end Append_Slow_Path;
519 procedure Assign (Target : in out Vector; Source : Vector) is
521 if Target'Address = Source'Address then
525 Target.Append (Source);
533 function Capacity (Container : Vector) return Count_Type is
535 if Container.Elements = null then
538 return Container.Elements.EA'Length;
546 procedure Clear (Container : in out Vector) is
548 if Container.Busy > 0 then
549 raise Program_Error with
550 "attempt to tamper with cursors (vector is busy)";
552 Container.Last := No_Index;
556 ------------------------
557 -- Constant_Reference --
558 ------------------------
560 function Constant_Reference
561 (Container : aliased Vector;
562 Position : Cursor) return Constant_Reference_Type
565 if Position.Container = null then
566 raise Constraint_Error with "Position cursor has no element";
569 if Position.Container /= Container'Unrestricted_Access then
570 raise Program_Error with "Position cursor denotes wrong container";
573 if Position.Index > Position.Container.Last then
574 raise Constraint_Error with "Position cursor is out of range";
578 C : Vector renames Position.Container.all;
579 B : Natural renames C.Busy;
580 L : Natural renames C.Lock;
582 return R : constant Constant_Reference_Type :=
583 (Element => Container.Elements.EA (Position.Index)'Access,
584 Control => (Controlled with Container'Unrestricted_Access))
590 end Constant_Reference;
592 function Constant_Reference
593 (Container : aliased Vector;
594 Index : Index_Type) return Constant_Reference_Type
597 if Index > Container.Last then
598 raise Constraint_Error with "Index is out of range";
601 C : Vector renames Container'Unrestricted_Access.all;
602 B : Natural renames C.Busy;
603 L : Natural renames C.Lock;
605 return R : constant Constant_Reference_Type :=
606 (Element => Container.Elements.EA (Index)'Access,
607 Control => (Controlled with Container'Unrestricted_Access))
614 end Constant_Reference;
622 Item : Element_Type) return Boolean
625 return Find_Index (Container, Item) /= No_Index;
634 Capacity : Count_Type := 0) return Vector
642 elsif Capacity >= Source.Length then
646 raise Capacity_Error with
647 "Requested capacity is less than Source length";
650 return Target : Vector do
651 Target.Reserve_Capacity (C);
652 Target.Assign (Source);
661 (Container : in out Vector;
662 Index : Extended_Index;
663 Count : Count_Type := 1)
665 Old_Last : constant Index_Type'Base := Container.Last;
666 New_Last : Index_Type'Base;
667 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
668 J : Index_Type'Base; -- first index of items that slide down
671 -- Delete removes items from the vector, the number of which is the
672 -- minimum of the specified Count and the items (if any) that exist from
673 -- Index to Container.Last. There are no constraints on the specified
674 -- value of Count (it can be larger than what's available at this
675 -- position in the vector, for example), but there are constraints on
676 -- the allowed values of the Index.
678 -- As a precondition on the generic actual Index_Type, the base type
679 -- must include Index_Type'Pred (Index_Type'First); this is the value
680 -- that Container.Last assumes when the vector is empty. However, we do
681 -- not allow that as the value for Index when specifying which items
682 -- should be deleted, so we must manually check. (That the user is
683 -- allowed to specify the value at all here is a consequence of the
684 -- declaration of the Extended_Index subtype, which includes the values
685 -- in the base range that immediately precede and immediately follow the
686 -- values in the Index_Type.)
688 if Index < Index_Type'First then
689 raise Constraint_Error with "Index is out of range (too small)";
692 -- We do allow a value greater than Container.Last to be specified as
693 -- the Index, but only if it's immediately greater. This allows the
694 -- corner case of deleting no items from the back end of the vector to
695 -- be treated as a no-op. (It is assumed that specifying an index value
696 -- greater than Last + 1 indicates some deeper flaw in the caller's
697 -- algorithm, so that case is treated as a proper error.)
699 if Index > Old_Last then
700 if Index > Old_Last + 1 then
701 raise Constraint_Error with "Index is out of range (too large)";
707 -- Here and elsewhere we treat deleting 0 items from the container as a
708 -- no-op, even when the container is busy, so we simply return.
714 -- The tampering bits exist to prevent an item from being deleted (or
715 -- otherwise harmfully manipulated) while it is being visited. Query,
716 -- Update, and Iterate increment the busy count on entry, and decrement
717 -- the count on exit. Delete checks the count to determine whether it is
718 -- being called while the associated callback procedure is executing.
720 if Container.Busy > 0 then
721 raise Program_Error with
722 "attempt to tamper with cursors (vector is busy)";
725 -- We first calculate what's available for deletion starting at
726 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
727 -- Count_Type'Base as the type for intermediate values. (See function
728 -- Length for more information.)
730 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
731 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
733 Count2 := Count_Type'Base (Old_Last - Index + 1);
736 -- If more elements are requested (Count) for deletion than are
737 -- available (Count2) for deletion beginning at Index, then everything
738 -- from Index is deleted. There are no elements to slide down, and so
739 -- all we need to do is set the value of Container.Last.
741 if Count >= Count2 then
742 Container.Last := Index - 1;
746 -- There are some elements aren't being deleted (the requested count was
747 -- less than the available count), so we must slide them down to
748 -- Index. We first calculate the index values of the respective array
749 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
750 -- type for intermediate calculations. For the elements that slide down,
751 -- index value New_Last is the last index value of their new home, and
752 -- index value J is the first index of their old home.
754 if Index_Type'Base'Last >= Count_Type_Last then
755 New_Last := Old_Last - Index_Type'Base (Count);
756 J := Index + Index_Type'Base (Count);
758 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
759 J := Index_Type'Base (Count_Type'Base (Index) + Count);
762 -- The internal elements array isn't guaranteed to exist unless we have
763 -- elements, but we have that guarantee here because we know we have
764 -- elements to slide. The array index values for each slice have
765 -- already been determined, so we just slide down to Index the elements
766 -- that weren't deleted.
769 EA : Elements_Array renames Container.Elements.EA;
771 EA (Index .. New_Last) := EA (J .. Old_Last);
772 Container.Last := New_Last;
777 (Container : in out Vector;
778 Position : in out Cursor;
779 Count : Count_Type := 1)
781 pragma Warnings (Off, Position);
784 if Position.Container = null then
785 raise Constraint_Error with "Position cursor has no element";
787 elsif Position.Container /= Container'Unrestricted_Access then
788 raise Program_Error with "Position cursor denotes wrong container";
790 elsif Position.Index > Container.Last then
791 raise Program_Error with "Position index is out of range";
794 Delete (Container, Position.Index, Count);
795 Position := No_Element;
803 procedure Delete_First
804 (Container : in out Vector;
805 Count : Count_Type := 1)
811 elsif Count >= Length (Container) then
816 Delete (Container, Index_Type'First, Count);
824 procedure Delete_Last
825 (Container : in out Vector;
826 Count : Count_Type := 1)
829 -- It is not permitted to delete items while the container is busy (for
830 -- example, we're in the middle of a passive iteration). However, we
831 -- always treat deleting 0 items as a no-op, even when we're busy, so we
832 -- simply return without checking.
838 -- The tampering bits exist to prevent an item from being deleted (or
839 -- otherwise harmfully manipulated) while it is being visited. Query,
840 -- Update, and Iterate increment the busy count on entry, and decrement
841 -- the count on exit. Delete_Last checks the count to determine whether
842 -- it is being called while the associated callback procedure is
845 if Container.Busy > 0 then
846 raise Program_Error with
847 "attempt to tamper with cursors (vector is busy)";
850 -- There is no restriction on how large Count can be when deleting
851 -- items. If it is equal or greater than the current length, then this
852 -- is equivalent to clearing the vector. (In particular, there's no need
853 -- for us to actually calculate the new value for Last.)
855 -- If the requested count is less than the current length, then we must
856 -- calculate the new value for Last. For the type we use the widest of
857 -- Index_Type'Base and Count_Type'Base for the intermediate values of
858 -- our calculation. (See the comments in Length for more information.)
860 if Count >= Container.Length then
861 Container.Last := No_Index;
863 elsif Index_Type'Base'Last >= Count_Type_Last then
864 Container.Last := Container.Last - Index_Type'Base (Count);
868 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
878 Index : Index_Type) return Element_Type
881 if Index > Container.Last then
882 raise Constraint_Error with "Index is out of range";
884 return Container.Elements.EA (Index);
888 function Element (Position : Cursor) return Element_Type is
890 if Position.Container = null then
891 raise Constraint_Error with "Position cursor has no element";
892 elsif Position.Index > Position.Container.Last then
893 raise Constraint_Error with "Position cursor is out of range";
895 return Position.Container.Elements.EA (Position.Index);
903 procedure Finalize (Container : in out Vector) is
904 X : Elements_Access := Container.Elements;
907 Container.Elements := null;
908 Container.Last := No_Index;
912 if Container.Busy > 0 then
913 raise Program_Error with
914 "attempt to tamper with cursors (vector is busy)";
918 procedure Finalize (Object : in out Iterator) is
919 B : Natural renames Object.Container.Busy;
924 procedure Finalize (Control : in out Reference_Control_Type) is
926 if Control.Container /= null then
928 C : Vector renames Control.Container.all;
929 B : Natural renames C.Busy;
930 L : Natural renames C.Lock;
936 Control.Container := null;
947 Position : Cursor := No_Element) return Cursor
950 if Position.Container /= null then
951 if Position.Container /= Container'Unrestricted_Access then
952 raise Program_Error with "Position cursor denotes wrong container";
955 if Position.Index > Container.Last then
956 raise Program_Error with "Position index is out of range";
960 -- Per AI05-0022, the container implementation is required to detect
961 -- element tampering by a generic actual subprogram.
964 B : Natural renames Container'Unrestricted_Access.Busy;
965 L : Natural renames Container'Unrestricted_Access.Lock;
967 Result : Index_Type'Base;
974 for J in Position.Index .. Container.Last loop
975 if Container.Elements.EA (J) = Item then
984 if Result = No_Index then
987 return Cursor'(Container'Unrestricted_Access, Result);
1004 (Container : Vector;
1005 Item : Element_Type;
1006 Index : Index_Type := Index_Type'First) return Extended_Index
1008 B : Natural renames Container'Unrestricted_Access.Busy;
1009 L : Natural renames Container'Unrestricted_Access.Lock;
1011 Result : Index_Type'Base;
1014 -- Per AI05-0022, the container implementation is required to detect
1015 -- element tampering by a generic actual subprogram.
1021 for Indx in Index .. Container.Last loop
1022 if Container.Elements.EA (Indx) = Item then
1045 function First (Container : Vector) return Cursor is
1047 if Is_Empty (Container) then
1050 return (Container'Unrestricted_Access, Index_Type'First);
1054 function First (Object : Iterator) return Cursor is
1056 -- The value of the iterator object's Index component influences the
1057 -- behavior of the First (and Last) selector function.
1059 -- When the Index component is No_Index, this means the iterator
1060 -- object was constructed without a start expression, in which case the
1061 -- (forward) iteration starts from the (logical) beginning of the entire
1062 -- sequence of items (corresponding to Container.First, for a forward
1065 -- Otherwise, this is iteration over a partial sequence of items.
1066 -- When the Index component isn't No_Index, the iterator object was
1067 -- constructed with a start expression, that specifies the position
1068 -- from which the (forward) partial iteration begins.
1070 if Object.Index = No_Index then
1071 return First (Object.Container.all);
1073 return Cursor'(Object.Container, Object.Index);
1081 function First_Element (Container : Vector) return Element_Type is
1083 if Container.Last = No_Index then
1084 raise Constraint_Error with "Container is empty";
1086 return Container.Elements.EA (Index_Type'First);
1094 function First_Index (Container : Vector) return Index_Type is
1095 pragma Unreferenced (Container);
1097 return Index_Type'First;
1100 ---------------------
1101 -- Generic_Sorting --
1102 ---------------------
1104 package body Generic_Sorting is
1110 function Is_Sorted (Container : Vector) return Boolean is
1112 if Container.Last <= Index_Type'First then
1116 -- Per AI05-0022, the container implementation is required to detect
1117 -- element tampering by a generic actual subprogram.
1120 EA : Elements_Array renames Container.Elements.EA;
1122 B : Natural renames Container'Unrestricted_Access.Busy;
1123 L : Natural renames Container'Unrestricted_Access.Lock;
1132 for J in Index_Type'First .. Container.Last - 1 loop
1133 if EA (J + 1) < EA (J) then
1157 procedure Merge (Target, Source : in out Vector) is
1158 I : Index_Type'Base := Target.Last;
1159 J : Index_Type'Base;
1162 -- The semantics of Merge changed slightly per AI05-0021. It was
1163 -- originally the case that if Target and Source denoted the same
1164 -- container object, then the GNAT implementation of Merge did
1165 -- nothing. However, it was argued that RM05 did not precisely
1166 -- specify the semantics for this corner case. The decision of the
1167 -- ARG was that if Target and Source denote the same non-empty
1168 -- container object, then Program_Error is raised.
1170 if Source.Last < Index_Type'First then -- Source is empty
1174 if Target'Address = Source'Address then
1175 raise Program_Error with
1176 "Target and Source denote same non-empty container";
1179 if Target.Last < Index_Type'First then -- Target is empty
1180 Move (Target => Target, Source => Source);
1184 if Source.Busy > 0 then
1185 raise Program_Error with
1186 "attempt to tamper with cursors (vector is busy)";
1189 Target.Set_Length (Length (Target) + Length (Source));
1191 -- Per AI05-0022, the container implementation is required to detect
1192 -- element tampering by a generic actual subprogram.
1195 TA : Elements_Array renames Target.Elements.EA;
1196 SA : Elements_Array renames Source.Elements.EA;
1198 TB : Natural renames Target.Busy;
1199 TL : Natural renames Target.Lock;
1201 SB : Natural renames Source.Busy;
1202 SL : Natural renames Source.Lock;
1212 while Source.Last >= Index_Type'First loop
1213 pragma Assert (Source.Last <= Index_Type'First
1214 or else not (SA (Source.Last) <
1215 SA (Source.Last - 1)));
1217 if I < Index_Type'First then
1218 TA (Index_Type'First .. J) :=
1219 SA (Index_Type'First .. Source.Last);
1221 Source.Last := No_Index;
1225 pragma Assert (I <= Index_Type'First
1226 or else not (TA (I) < TA (I - 1)));
1228 if SA (Source.Last) < TA (I) then
1233 TA (J) := SA (Source.Last);
1234 Source.Last := Source.Last - 1;
1262 procedure Sort (Container : in out Vector) is
1264 new Generic_Array_Sort
1265 (Index_Type => Index_Type,
1266 Element_Type => Element_Type,
1267 Array_Type => Elements_Array,
1271 if Container.Last <= Index_Type'First then
1275 -- The exception behavior for the vector container must match that
1276 -- for the list container, so we check for cursor tampering here
1277 -- (which will catch more things) instead of for element tampering
1278 -- (which will catch fewer things). It's true that the elements of
1279 -- this vector container could be safely moved around while (say) an
1280 -- iteration is taking place (iteration only increments the busy
1281 -- counter), and so technically all we would need here is a test for
1282 -- element tampering (indicated by the lock counter), that's simply
1283 -- an artifact of our array-based implementation. Logically Sort
1284 -- requires a check for cursor tampering.
1286 if Container.Busy > 0 then
1287 raise Program_Error with
1288 "attempt to tamper with cursors (vector is busy)";
1291 -- Per AI05-0022, the container implementation is required to detect
1292 -- element tampering by a generic actual subprogram.
1295 B : Natural renames Container.Busy;
1296 L : Natural renames Container.Lock;
1302 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1316 end Generic_Sorting;
1318 ------------------------
1319 -- Get_Element_Access --
1320 ------------------------
1322 function Get_Element_Access
1323 (Position : Cursor) return not null Element_Access is
1325 return Position.Container.Elements.EA (Position.Index)'Access;
1326 end Get_Element_Access;
1332 function Has_Element (Position : Cursor) return Boolean is
1334 return Position /= No_Element;
1342 (Container : in out Vector;
1343 Before : Extended_Index;
1344 New_Item : Element_Type;
1345 Count : Count_Type := 1)
1347 Old_Length : constant Count_Type := Container.Length;
1349 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1350 New_Length : Count_Type'Base; -- sum of current length and Count
1351 New_Last : Index_Type'Base; -- last index of vector after insertion
1353 Index : Index_Type'Base; -- scratch for intermediate values
1354 J : Count_Type'Base; -- scratch
1356 New_Capacity : Count_Type'Base; -- length of new, expanded array
1357 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1358 Dst : Elements_Access; -- new, expanded internal array
1361 -- As a precondition on the generic actual Index_Type, the base type
1362 -- must include Index_Type'Pred (Index_Type'First); this is the value
1363 -- that Container.Last assumes when the vector is empty. However, we do
1364 -- not allow that as the value for Index when specifying where the new
1365 -- items should be inserted, so we must manually check. (That the user
1366 -- is allowed to specify the value at all here is a consequence of the
1367 -- declaration of the Extended_Index subtype, which includes the values
1368 -- in the base range that immediately precede and immediately follow the
1369 -- values in the Index_Type.)
1371 if Before < Index_Type'First then
1372 raise Constraint_Error with
1373 "Before index is out of range (too small)";
1376 -- We do allow a value greater than Container.Last to be specified as
1377 -- the Index, but only if it's immediately greater. This allows for the
1378 -- case of appending items to the back end of the vector. (It is assumed
1379 -- that specifying an index value greater than Last + 1 indicates some
1380 -- deeper flaw in the caller's algorithm, so that case is treated as a
1383 if Before > Container.Last + 1 then
1384 raise Constraint_Error with
1385 "Before index is out of range (too large)";
1388 -- We treat inserting 0 items into the container as a no-op, even when
1389 -- the container is busy, so we simply return.
1395 -- There are two constraints we need to satisfy. The first constraint is
1396 -- that a container cannot have more than Count_Type'Last elements, so
1397 -- we must check the sum of the current length and the insertion count.
1398 -- Note: we cannot simply add these values, because of the possibility
1401 if Old_Length > Count_Type'Last - Count then
1402 raise Constraint_Error with "Count is out of range";
1405 -- It is now safe compute the length of the new vector, without fear of
1408 New_Length := Old_Length + Count;
1410 -- The second constraint is that the new Last index value cannot exceed
1411 -- Index_Type'Last. In each branch below, we calculate the maximum
1412 -- length (computed from the range of values in Index_Type), and then
1413 -- compare the new length to the maximum length. If the new length is
1414 -- acceptable, then we compute the new last index from that.
1416 if Index_Type'Base'Last >= Count_Type_Last then
1418 -- We have to handle the case when there might be more values in the
1419 -- range of Index_Type than in the range of Count_Type.
1421 if Index_Type'First <= 0 then
1423 -- We know that No_Index (the same as Index_Type'First - 1) is
1424 -- less than 0, so it is safe to compute the following sum without
1425 -- fear of overflow.
1427 Index := No_Index + Index_Type'Base (Count_Type'Last);
1429 if Index <= Index_Type'Last then
1431 -- We have determined that range of Index_Type has at least as
1432 -- many values as in Count_Type, so Count_Type'Last is the
1433 -- maximum number of items that are allowed.
1435 Max_Length := Count_Type'Last;
1438 -- The range of Index_Type has fewer values than in Count_Type,
1439 -- so the maximum number of items is computed from the range of
1442 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1446 -- No_Index is equal or greater than 0, so we can safely compute
1447 -- the difference without fear of overflow (which we would have to
1448 -- worry about if No_Index were less than 0, but that case is
1451 if Index_Type'Last - No_Index >= Count_Type_Last then
1453 -- We have determined that range of Index_Type has at least as
1454 -- many values as in Count_Type, so Count_Type'Last is the
1455 -- maximum number of items that are allowed.
1457 Max_Length := Count_Type'Last;
1460 -- The range of Index_Type has fewer values than in Count_Type,
1461 -- so the maximum number of items is computed from the range of
1464 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1468 elsif Index_Type'First <= 0 then
1470 -- We know that No_Index (the same as Index_Type'First - 1) is less
1471 -- than 0, so it is safe to compute the following sum without fear of
1474 J := Count_Type'Base (No_Index) + Count_Type'Last;
1476 if J <= Count_Type'Base (Index_Type'Last) then
1478 -- We have determined that range of Index_Type has at least as
1479 -- many values as in Count_Type, so Count_Type'Last is the maximum
1480 -- number of items that are allowed.
1482 Max_Length := Count_Type'Last;
1485 -- The range of Index_Type has fewer values than Count_Type does,
1486 -- so the maximum number of items is computed from the range of
1490 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1494 -- No_Index is equal or greater than 0, so we can safely compute the
1495 -- difference without fear of overflow (which we would have to worry
1496 -- about if No_Index were less than 0, but that case is handled
1500 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1503 -- We have just computed the maximum length (number of items). We must
1504 -- now compare the requested length to the maximum length, as we do not
1505 -- allow a vector expand beyond the maximum (because that would create
1506 -- an internal array with a last index value greater than
1507 -- Index_Type'Last, with no way to index those elements).
1509 if New_Length > Max_Length then
1510 raise Constraint_Error with "Count is out of range";
1513 -- New_Last is the last index value of the items in the container after
1514 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1515 -- compute its value from the New_Length.
1517 if Index_Type'Base'Last >= Count_Type_Last then
1518 New_Last := No_Index + Index_Type'Base (New_Length);
1520 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1523 if Container.Elements = null then
1524 pragma Assert (Container.Last = No_Index);
1526 -- This is the simplest case, with which we must always begin: we're
1527 -- inserting items into an empty vector that hasn't allocated an
1528 -- internal array yet. Note that we don't need to check the busy bit
1529 -- here, because an empty container cannot be busy.
1531 -- In order to preserve container invariants, we allocate the new
1532 -- internal array first, before setting the Last index value, in case
1533 -- the allocation fails (which can happen either because there is no
1534 -- storage available, or because element initialization fails).
1536 Container.Elements := new Elements_Type'
1538 EA => (others => New_Item));
1540 -- The allocation of the new, internal array succeeded, so it is now
1541 -- safe to update the Last index, restoring container invariants.
1543 Container.Last := New_Last;
1548 -- The tampering bits exist to prevent an item from being harmfully
1549 -- manipulated while it is being visited. Query, Update, and Iterate
1550 -- increment the busy count on entry, and decrement the count on
1551 -- exit. Insert checks the count to determine whether it is being called
1552 -- while the associated callback procedure is executing.
1554 if Container.Busy > 0 then
1555 raise Program_Error with
1556 "attempt to tamper with cursors (vector is busy)";
1559 -- An internal array has already been allocated, so we must determine
1560 -- whether there is enough unused storage for the new items.
1562 if New_Length <= Container.Elements.EA'Length then
1564 -- In this case, we're inserting elements into a vector that has
1565 -- already allocated an internal array, and the existing array has
1566 -- enough unused storage for the new items.
1569 EA : Elements_Array renames Container.Elements.EA;
1572 if Before > Container.Last then
1574 -- The new items are being appended to the vector, so no
1575 -- sliding of existing elements is required.
1577 EA (Before .. New_Last) := (others => New_Item);
1580 -- The new items are being inserted before some existing
1581 -- elements, so we must slide the existing elements up to their
1582 -- new home. We use the wider of Index_Type'Base and
1583 -- Count_Type'Base as the type for intermediate index values.
1585 if Index_Type'Base'Last >= Count_Type_Last then
1586 Index := Before + Index_Type'Base (Count);
1588 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1591 EA (Index .. New_Last) := EA (Before .. Container.Last);
1592 EA (Before .. Index - 1) := (others => New_Item);
1596 Container.Last := New_Last;
1600 -- In this case, we're inserting elements into a vector that has already
1601 -- allocated an internal array, but the existing array does not have
1602 -- enough storage, so we must allocate a new, longer array. In order to
1603 -- guarantee that the amortized insertion cost is O(1), we always
1604 -- allocate an array whose length is some power-of-two factor of the
1605 -- current array length. (The new array cannot have a length less than
1606 -- the New_Length of the container, but its last index value cannot be
1607 -- greater than Index_Type'Last.)
1609 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1610 while New_Capacity < New_Length loop
1611 if New_Capacity > Count_Type'Last / 2 then
1612 New_Capacity := Count_Type'Last;
1615 New_Capacity := 2 * New_Capacity;
1619 if New_Capacity > Max_Length then
1621 -- We have reached the limit of capacity, so no further expansion
1622 -- will occur. (This is not a problem, as there is never a need to
1623 -- have more capacity than the maximum container length.)
1625 New_Capacity := Max_Length;
1628 -- We have computed the length of the new internal array (and this is
1629 -- what "vector capacity" means), so use that to compute its last index.
1631 if Index_Type'Base'Last >= Count_Type_Last then
1632 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1635 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1638 -- Now we allocate the new, longer internal array. If the allocation
1639 -- fails, we have not changed any container state, so no side-effect
1640 -- will occur as a result of propagating the exception.
1642 Dst := new Elements_Type (Dst_Last);
1644 -- We have our new internal array. All that needs to be done now is to
1645 -- copy the existing items (if any) from the old array (the "source"
1646 -- array, object SA below) to the new array (the "destination" array,
1647 -- object DA below), and then deallocate the old array.
1650 SA : Elements_Array renames Container.Elements.EA; -- source
1651 DA : Elements_Array renames Dst.EA; -- destination
1654 DA (Index_Type'First .. Before - 1) :=
1655 SA (Index_Type'First .. Before - 1);
1657 if Before > Container.Last then
1658 DA (Before .. New_Last) := (others => New_Item);
1661 -- The new items are being inserted before some existing elements,
1662 -- so we must slide the existing elements up to their new home.
1664 if Index_Type'Base'Last >= Count_Type_Last then
1665 Index := Before + Index_Type'Base (Count);
1667 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1670 DA (Before .. Index - 1) := (others => New_Item);
1671 DA (Index .. New_Last) := SA (Before .. Container.Last);
1680 -- We have successfully copied the items onto the new array, so the
1681 -- final thing to do is deallocate the old array.
1684 X : Elements_Access := Container.Elements;
1687 -- We first isolate the old internal array, removing it from the
1688 -- container and replacing it with the new internal array, before we
1689 -- deallocate the old array (which can fail if finalization of
1690 -- elements propagates an exception).
1692 Container.Elements := Dst;
1693 Container.Last := New_Last;
1695 -- The container invariants have been restored, so it is now safe to
1696 -- attempt to deallocate the old array.
1703 (Container : in out Vector;
1704 Before : Extended_Index;
1707 N : constant Count_Type := Length (New_Item);
1708 J : Index_Type'Base;
1711 -- Use Insert_Space to create the "hole" (the destination slice) into
1712 -- which we copy the source items.
1714 Insert_Space (Container, Before, Count => N);
1718 -- There's nothing else to do here (vetting of parameters was
1719 -- performed already in Insert_Space), so we simply return.
1724 -- We calculate the last index value of the destination slice using the
1725 -- wider of Index_Type'Base and count_Type'Base.
1727 if Index_Type'Base'Last >= Count_Type_Last then
1728 J := (Before - 1) + Index_Type'Base (N);
1730 J := Index_Type'Base (Count_Type'Base (Before - 1) + N);
1733 if Container'Address /= New_Item'Address then
1735 -- This is the simple case. New_Item denotes an object different
1736 -- from Container, so there's nothing special we need to do to copy
1737 -- the source items to their destination, because all of the source
1738 -- items are contiguous.
1740 Container.Elements.EA (Before .. J) :=
1741 New_Item.Elements.EA (Index_Type'First .. New_Item.Last);
1746 -- New_Item denotes the same object as Container, so an insertion has
1747 -- potentially split the source items. The destination is always the
1748 -- range [Before, J], but the source is [Index_Type'First, Before) and
1749 -- (J, Container.Last]. We perform the copy in two steps, using each of
1750 -- the two slices of the source items.
1753 L : constant Index_Type'Base := Before - 1;
1755 subtype Src_Index_Subtype is Index_Type'Base range
1756 Index_Type'First .. L;
1758 Src : Elements_Array renames
1759 Container.Elements.EA (Src_Index_Subtype);
1761 K : Index_Type'Base;
1764 -- We first copy the source items that precede the space we
1765 -- inserted. Index value K is the last index of that portion
1766 -- destination that receives this slice of the source. (If Before
1767 -- equals Index_Type'First, then this first source slice will be
1768 -- empty, which is harmless.)
1770 if Index_Type'Base'Last >= Count_Type_Last then
1771 K := L + Index_Type'Base (Src'Length);
1773 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1776 Container.Elements.EA (Before .. K) := Src;
1778 if Src'Length = N then
1780 -- The new items were effectively appended to the container, so we
1781 -- have already copied all of the items that need to be copied.
1782 -- We return early here, even though the source slice below is
1783 -- empty (so the assignment would be harmless), because we want to
1784 -- avoid computing J + 1, which will overflow if J equals
1785 -- Index_Type'Base'Last.
1792 -- Note that we want to avoid computing J + 1 here, in case J equals
1793 -- Index_Type'Base'Last. We prevent that by returning early above,
1794 -- immediately after copying the first slice of the source, and
1795 -- determining that this second slice of the source is empty.
1797 F : constant Index_Type'Base := J + 1;
1799 subtype Src_Index_Subtype is Index_Type'Base range
1800 F .. Container.Last;
1802 Src : Elements_Array renames
1803 Container.Elements.EA (Src_Index_Subtype);
1805 K : Index_Type'Base;
1808 -- We next copy the source items that follow the space we inserted.
1809 -- Index value K is the first index of that portion of the
1810 -- destination that receives this slice of the source. (For the
1811 -- reasons given above, this slice is guaranteed to be non-empty.)
1813 if Index_Type'Base'Last >= Count_Type_Last then
1814 K := F - Index_Type'Base (Src'Length);
1816 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1819 Container.Elements.EA (K .. J) := Src;
1824 (Container : in out Vector;
1828 Index : Index_Type'Base;
1831 if Before.Container /= null
1832 and then Before.Container /= Container'Unrestricted_Access
1834 raise Program_Error with "Before cursor denotes wrong container";
1837 if Is_Empty (New_Item) then
1841 if Before.Container = null or else Before.Index > Container.Last then
1842 if Container.Last = Index_Type'Last then
1843 raise Constraint_Error with
1844 "vector is already at its maximum length";
1847 Index := Container.Last + 1;
1850 Index := Before.Index;
1853 Insert (Container, Index, New_Item);
1857 (Container : in out Vector;
1860 Position : out Cursor)
1862 Index : Index_Type'Base;
1865 if Before.Container /= null
1866 and then Before.Container /= Container'Unrestricted_Access
1868 raise Program_Error with "Before cursor denotes wrong container";
1871 if Is_Empty (New_Item) then
1872 if Before.Container = null or else Before.Index > Container.Last then
1873 Position := No_Element;
1875 Position := (Container'Unrestricted_Access, Before.Index);
1881 if Before.Container = null or else Before.Index > Container.Last then
1882 if Container.Last = Index_Type'Last then
1883 raise Constraint_Error with
1884 "vector is already at its maximum length";
1887 Index := Container.Last + 1;
1890 Index := Before.Index;
1893 Insert (Container, Index, New_Item);
1895 Position := (Container'Unrestricted_Access, Index);
1899 (Container : in out Vector;
1901 New_Item : Element_Type;
1902 Count : Count_Type := 1)
1904 Index : Index_Type'Base;
1907 if Before.Container /= null
1908 and then Before.Container /= Container'Unrestricted_Access
1910 raise Program_Error with "Before cursor denotes wrong container";
1917 if Before.Container = null or else Before.Index > Container.Last then
1918 if Container.Last = Index_Type'Last then
1919 raise Constraint_Error with
1920 "vector is already at its maximum length";
1922 Index := Container.Last + 1;
1926 Index := Before.Index;
1929 Insert (Container, Index, New_Item, Count);
1933 (Container : in out Vector;
1935 New_Item : Element_Type;
1936 Position : out Cursor;
1937 Count : Count_Type := 1)
1939 Index : Index_Type'Base;
1942 if Before.Container /= null
1943 and then Before.Container /= Container'Unrestricted_Access
1945 raise Program_Error with "Before cursor denotes wrong container";
1949 if Before.Container = null or else Before.Index > Container.Last then
1950 Position := No_Element;
1952 Position := (Container'Unrestricted_Access, Before.Index);
1958 if Before.Container = null or else Before.Index > Container.Last then
1959 if Container.Last = Index_Type'Last then
1960 raise Constraint_Error with
1961 "vector is already at its maximum length";
1964 Index := Container.Last + 1;
1967 Index := Before.Index;
1970 Insert (Container, Index, New_Item, Count);
1972 Position := (Container'Unrestricted_Access, Index);
1976 (Container : in out Vector;
1977 Before : Extended_Index;
1978 Count : Count_Type := 1)
1980 New_Item : Element_Type; -- Default-initialized value
1981 pragma Warnings (Off, New_Item);
1984 Insert (Container, Before, New_Item, Count);
1988 (Container : in out Vector;
1990 Position : out Cursor;
1991 Count : Count_Type := 1)
1993 New_Item : Element_Type; -- Default-initialized value
1994 pragma Warnings (Off, New_Item);
1996 Insert (Container, Before, New_Item, Position, Count);
2003 procedure Insert_Space
2004 (Container : in out Vector;
2005 Before : Extended_Index;
2006 Count : Count_Type := 1)
2008 Old_Length : constant Count_Type := Container.Length;
2010 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2011 New_Length : Count_Type'Base; -- sum of current length and Count
2012 New_Last : Index_Type'Base; -- last index of vector after insertion
2014 Index : Index_Type'Base; -- scratch for intermediate values
2015 J : Count_Type'Base; -- scratch
2017 New_Capacity : Count_Type'Base; -- length of new, expanded array
2018 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2019 Dst : Elements_Access; -- new, expanded internal array
2022 -- As a precondition on the generic actual Index_Type, the base type
2023 -- must include Index_Type'Pred (Index_Type'First); this is the value
2024 -- that Container.Last assumes when the vector is empty. However, we do
2025 -- not allow that as the value for Index when specifying where the new
2026 -- items should be inserted, so we must manually check. (That the user
2027 -- is allowed to specify the value at all here is a consequence of the
2028 -- declaration of the Extended_Index subtype, which includes the values
2029 -- in the base range that immediately precede and immediately follow the
2030 -- values in the Index_Type.)
2032 if Before < Index_Type'First then
2033 raise Constraint_Error with
2034 "Before index is out of range (too small)";
2037 -- We do allow a value greater than Container.Last to be specified as
2038 -- the Index, but only if it's immediately greater. This allows for the
2039 -- case of appending items to the back end of the vector. (It is assumed
2040 -- that specifying an index value greater than Last + 1 indicates some
2041 -- deeper flaw in the caller's algorithm, so that case is treated as a
2044 if Before > Container.Last + 1 then
2045 raise Constraint_Error with
2046 "Before index is out of range (too large)";
2049 -- We treat inserting 0 items into the container as a no-op, even when
2050 -- the container is busy, so we simply return.
2056 -- There are two constraints we need to satisfy. The first constraint is
2057 -- that a container cannot have more than Count_Type'Last elements, so
2058 -- we must check the sum of the current length and the insertion count.
2059 -- Note: we cannot simply add these values, because of the possibility
2062 if Old_Length > Count_Type'Last - Count then
2063 raise Constraint_Error with "Count is out of range";
2066 -- It is now safe compute the length of the new vector, without fear of
2069 New_Length := Old_Length + Count;
2071 -- The second constraint is that the new Last index value cannot exceed
2072 -- Index_Type'Last. In each branch below, we calculate the maximum
2073 -- length (computed from the range of values in Index_Type), and then
2074 -- compare the new length to the maximum length. If the new length is
2075 -- acceptable, then we compute the new last index from that.
2077 if Index_Type'Base'Last >= Count_Type_Last then
2079 -- We have to handle the case when there might be more values in the
2080 -- range of Index_Type than in the range of Count_Type.
2082 if Index_Type'First <= 0 then
2084 -- We know that No_Index (the same as Index_Type'First - 1) is
2085 -- less than 0, so it is safe to compute the following sum without
2086 -- fear of overflow.
2088 Index := No_Index + Index_Type'Base (Count_Type'Last);
2090 if Index <= Index_Type'Last then
2092 -- We have determined that range of Index_Type has at least as
2093 -- many values as in Count_Type, so Count_Type'Last is the
2094 -- maximum number of items that are allowed.
2096 Max_Length := Count_Type'Last;
2099 -- The range of Index_Type has fewer values than in Count_Type,
2100 -- so the maximum number of items is computed from the range of
2103 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2107 -- No_Index is equal or greater than 0, so we can safely compute
2108 -- the difference without fear of overflow (which we would have to
2109 -- worry about if No_Index were less than 0, but that case is
2112 if Index_Type'Last - No_Index >= Count_Type_Last then
2114 -- We have determined that range of Index_Type has at least as
2115 -- many values as in Count_Type, so Count_Type'Last is the
2116 -- maximum number of items that are allowed.
2118 Max_Length := Count_Type'Last;
2121 -- The range of Index_Type has fewer values than in Count_Type,
2122 -- so the maximum number of items is computed from the range of
2125 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
2129 elsif Index_Type'First <= 0 then
2131 -- We know that No_Index (the same as Index_Type'First - 1) is less
2132 -- than 0, so it is safe to compute the following sum without fear of
2135 J := Count_Type'Base (No_Index) + Count_Type'Last;
2137 if J <= Count_Type'Base (Index_Type'Last) then
2139 -- We have determined that range of Index_Type has at least as
2140 -- many values as in Count_Type, so Count_Type'Last is the maximum
2141 -- number of items that are allowed.
2143 Max_Length := Count_Type'Last;
2146 -- The range of Index_Type has fewer values than Count_Type does,
2147 -- so the maximum number of items is computed from the range of
2151 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2155 -- No_Index is equal or greater than 0, so we can safely compute the
2156 -- difference without fear of overflow (which we would have to worry
2157 -- about if No_Index were less than 0, but that case is handled
2161 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
2164 -- We have just computed the maximum length (number of items). We must
2165 -- now compare the requested length to the maximum length, as we do not
2166 -- allow a vector expand beyond the maximum (because that would create
2167 -- an internal array with a last index value greater than
2168 -- Index_Type'Last, with no way to index those elements).
2170 if New_Length > Max_Length then
2171 raise Constraint_Error with "Count is out of range";
2174 -- New_Last is the last index value of the items in the container after
2175 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2176 -- compute its value from the New_Length.
2178 if Index_Type'Base'Last >= Count_Type_Last then
2179 New_Last := No_Index + Index_Type'Base (New_Length);
2181 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2184 if Container.Elements = null then
2185 pragma Assert (Container.Last = No_Index);
2187 -- This is the simplest case, with which we must always begin: we're
2188 -- inserting items into an empty vector that hasn't allocated an
2189 -- internal array yet. Note that we don't need to check the busy bit
2190 -- here, because an empty container cannot be busy.
2192 -- In order to preserve container invariants, we allocate the new
2193 -- internal array first, before setting the Last index value, in case
2194 -- the allocation fails (which can happen either because there is no
2195 -- storage available, or because default-valued element
2196 -- initialization fails).
2198 Container.Elements := new Elements_Type (New_Last);
2200 -- The allocation of the new, internal array succeeded, so it is now
2201 -- safe to update the Last index, restoring container invariants.
2203 Container.Last := New_Last;
2208 -- The tampering bits exist to prevent an item from being harmfully
2209 -- manipulated while it is being visited. Query, Update, and Iterate
2210 -- increment the busy count on entry, and decrement the count on
2211 -- exit. Insert checks the count to determine whether it is being called
2212 -- while the associated callback procedure is executing.
2214 if Container.Busy > 0 then
2215 raise Program_Error with
2216 "attempt to tamper with cursors (vector is busy)";
2219 -- An internal array has already been allocated, so we must determine
2220 -- whether there is enough unused storage for the new items.
2222 if New_Last <= Container.Elements.Last then
2224 -- In this case, we're inserting space into a vector that has already
2225 -- allocated an internal array, and the existing array has enough
2226 -- unused storage for the new items.
2229 EA : Elements_Array renames Container.Elements.EA;
2232 if Before <= Container.Last then
2234 -- The space is being inserted before some existing elements,
2235 -- so we must slide the existing elements up to their new
2236 -- home. We use the wider of Index_Type'Base and
2237 -- Count_Type'Base as the type for intermediate index values.
2239 if Index_Type'Base'Last >= Count_Type_Last then
2240 Index := Before + Index_Type'Base (Count);
2243 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2246 EA (Index .. New_Last) := EA (Before .. Container.Last);
2250 Container.Last := New_Last;
2254 -- In this case, we're inserting space into a vector that has already
2255 -- allocated an internal array, but the existing array does not have
2256 -- enough storage, so we must allocate a new, longer array. In order to
2257 -- guarantee that the amortized insertion cost is O(1), we always
2258 -- allocate an array whose length is some power-of-two factor of the
2259 -- current array length. (The new array cannot have a length less than
2260 -- the New_Length of the container, but its last index value cannot be
2261 -- greater than Index_Type'Last.)
2263 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
2264 while New_Capacity < New_Length loop
2265 if New_Capacity > Count_Type'Last / 2 then
2266 New_Capacity := Count_Type'Last;
2270 New_Capacity := 2 * New_Capacity;
2273 if New_Capacity > Max_Length then
2275 -- We have reached the limit of capacity, so no further expansion
2276 -- will occur. (This is not a problem, as there is never a need to
2277 -- have more capacity than the maximum container length.)
2279 New_Capacity := Max_Length;
2282 -- We have computed the length of the new internal array (and this is
2283 -- what "vector capacity" means), so use that to compute its last index.
2285 if Index_Type'Base'Last >= Count_Type_Last then
2286 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2289 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2292 -- Now we allocate the new, longer internal array. If the allocation
2293 -- fails, we have not changed any container state, so no side-effect
2294 -- will occur as a result of propagating the exception.
2296 Dst := new Elements_Type (Dst_Last);
2298 -- We have our new internal array. All that needs to be done now is to
2299 -- copy the existing items (if any) from the old array (the "source"
2300 -- array, object SA below) to the new array (the "destination" array,
2301 -- object DA below), and then deallocate the old array.
2304 SA : Elements_Array renames Container.Elements.EA; -- source
2305 DA : Elements_Array renames Dst.EA; -- destination
2308 DA (Index_Type'First .. Before - 1) :=
2309 SA (Index_Type'First .. Before - 1);
2311 if Before <= Container.Last then
2313 -- The space is being inserted before some existing elements, so
2314 -- we must slide the existing elements up to their new home.
2316 if Index_Type'Base'Last >= Count_Type_Last then
2317 Index := Before + Index_Type'Base (Count);
2319 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
2322 DA (Index .. New_Last) := SA (Before .. Container.Last);
2331 -- We have successfully copied the items onto the new array, so the
2332 -- final thing to do is restore invariants, and deallocate the old
2336 X : Elements_Access := Container.Elements;
2339 -- We first isolate the old internal array, removing it from the
2340 -- container and replacing it with the new internal array, before we
2341 -- deallocate the old array (which can fail if finalization of
2342 -- elements propagates an exception).
2344 Container.Elements := Dst;
2345 Container.Last := New_Last;
2347 -- The container invariants have been restored, so it is now safe to
2348 -- attempt to deallocate the old array.
2354 procedure Insert_Space
2355 (Container : in out Vector;
2357 Position : out Cursor;
2358 Count : Count_Type := 1)
2360 Index : Index_Type'Base;
2363 if Before.Container /= null
2364 and then Before.Container /= Container'Unrestricted_Access
2366 raise Program_Error with "Before cursor denotes wrong container";
2370 if Before.Container = null or else Before.Index > Container.Last then
2371 Position := No_Element;
2373 Position := (Container'Unrestricted_Access, Before.Index);
2379 if Before.Container = null or else Before.Index > Container.Last then
2380 if Container.Last = Index_Type'Last then
2381 raise Constraint_Error with
2382 "vector is already at its maximum length";
2384 Index := Container.Last + 1;
2388 Index := Before.Index;
2391 Insert_Space (Container, Index, Count => Count);
2393 Position := (Container'Unrestricted_Access, Index);
2400 function Is_Empty (Container : Vector) return Boolean is
2402 return Container.Last < Index_Type'First;
2410 (Container : Vector;
2411 Process : not null access procedure (Position : Cursor))
2413 B : Natural renames Container'Unrestricted_Access.all.Busy;
2419 for Indx in Index_Type'First .. Container.Last loop
2420 Process (Cursor'(Container'Unrestricted_Access, Indx));
2432 (Container : Vector)
2433 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2435 V : constant Vector_Access := Container'Unrestricted_Access;
2436 B : Natural renames V.Busy;
2439 -- The value of its Index component influences the behavior of the First
2440 -- and Last selector functions of the iterator object. When the Index
2441 -- component is No_Index (as is the case here), this means the iterator
2442 -- object was constructed without a start expression. This is a complete
2443 -- iterator, meaning that the iteration starts from the (logical)
2444 -- beginning of the sequence of items.
2446 -- Note: For a forward iterator, Container.First is the beginning, and
2447 -- for a reverse iterator, Container.Last is the beginning.
2449 return It : constant Iterator :=
2450 (Limited_Controlled with
2459 (Container : Vector;
2461 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2463 V : constant Vector_Access := Container'Unrestricted_Access;
2464 B : Natural renames V.Busy;
2467 -- It was formerly the case that when Start = No_Element, the partial
2468 -- iterator was defined to behave the same as for a complete iterator,
2469 -- and iterate over the entire sequence of items. However, those
2470 -- semantics were unintuitive and arguably error-prone (it is too easy
2471 -- to accidentally create an endless loop), and so they were changed,
2472 -- per the ARG meeting in Denver on 2011/11. However, there was no
2473 -- consensus about what positive meaning this corner case should have,
2474 -- and so it was decided to simply raise an exception. This does imply,
2475 -- however, that it is not possible to use a partial iterator to specify
2476 -- an empty sequence of items.
2478 if Start.Container = null then
2479 raise Constraint_Error with
2480 "Start position for iterator equals No_Element";
2483 if Start.Container /= V then
2484 raise Program_Error with
2485 "Start cursor of Iterate designates wrong vector";
2488 if Start.Index > V.Last then
2489 raise Constraint_Error with
2490 "Start position for iterator equals No_Element";
2493 -- The value of its Index component influences the behavior of the First
2494 -- and Last selector functions of the iterator object. When the Index
2495 -- component is not No_Index (as is the case here), it means that this
2496 -- is a partial iteration, over a subset of the complete sequence of
2497 -- items. The iterator object was constructed with a start expression,
2498 -- indicating the position from which the iteration begins. Note that
2499 -- the start position has the same value irrespective of whether this
2500 -- is a forward or reverse iteration.
2502 return It : constant Iterator :=
2503 (Limited_Controlled with
2505 Index => Start.Index)
2515 function Last (Container : Vector) return Cursor is
2517 if Is_Empty (Container) then
2520 return (Container'Unrestricted_Access, Container.Last);
2524 function Last (Object : Iterator) return Cursor is
2526 -- The value of the iterator object's Index component influences the
2527 -- behavior of the Last (and First) selector function.
2529 -- When the Index component is No_Index, this means the iterator
2530 -- object was constructed without a start expression, in which case the
2531 -- (reverse) iteration starts from the (logical) beginning of the entire
2532 -- sequence (corresponding to Container.Last, for a reverse iterator).
2534 -- Otherwise, this is iteration over a partial sequence of items.
2535 -- When the Index component is not No_Index, the iterator object was
2536 -- constructed with a start expression, that specifies the position
2537 -- from which the (reverse) partial iteration begins.
2539 if Object.Index = No_Index then
2540 return Last (Object.Container.all);
2542 return Cursor'(Object.Container, Object.Index);
2550 function Last_Element (Container : Vector) return Element_Type is
2552 if Container.Last = No_Index then
2553 raise Constraint_Error with "Container is empty";
2555 return Container.Elements.EA (Container.Last);
2563 function Last_Index (Container : Vector) return Extended_Index is
2565 return Container.Last;
2572 function Length (Container : Vector) return Count_Type is
2573 L : constant Index_Type'Base := Container.Last;
2574 F : constant Index_Type := Index_Type'First;
2577 -- The base range of the index type (Index_Type'Base) might not include
2578 -- all values for length (Count_Type). Contrariwise, the index type
2579 -- might include values outside the range of length. Hence we use
2580 -- whatever type is wider for intermediate values when calculating
2581 -- length. Note that no matter what the index type is, the maximum
2582 -- length to which a vector is allowed to grow is always the minimum
2583 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2585 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2586 -- to have a base range of -128 .. 127, but the corresponding vector
2587 -- would have lengths in the range 0 .. 255. In this case we would need
2588 -- to use Count_Type'Base for intermediate values.
2590 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2591 -- vector would have a maximum length of 10, but the index values lie
2592 -- outside the range of Count_Type (which is only 32 bits). In this
2593 -- case we would need to use Index_Type'Base for intermediate values.
2595 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
2596 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2598 return Count_Type (L - F + 1);
2607 (Target : in out Vector;
2608 Source : in out Vector)
2611 if Target'Address = Source'Address then
2615 if Target.Busy > 0 then
2616 raise Program_Error with
2617 "attempt to tamper with cursors (Target is busy)";
2620 if Source.Busy > 0 then
2621 raise Program_Error with
2622 "attempt to tamper with cursors (Source is busy)";
2626 Target_Elements : constant Elements_Access := Target.Elements;
2628 Target.Elements := Source.Elements;
2629 Source.Elements := Target_Elements;
2632 Target.Last := Source.Last;
2633 Source.Last := No_Index;
2640 function Next (Position : Cursor) return Cursor is
2642 if Position.Container = null then
2644 elsif Position.Index < Position.Container.Last then
2645 return (Position.Container, Position.Index + 1);
2651 function Next (Object : Iterator; Position : Cursor) return Cursor is
2653 if Position.Container = null then
2655 elsif Position.Container /= Object.Container then
2656 raise Program_Error with
2657 "Position cursor of Next designates wrong vector";
2659 return Next (Position);
2663 procedure Next (Position : in out Cursor) is
2665 if Position.Container = null then
2667 elsif Position.Index < Position.Container.Last then
2668 Position.Index := Position.Index + 1;
2670 Position := No_Element;
2678 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2680 Insert (Container, Index_Type'First, New_Item);
2684 (Container : in out Vector;
2685 New_Item : Element_Type;
2686 Count : Count_Type := 1)
2689 Insert (Container, Index_Type'First, New_Item, Count);
2696 function Previous (Position : Cursor) return Cursor is
2698 if Position.Container = null then
2700 elsif Position.Index > Index_Type'First then
2701 return (Position.Container, Position.Index - 1);
2707 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2709 if Position.Container = null then
2711 elsif Position.Container /= Object.Container then
2712 raise Program_Error with
2713 "Position cursor of Previous designates wrong vector";
2715 return Previous (Position);
2719 procedure Previous (Position : in out Cursor) is
2721 if Position.Container = null then
2723 elsif Position.Index > Index_Type'First then
2724 Position.Index := Position.Index - 1;
2726 Position := No_Element;
2730 ----------------------
2731 -- Pseudo_Reference --
2732 ----------------------
2734 function Pseudo_Reference
2735 (Container : aliased Vector'Class) return Reference_Control_Type
2737 C : constant Vector_Access := Container'Unrestricted_Access;
2738 B : Natural renames C.Busy;
2739 L : Natural renames C.Lock;
2741 return R : constant Reference_Control_Type :=
2747 end Pseudo_Reference;
2753 procedure Query_Element
2754 (Container : Vector;
2756 Process : not null access procedure (Element : Element_Type))
2758 V : Vector renames Container'Unrestricted_Access.all;
2759 B : Natural renames V.Busy;
2760 L : Natural renames V.Lock;
2763 if Index > Container.Last then
2764 raise Constraint_Error with "Index is out of range";
2771 Process (V.Elements.EA (Index));
2783 procedure Query_Element
2785 Process : not null access procedure (Element : Element_Type))
2788 if Position.Container = null then
2789 raise Constraint_Error with "Position cursor has no element";
2791 Query_Element (Position.Container.all, Position.Index, Process);
2800 (Stream : not null access Root_Stream_Type'Class;
2801 Container : out Vector)
2803 Length : Count_Type'Base;
2804 Last : Index_Type'Base := No_Index;
2809 Count_Type'Base'Read (Stream, Length);
2811 if Length > Capacity (Container) then
2812 Reserve_Capacity (Container, Capacity => Length);
2815 for J in Count_Type range 1 .. Length loop
2817 Element_Type'Read (Stream, Container.Elements.EA (Last));
2818 Container.Last := Last;
2823 (Stream : not null access Root_Stream_Type'Class;
2824 Position : out Cursor)
2827 raise Program_Error with "attempt to stream vector cursor";
2831 (Stream : not null access Root_Stream_Type'Class;
2832 Item : out Reference_Type)
2835 raise Program_Error with "attempt to stream reference";
2839 (Stream : not null access Root_Stream_Type'Class;
2840 Item : out Constant_Reference_Type)
2843 raise Program_Error with "attempt to stream reference";
2851 (Container : aliased in out Vector;
2852 Position : Cursor) return Reference_Type
2855 if Position.Container = null then
2856 raise Constraint_Error with "Position cursor has no element";
2859 if Position.Container /= Container'Unrestricted_Access then
2860 raise Program_Error with "Position cursor denotes wrong container";
2863 if Position.Index > Position.Container.Last then
2864 raise Constraint_Error with "Position cursor is out of range";
2868 C : Vector renames Position.Container.all;
2869 B : Natural renames C.Busy;
2870 L : Natural renames C.Lock;
2872 return R : constant Reference_Type :=
2873 (Element => Container.Elements.EA (Position.Index)'Access,
2874 Control => (Controlled with Position.Container))
2883 (Container : aliased in out Vector;
2884 Index : Index_Type) return Reference_Type
2887 if Index > Container.Last then
2888 raise Constraint_Error with "Index is out of range";
2892 C : Vector renames Container'Unrestricted_Access.all;
2893 B : Natural renames C.Busy;
2894 L : Natural renames C.Lock;
2896 return R : constant Reference_Type :=
2897 (Element => Container.Elements.EA (Index)'Access,
2898 Control => (Controlled with Container'Unrestricted_Access))
2907 ---------------------
2908 -- Replace_Element --
2909 ---------------------
2911 procedure Replace_Element
2912 (Container : in out Vector;
2914 New_Item : Element_Type)
2917 if Index > Container.Last then
2918 raise Constraint_Error with "Index is out of range";
2919 elsif Container.Lock > 0 then
2920 raise Program_Error with
2921 "attempt to tamper with elements (vector is locked)";
2923 Container.Elements.EA (Index) := New_Item;
2925 end Replace_Element;
2927 procedure Replace_Element
2928 (Container : in out Vector;
2930 New_Item : Element_Type)
2933 if Position.Container = null then
2934 raise Constraint_Error with "Position cursor has no element";
2936 elsif Position.Container /= Container'Unrestricted_Access then
2937 raise Program_Error with "Position cursor denotes wrong container";
2939 elsif Position.Index > Container.Last then
2940 raise Constraint_Error with "Position cursor is out of range";
2943 if Container.Lock > 0 then
2944 raise Program_Error with
2945 "attempt to tamper with elements (vector is locked)";
2948 Container.Elements.EA (Position.Index) := New_Item;
2950 end Replace_Element;
2952 ----------------------
2953 -- Reserve_Capacity --
2954 ----------------------
2956 procedure Reserve_Capacity
2957 (Container : in out Vector;
2958 Capacity : Count_Type)
2960 N : constant Count_Type := Length (Container);
2962 Index : Count_Type'Base;
2963 Last : Index_Type'Base;
2966 -- Reserve_Capacity can be used to either expand the storage available
2967 -- for elements (this would be its typical use, in anticipation of
2968 -- future insertion), or to trim back storage. In the latter case,
2969 -- storage can only be trimmed back to the limit of the container
2970 -- length. Note that Reserve_Capacity neither deletes (active) elements
2971 -- nor inserts elements; it only affects container capacity, never
2972 -- container length.
2974 if Capacity = 0 then
2976 -- This is a request to trim back storage, to the minimum amount
2977 -- possible given the current state of the container.
2981 -- The container is empty, so in this unique case we can
2982 -- deallocate the entire internal array. Note that an empty
2983 -- container can never be busy, so there's no need to check the
2987 X : Elements_Access := Container.Elements;
2990 -- First we remove the internal array from the container, to
2991 -- handle the case when the deallocation raises an exception.
2993 Container.Elements := null;
2995 -- Container invariants have been restored, so it is now safe
2996 -- to attempt to deallocate the internal array.
3001 elsif N < Container.Elements.EA'Length then
3003 -- The container is not empty, and the current length is less than
3004 -- the current capacity, so there's storage available to trim. In
3005 -- this case, we allocate a new internal array having a length
3006 -- that exactly matches the number of items in the
3007 -- container. (Reserve_Capacity does not delete active elements,
3008 -- so this is the best we can do with respect to minimizing
3011 if Container.Busy > 0 then
3012 raise Program_Error with
3013 "attempt to tamper with cursors (vector is busy)";
3017 subtype Src_Index_Subtype is Index_Type'Base range
3018 Index_Type'First .. Container.Last;
3020 Src : Elements_Array renames
3021 Container.Elements.EA (Src_Index_Subtype);
3023 X : Elements_Access := Container.Elements;
3026 -- Although we have isolated the old internal array that we're
3027 -- going to deallocate, we don't deallocate it until we have
3028 -- successfully allocated a new one. If there is an exception
3029 -- during allocation (either because there is not enough
3030 -- storage, or because initialization of the elements fails),
3031 -- we let it propagate without causing any side-effect.
3033 Container.Elements := new Elements_Type'(Container.Last, Src);
3035 -- We have successfully allocated a new internal array (with a
3036 -- smaller length than the old one, and containing a copy of
3037 -- just the active elements in the container), so it is now
3038 -- safe to attempt to deallocate the old array. The old array
3039 -- has been isolated, and container invariants have been
3040 -- restored, so if the deallocation fails (because finalization
3041 -- of the elements fails), we simply let it propagate.
3050 -- Reserve_Capacity can be used to expand the storage available for
3051 -- elements, but we do not let the capacity grow beyond the number of
3052 -- values in Index_Type'Range. (Were it otherwise, there would be no way
3053 -- to refer to the elements with an index value greater than
3054 -- Index_Type'Last, so that storage would be wasted.) Here we compute
3055 -- the Last index value of the new internal array, in a way that avoids
3056 -- any possibility of overflow.
3058 if Index_Type'Base'Last >= Count_Type_Last then
3060 -- We perform a two-part test. First we determine whether the
3061 -- computed Last value lies in the base range of the type, and then
3062 -- determine whether it lies in the range of the index (sub)type.
3064 -- Last must satisfy this relation:
3065 -- First + Length - 1 <= Last
3066 -- We regroup terms:
3067 -- First - 1 <= Last - Length
3068 -- Which can rewrite as:
3069 -- No_Index <= Last - Length
3071 if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then
3072 raise Constraint_Error with "Capacity is out of range";
3075 -- We now know that the computed value of Last is within the base
3076 -- range of the type, so it is safe to compute its value:
3078 Last := No_Index + Index_Type'Base (Capacity);
3080 -- Finally we test whether the value is within the range of the
3081 -- generic actual index subtype:
3083 if Last > Index_Type'Last then
3084 raise Constraint_Error with "Capacity is out of range";
3087 elsif Index_Type'First <= 0 then
3089 -- Here we can compute Last directly, in the normal way. We know that
3090 -- No_Index is less than 0, so there is no danger of overflow when
3091 -- adding the (positive) value of Capacity.
3093 Index := Count_Type'Base (No_Index) + Capacity; -- Last
3095 if Index > Count_Type'Base (Index_Type'Last) then
3096 raise Constraint_Error with "Capacity is out of range";
3099 -- We know that the computed value (having type Count_Type) of Last
3100 -- is within the range of the generic actual index subtype, so it is
3101 -- safe to convert to Index_Type:
3103 Last := Index_Type'Base (Index);
3106 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3107 -- must test the length indirectly (by working backwards from the
3108 -- largest possible value of Last), in order to prevent overflow.
3110 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
3112 if Index < Count_Type'Base (No_Index) then
3113 raise Constraint_Error with "Capacity is out of range";
3116 -- We have determined that the value of Capacity would not create a
3117 -- Last index value outside of the range of Index_Type, so we can now
3118 -- safely compute its value.
3120 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
3123 -- The requested capacity is non-zero, but we don't know yet whether
3124 -- this is a request for expansion or contraction of storage.
3126 if Container.Elements = null then
3128 -- The container is empty (it doesn't even have an internal array),
3129 -- so this represents a request to allocate (expand) storage having
3130 -- the given capacity.
3132 Container.Elements := new Elements_Type (Last);
3136 if Capacity <= N then
3138 -- This is a request to trim back storage, but only to the limit of
3139 -- what's already in the container. (Reserve_Capacity never deletes
3140 -- active elements, it only reclaims excess storage.)
3142 if N < Container.Elements.EA'Length then
3144 -- The container is not empty (because the requested capacity is
3145 -- positive, and less than or equal to the container length), and
3146 -- the current length is less than the current capacity, so
3147 -- there's storage available to trim. In this case, we allocate a
3148 -- new internal array having a length that exactly matches the
3149 -- number of items in the container.
3151 if Container.Busy > 0 then
3152 raise Program_Error with
3153 "attempt to tamper with cursors (vector is busy)";
3157 subtype Src_Index_Subtype is Index_Type'Base range
3158 Index_Type'First .. Container.Last;
3160 Src : Elements_Array renames
3161 Container.Elements.EA (Src_Index_Subtype);
3163 X : Elements_Access := Container.Elements;
3166 -- Although we have isolated the old internal array that we're
3167 -- going to deallocate, we don't deallocate it until we have
3168 -- successfully allocated a new one. If there is an exception
3169 -- during allocation (either because there is not enough
3170 -- storage, or because initialization of the elements fails),
3171 -- we let it propagate without causing any side-effect.
3173 Container.Elements := new Elements_Type'(Container.Last, Src);
3175 -- We have successfully allocated a new internal array (with a
3176 -- smaller length than the old one, and containing a copy of
3177 -- just the active elements in the container), so it is now
3178 -- safe to attempt to deallocate the old array. The old array
3179 -- has been isolated, and container invariants have been
3180 -- restored, so if the deallocation fails (because finalization
3181 -- of the elements fails), we simply let it propagate.
3190 -- The requested capacity is larger than the container length (the
3191 -- number of active elements). Whether this represents a request for
3192 -- expansion or contraction of the current capacity depends on what the
3193 -- current capacity is.
3195 if Capacity = Container.Elements.EA'Length then
3197 -- The requested capacity matches the existing capacity, so there's
3198 -- nothing to do here. We treat this case as a no-op, and simply
3199 -- return without checking the busy bit.
3204 -- There is a change in the capacity of a non-empty container, so a new
3205 -- internal array will be allocated. (The length of the new internal
3206 -- array could be less or greater than the old internal array. We know
3207 -- only that the length of the new internal array is greater than the
3208 -- number of active elements in the container.) We must check whether
3209 -- the container is busy before doing anything else.
3211 if Container.Busy > 0 then
3212 raise Program_Error with
3213 "attempt to tamper with cursors (vector is busy)";
3216 -- We now allocate a new internal array, having a length different from
3217 -- its current value.
3220 E : Elements_Access := new Elements_Type (Last);
3223 -- We have successfully allocated the new internal array. We first
3224 -- attempt to copy the existing elements from the old internal array
3225 -- ("src" elements) onto the new internal array ("tgt" elements).
3228 subtype Index_Subtype is Index_Type'Base range
3229 Index_Type'First .. Container.Last;
3231 Src : Elements_Array renames
3232 Container.Elements.EA (Index_Subtype);
3234 Tgt : Elements_Array renames E.EA (Index_Subtype);
3245 -- We have successfully copied the existing elements onto the new
3246 -- internal array, so now we can attempt to deallocate the old one.
3249 X : Elements_Access := Container.Elements;
3252 -- First we isolate the old internal array, and replace it in the
3253 -- container with the new internal array.
3255 Container.Elements := E;
3257 -- Container invariants have been restored, so it is now safe to
3258 -- attempt to deallocate the old internal array.
3263 end Reserve_Capacity;
3265 ----------------------
3266 -- Reverse_Elements --
3267 ----------------------
3269 procedure Reverse_Elements (Container : in out Vector) is
3271 if Container.Length <= 1 then
3275 -- The exception behavior for the vector container must match that for
3276 -- the list container, so we check for cursor tampering here (which will
3277 -- catch more things) instead of for element tampering (which will catch
3278 -- fewer things). It's true that the elements of this vector container
3279 -- could be safely moved around while (say) an iteration is taking place
3280 -- (iteration only increments the busy counter), and so technically
3281 -- all we would need here is a test for element tampering (indicated
3282 -- by the lock counter), that's simply an artifact of our array-based
3283 -- implementation. Logically Reverse_Elements requires a check for
3284 -- cursor tampering.
3286 if Container.Busy > 0 then
3287 raise Program_Error with
3288 "attempt to tamper with cursors (vector is busy)";
3294 E : Elements_Type renames Container.Elements.all;
3297 K := Index_Type'First;
3298 J := Container.Last;
3301 EK : constant Element_Type := E.EA (K);
3303 E.EA (K) := E.EA (J);
3311 end Reverse_Elements;
3317 function Reverse_Find
3318 (Container : Vector;
3319 Item : Element_Type;
3320 Position : Cursor := No_Element) return Cursor
3322 Last : Index_Type'Base;
3325 if Position.Container /= null
3326 and then Position.Container /= Container'Unrestricted_Access
3328 raise Program_Error with "Position cursor denotes wrong container";
3332 (if Position.Container = null or else Position.Index > Container.Last
3334 else Position.Index);
3336 -- Per AI05-0022, the container implementation is required to detect
3337 -- element tampering by a generic actual subprogram.
3340 B : Natural renames Container'Unrestricted_Access.Busy;
3341 L : Natural renames Container'Unrestricted_Access.Lock;
3343 Result : Index_Type'Base;
3350 for Indx in reverse Index_Type'First .. Last loop
3351 if Container.Elements.EA (Indx) = Item then
3360 if Result = No_Index then
3363 return Cursor'(Container'Unrestricted_Access, Result);
3375 ------------------------
3376 -- Reverse_Find_Index --
3377 ------------------------
3379 function Reverse_Find_Index
3380 (Container : Vector;
3381 Item : Element_Type;
3382 Index : Index_Type := Index_Type'Last) return Extended_Index
3384 B : Natural renames Container'Unrestricted_Access.Busy;
3385 L : Natural renames Container'Unrestricted_Access.Lock;
3387 Last : constant Index_Type'Base :=
3388 Index_Type'Min (Container.Last, Index);
3390 Result : Index_Type'Base;
3393 -- Per AI05-0022, the container implementation is required to detect
3394 -- element tampering by a generic actual subprogram.
3400 for Indx in reverse Index_Type'First .. Last loop
3401 if Container.Elements.EA (Indx) = Item then
3418 end Reverse_Find_Index;
3420 ---------------------
3421 -- Reverse_Iterate --
3422 ---------------------
3424 procedure Reverse_Iterate
3425 (Container : Vector;
3426 Process : not null access procedure (Position : Cursor))
3428 V : Vector renames Container'Unrestricted_Access.all;
3429 B : Natural renames V.Busy;
3435 for Indx in reverse Index_Type'First .. Container.Last loop
3436 Process (Cursor'(Container'Unrestricted_Access, Indx));
3445 end Reverse_Iterate;
3451 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
3452 Count : constant Count_Type'Base := Container.Length - Length;
3455 -- Set_Length allows the user to set the length explicitly, instead
3456 -- of implicitly as a side-effect of deletion or insertion. If the
3457 -- requested length is less than the current length, this is equivalent
3458 -- to deleting items from the back end of the vector. If the requested
3459 -- length is greater than the current length, then this is equivalent
3460 -- to inserting "space" (nonce items) at the end.
3463 Container.Delete_Last (Count);
3465 elsif Container.Last >= Index_Type'Last then
3466 raise Constraint_Error with "vector is already at its maximum length";
3469 Container.Insert_Space (Container.Last + 1, -Count);
3477 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3479 if I > Container.Last then
3480 raise Constraint_Error with "I index is out of range";
3483 if J > Container.Last then
3484 raise Constraint_Error with "J index is out of range";
3491 if Container.Lock > 0 then
3492 raise Program_Error with
3493 "attempt to tamper with elements (vector is locked)";
3497 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3499 Container.Elements.EA (I) := Container.Elements.EA (J);
3500 Container.Elements.EA (J) := EI_Copy;
3504 procedure Swap (Container : in out Vector; I, J : Cursor) is
3506 if I.Container = null then
3507 raise Constraint_Error with "I cursor has no element";
3509 elsif J.Container = null then
3510 raise Constraint_Error with "J cursor has no element";
3512 elsif I.Container /= Container'Unrestricted_Access then
3513 raise Program_Error with "I cursor denotes wrong container";
3515 elsif J.Container /= Container'Unrestricted_Access then
3516 raise Program_Error with "J cursor denotes wrong container";
3519 Swap (Container, I.Index, J.Index);
3528 (Container : Vector;
3529 Index : Extended_Index) return Cursor
3532 if Index not in Index_Type'First .. Container.Last then
3535 return (Container'Unrestricted_Access, Index);
3543 function To_Index (Position : Cursor) return Extended_Index is
3545 if Position.Container = null then
3547 elsif Position.Index <= Position.Container.Last then
3548 return Position.Index;
3558 function To_Vector (Length : Count_Type) return Vector is
3559 Index : Count_Type'Base;
3560 Last : Index_Type'Base;
3561 Elements : Elements_Access;
3565 return Empty_Vector;
3568 -- We create a vector object with a capacity that matches the specified
3569 -- Length, but we do not allow the vector capacity (the length of the
3570 -- internal array) to exceed the number of values in Index_Type'Range
3571 -- (otherwise, there would be no way to refer to those components via an
3572 -- index). We must therefore check whether the specified Length would
3573 -- create a Last index value greater than Index_Type'Last.
3575 if Index_Type'Base'Last >= Count_Type_Last then
3577 -- We perform a two-part test. First we determine whether the
3578 -- computed Last value lies in the base range of the type, and then
3579 -- determine whether it lies in the range of the index (sub)type.
3581 -- Last must satisfy this relation:
3582 -- First + Length - 1 <= Last
3583 -- We regroup terms:
3584 -- First - 1 <= Last - Length
3585 -- Which can rewrite as:
3586 -- No_Index <= Last - Length
3588 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3589 raise Constraint_Error with "Length is out of range";
3592 -- We now know that the computed value of Last is within the base
3593 -- range of the type, so it is safe to compute its value:
3595 Last := No_Index + Index_Type'Base (Length);
3597 -- Finally we test whether the value is within the range of the
3598 -- generic actual index subtype:
3600 if Last > Index_Type'Last then
3601 raise Constraint_Error with "Length is out of range";
3604 elsif Index_Type'First <= 0 then
3606 -- Here we can compute Last directly, in the normal way. We know that
3607 -- No_Index is less than 0, so there is no danger of overflow when
3608 -- adding the (positive) value of Length.
3610 Index := Count_Type'Base (No_Index) + Length; -- Last
3612 if Index > Count_Type'Base (Index_Type'Last) then
3613 raise Constraint_Error with "Length is out of range";
3616 -- We know that the computed value (having type Count_Type) of Last
3617 -- is within the range of the generic actual index subtype, so it is
3618 -- safe to convert to Index_Type:
3620 Last := Index_Type'Base (Index);
3623 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3624 -- must test the length indirectly (by working backwards from the
3625 -- largest possible value of Last), in order to prevent overflow.
3627 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3629 if Index < Count_Type'Base (No_Index) then
3630 raise Constraint_Error with "Length is out of range";
3633 -- We have determined that the value of Length would not create a
3634 -- Last index value outside of the range of Index_Type, so we can now
3635 -- safely compute its value.
3637 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3640 Elements := new Elements_Type (Last);
3642 return Vector'(Controlled with Elements, Last, others => <>);
3646 (New_Item : Element_Type;
3647 Length : Count_Type) return Vector
3649 Index : Count_Type'Base;
3650 Last : Index_Type'Base;
3651 Elements : Elements_Access;
3655 return Empty_Vector;
3658 -- We create a vector object with a capacity that matches the specified
3659 -- Length, but we do not allow the vector capacity (the length of the
3660 -- internal array) to exceed the number of values in Index_Type'Range
3661 -- (otherwise, there would be no way to refer to those components via an
3662 -- index). We must therefore check whether the specified Length would
3663 -- create a Last index value greater than Index_Type'Last.
3665 if Index_Type'Base'Last >= Count_Type_Last then
3667 -- We perform a two-part test. First we determine whether the
3668 -- computed Last value lies in the base range of the type, and then
3669 -- determine whether it lies in the range of the index (sub)type.
3671 -- Last must satisfy this relation:
3672 -- First + Length - 1 <= Last
3673 -- We regroup terms:
3674 -- First - 1 <= Last - Length
3675 -- Which can rewrite as:
3676 -- No_Index <= Last - Length
3678 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
3679 raise Constraint_Error with "Length is out of range";
3682 -- We now know that the computed value of Last is within the base
3683 -- range of the type, so it is safe to compute its value:
3685 Last := No_Index + Index_Type'Base (Length);
3687 -- Finally we test whether the value is within the range of the
3688 -- generic actual index subtype:
3690 if Last > Index_Type'Last then
3691 raise Constraint_Error with "Length is out of range";
3694 elsif Index_Type'First <= 0 then
3696 -- Here we can compute Last directly, in the normal way. We know that
3697 -- No_Index is less than 0, so there is no danger of overflow when
3698 -- adding the (positive) value of Length.
3700 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
3702 if Index > Count_Type'Base (Index_Type'Last) then
3703 raise Constraint_Error with "Length is out of range";
3706 -- We know that the computed value (having type Count_Type) of Last
3707 -- is within the range of the generic actual index subtype, so it is
3708 -- safe to convert to Index_Type:
3710 Last := Index_Type'Base (Index);
3713 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3714 -- must test the length indirectly (by working backwards from the
3715 -- largest possible value of Last), in order to prevent overflow.
3717 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3719 if Index < Count_Type'Base (No_Index) then
3720 raise Constraint_Error with "Length is out of range";
3723 -- We have determined that the value of Length would not create a
3724 -- Last index value outside of the range of Index_Type, so we can now
3725 -- safely compute its value.
3727 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3730 Elements := new Elements_Type'(Last, EA => (others => New_Item));
3732 return Vector'(Controlled with Elements, Last, others => <>);
3735 --------------------
3736 -- Update_Element --
3737 --------------------
3739 procedure Update_Element
3740 (Container : in out Vector;
3742 Process : not null access procedure (Element : in out Element_Type))
3744 B : Natural renames Container.Busy;
3745 L : Natural renames Container.Lock;
3748 if Index > Container.Last then
3749 raise Constraint_Error with "Index is out of range";
3756 Process (Container.Elements.EA (Index));
3768 procedure Update_Element
3769 (Container : in out Vector;
3771 Process : not null access procedure (Element : in out Element_Type))
3774 if Position.Container = null then
3775 raise Constraint_Error with "Position cursor has no element";
3776 elsif Position.Container /= Container'Unrestricted_Access then
3777 raise Program_Error with "Position cursor denotes wrong container";
3779 Update_Element (Container, Position.Index, Process);
3788 (Stream : not null access Root_Stream_Type'Class;
3792 Count_Type'Base'Write (Stream, Length (Container));
3794 for J in Index_Type'First .. Container.Last loop
3795 Element_Type'Write (Stream, Container.Elements.EA (J));
3800 (Stream : not null access Root_Stream_Type'Class;
3804 raise Program_Error with "attempt to stream vector cursor";
3808 (Stream : not null access Root_Stream_Type'Class;
3809 Item : Reference_Type)
3812 raise Program_Error with "attempt to stream reference";
3816 (Stream : not null access Root_Stream_Type'Class;
3817 Item : Constant_Reference_Type)
3820 raise Program_Error with "attempt to stream reference";
3823 end Ada.Containers.Vectors;