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-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Generic_Array_Sort
;
31 with Ada
.Unchecked_Deallocation
;
33 with System
; use type System
.Address
;
35 package body Ada
.Containers
.Vectors
is
38 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
40 type Iterator
is new Limited_Controlled
and
41 Vector_Iterator_Interfaces
.Reversible_Iterator
with
43 Container
: Vector_Access
;
44 Index
: Index_Type
'Base;
47 overriding
procedure Finalize
(Object
: in out Iterator
);
49 overriding
function First
(Object
: Iterator
) return Cursor
;
50 overriding
function Last
(Object
: Iterator
) return Cursor
;
52 overriding
function Next
54 Position
: Cursor
) return Cursor
;
56 overriding
function Previous
58 Position
: Cursor
) return Cursor
;
64 function "&" (Left
, Right
: Vector
) return Vector
is
65 LN
: constant Count_Type
:= Length
(Left
);
66 RN
: constant Count_Type
:= Length
(Right
);
67 N
: Count_Type
'Base; -- length of result
68 J
: Count_Type
'Base; -- for computing intermediate index values
69 Last
: Index_Type
'Base; -- Last index of result
72 -- We decide that the capacity of the result is the sum of the lengths
73 -- of the vector parameters. We could decide to make it larger, but we
74 -- have no basis for knowing how much larger, so we just allocate the
75 -- minimum amount of storage.
77 -- Here we handle the easy cases first, when one of the vector
78 -- parameters is empty. (We say "easy" because there's nothing to
79 -- compute, that can potentially overflow.)
87 RE
: Elements_Array
renames
88 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
89 Elements
: constant Elements_Access
:=
90 new Elements_Type
'(Right.Last, RE);
92 return (Controlled with Elements, Right.Last, 0, 0);
98 LE : Elements_Array renames
99 Left.Elements.EA (Index_Type'First .. Left.Last);
100 Elements : constant Elements_Access :=
101 new Elements_Type'(Left
.Last
, LE
);
103 return (Controlled
with Elements
, Left
.Last
, 0, 0);
108 -- Neither of the vector parameters is empty, so must compute the length
109 -- of the result vector and its last index. (This is the harder case,
110 -- because our computations must avoid overflow.)
112 -- There are two constraints we need to satisfy. The first constraint is
113 -- that a container cannot have more than Count_Type'Last elements, so
114 -- we must check the sum of the combined lengths. Note that we cannot
115 -- simply add the lengths, because of the possibility of overflow.
117 if LN
> Count_Type
'Last - RN
then
118 raise Constraint_Error
with "new length is out of range";
121 -- It is now safe compute the length of the new vector, without fear of
126 -- The second constraint is that the new Last index value cannot
127 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
128 -- Count_Type'Base as the type for intermediate values.
130 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
132 -- We perform a two-part test. First we determine whether the
133 -- computed Last value lies in the base range of the type, and then
134 -- determine whether it lies in the range of the index (sub)type.
136 -- Last must satisfy this relation:
137 -- First + Length - 1 <= Last
139 -- First - 1 <= Last - Length
140 -- Which can rewrite as:
141 -- No_Index <= Last - Length
143 if Index_Type'Base'Last
- Index_Type
'Base (N
) < No_Index
then
144 raise Constraint_Error
with "new length is out of range";
147 -- We now know that the computed value of Last is within the base
148 -- range of the type, so it is safe to compute its value:
150 Last
:= No_Index
+ Index_Type
'Base (N
);
152 -- Finally we test whether the value is within the range of the
153 -- generic actual index subtype:
155 if Last
> Index_Type
'Last then
156 raise Constraint_Error
with "new length is out of range";
159 elsif Index_Type
'First <= 0 then
161 -- Here we can compute Last directly, in the normal way. We know that
162 -- No_Index is less than 0, so there is no danger of overflow when
163 -- adding the (positive) value of length.
165 J
:= Count_Type
'Base (No_Index
) + N
; -- Last
167 if J
> Count_Type
'Base (Index_Type
'Last) then
168 raise Constraint_Error
with "new length is out of range";
171 -- We know that the computed value (having type Count_Type) of Last
172 -- is within the range of the generic actual index subtype, so it is
173 -- safe to convert to Index_Type:
175 Last
:= Index_Type
'Base (J
);
178 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
179 -- must test the length indirectly (by working backwards from the
180 -- largest possible value of Last), in order to prevent overflow.
182 J
:= Count_Type
'Base (Index_Type
'Last) - N
; -- No_Index
184 if J
< Count_Type
'Base (No_Index
) then
185 raise Constraint_Error
with "new length is out of range";
188 -- We have determined that the result length would not create a Last
189 -- index value outside of the range of Index_Type, so we can now
190 -- safely compute its value.
192 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + N
);
196 LE
: Elements_Array
renames
197 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
198 RE
: Elements_Array
renames
199 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
200 Elements
: constant Elements_Access
:=
201 new Elements_Type
'(Last, LE & RE);
203 return (Controlled with Elements, Last, 0, 0);
207 function "&" (Left : Vector; Right : Element_Type) return Vector is
209 -- We decide that the capacity of the result is the sum of the lengths
210 -- of the parameters. We could decide to make it larger, but we have no
211 -- basis for knowing how much larger, so we just allocate the minimum
212 -- amount of storage.
214 -- Handle easy case first, when the vector parameter (Left) is empty
216 if Left.Is_Empty then
218 Elements : constant Elements_Access :=
220 (Last
=> Index_Type
'First,
221 EA
=> (others => Right
));
224 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
228 -- The vector parameter is not empty, so we must compute the length of
229 -- the result vector and its last index, but in such a way that overflow
230 -- is avoided. We must satisfy two constraints: the new length cannot
231 -- exceed Count_Type'Last, and the new Last index cannot exceed
234 if Left
.Length
= Count_Type
'Last then
235 raise Constraint_Error
with "new length is out of range";
238 if Left
.Last
>= Index_Type
'Last then
239 raise Constraint_Error
with "new length is out of range";
243 Last
: constant Index_Type
:= Left
.Last
+ 1;
244 LE
: Elements_Array
renames
245 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
246 Elements
: constant Elements_Access
:=
247 new Elements_Type
'(Last => Last, EA => LE & Right);
249 return (Controlled with Elements, Last, 0, 0);
253 function "&" (Left : Element_Type; Right : Vector) return Vector is
255 -- We decide that the capacity of the result is the sum of the lengths
256 -- of the parameters. We could decide to make it larger, but we have no
257 -- basis for knowing how much larger, so we just allocate the minimum
258 -- amount of storage.
260 -- Handle easy case first, when the vector parameter (Right) is empty
262 if Right.Is_Empty then
264 Elements : constant Elements_Access :=
266 (Last
=> Index_Type
'First,
267 EA
=> (others => Left
));
269 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
273 -- The vector parameter is not empty, so we must compute the length of
274 -- the result vector and its last index, but in such a way that overflow
275 -- is avoided. We must satisfy two constraints: the new length cannot
276 -- exceed Count_Type'Last, and the new Last index cannot exceed
279 if Right
.Length
= Count_Type
'Last then
280 raise Constraint_Error
with "new length is out of range";
283 if Right
.Last
>= Index_Type
'Last then
284 raise Constraint_Error
with "new length is out of range";
288 Last
: constant Index_Type
:= Right
.Last
+ 1;
290 RE
: Elements_Array
renames
291 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
293 Elements
: constant Elements_Access
:=
299 return (Controlled with Elements, Last, 0, 0);
303 function "&" (Left, Right : Element_Type) return Vector is
305 -- We decide that the capacity of the result is the sum of the lengths
306 -- of the parameters. We could decide to make it larger, but we have no
307 -- basis for knowing how much larger, so we just allocate the minimum
308 -- amount of storage.
310 -- We must compute the length of the result vector and its last index,
311 -- but in such a way that overflow is avoided. We must satisfy two
312 -- constraints: the new length cannot exceed Count_Type'Last (here, we
313 -- know that that condition is satisfied), and the new Last index cannot
314 -- exceed Index_Type'Last.
316 if Index_Type'First >= Index_Type'Last then
317 raise Constraint_Error with "new length is out of range";
321 Last : constant Index_Type := Index_Type'First + 1;
323 Elements : constant Elements_Access :=
326 EA
=> (Left
, Right
));
329 return (Controlled
with Elements
, Last
, 0, 0);
337 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
338 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
339 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
341 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
342 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
347 if Left
'Address = Right
'Address then
351 if Left
.Last
/= Right
.Last
then
355 -- Per AI05-0022, the container implementation is required to detect
356 -- element tampering by a generic actual subprogram.
365 for J
in Index_Type
range Index_Type
'First .. Left
.Last
loop
366 if Left
.Elements
.EA
(J
) /= Right
.Elements
.EA
(J
) then
395 procedure Adjust
(Container
: in out Vector
) is
397 if Container
.Last
= No_Index
then
398 Container
.Elements
:= null;
403 L
: constant Index_Type
:= Container
.Last
;
404 EA
: Elements_Array
renames
405 Container
.Elements
.EA
(Index_Type
'First .. L
);
408 Container
.Elements
:= null;
412 -- Note: it may seem that the following assignment to Container.Last
413 -- is useless, since we assign it to L below. However this code is
414 -- used in case 'new Elements_Type' below raises an exception, to
415 -- keep Container in a consistent state.
417 Container
.Last
:= No_Index
;
418 Container
.Elements
:= new Elements_Type
'(L, EA);
423 procedure Adjust (Control : in out Reference_Control_Type) is
425 if Control.Container /= null then
427 C : Vector renames Control.Container.all;
428 B : Natural renames C.Busy;
429 L : Natural renames C.Lock;
441 procedure Append (Container : in out Vector; New_Item : Vector) is
443 if Is_Empty (New_Item) then
445 elsif Container.Last = Index_Type'Last then
446 raise Constraint_Error with "vector is already at its maximum length";
448 Insert (Container, Container.Last + 1, New_Item);
453 (Container : in out Vector;
454 New_Item : Element_Type;
455 Count : Count_Type := 1)
460 elsif Container.Last = Index_Type'Last then
461 raise Constraint_Error with "vector is already at its maximum length";
463 Insert (Container, Container.Last + 1, New_Item, Count);
471 procedure Assign (Target : in out Vector; Source : Vector) is
473 if Target'Address = Source'Address then
477 Target.Append (Source);
485 function Capacity (Container : Vector) return Count_Type is
487 if Container.Elements = null then
490 return Container.Elements.EA'Length;
498 procedure Clear (Container : in out Vector) is
500 if Container.Busy > 0 then
501 raise Program_Error with
502 "attempt to tamper with cursors (vector is busy)";
504 Container.Last := No_Index;
508 ------------------------
509 -- Constant_Reference --
510 ------------------------
512 function Constant_Reference
513 (Container : aliased Vector;
514 Position : Cursor) return Constant_Reference_Type
517 if Position.Container = null then
518 raise Constraint_Error with "Position cursor has no element";
521 if Position.Container /= Container'Unrestricted_Access then
522 raise Program_Error with "Position cursor denotes wrong container";
525 if Position.Index > Position.Container.Last then
526 raise Constraint_Error with "Position cursor is out of range";
530 C : Vector renames Position.Container.all;
531 B : Natural renames C.Busy;
532 L : Natural renames C.Lock;
534 return R : constant Constant_Reference_Type :=
535 (Element => Container.Elements.EA (Position.Index)'Access,
536 Control => (Controlled with Container'Unrestricted_Access))
542 end Constant_Reference;
544 function Constant_Reference
545 (Container : aliased Vector;
546 Index : Index_Type) return Constant_Reference_Type
549 if Index > Container.Last then
550 raise Constraint_Error with "Index is out of range";
553 C : Vector renames Container'Unrestricted_Access.all;
554 B : Natural renames C.Busy;
555 L : Natural renames C.Lock;
557 return R : constant Constant_Reference_Type :=
558 (Element => Container.Elements.EA (Index)'Access,
559 Control => (Controlled with Container'Unrestricted_Access))
566 end Constant_Reference;
574 Item : Element_Type) return Boolean
577 return Find_Index (Container, Item) /= No_Index;
586 Capacity : Count_Type := 0) return Vector
594 elsif Capacity >= Source.Length then
598 raise Capacity_Error with
599 "Requested capacity is less than Source length";
602 return Target : Vector do
603 Target.Reserve_Capacity (C);
604 Target.Assign (Source);
613 (Container : in out Vector;
614 Index : Extended_Index;
615 Count : Count_Type := 1)
617 Old_Last : constant Index_Type'Base := Container.Last;
618 New_Last : Index_Type'Base;
619 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
620 J : Index_Type'Base; -- first index of items that slide down
623 -- Delete removes items from the vector, the number of which is the
624 -- minimum of the specified Count and the items (if any) that exist from
625 -- Index to Container.Last. There are no constraints on the specified
626 -- value of Count (it can be larger than what's available at this
627 -- position in the vector, for example), but there are constraints on
628 -- the allowed values of the Index.
630 -- As a precondition on the generic actual Index_Type, the base type
631 -- must include Index_Type'Pred (Index_Type'First); this is the value
632 -- that Container.Last assumes when the vector is empty. However, we do
633 -- not allow that as the value for Index when specifying which items
634 -- should be deleted, so we must manually check. (That the user is
635 -- allowed to specify the value at all here is a consequence of the
636 -- declaration of the Extended_Index subtype, which includes the values
637 -- in the base range that immediately precede and immediately follow the
638 -- values in the Index_Type.)
640 if Index < Index_Type'First then
641 raise Constraint_Error with "Index is out of range (too small)";
644 -- We do allow a value greater than Container.Last to be specified as
645 -- the Index, but only if it's immediately greater. This allows the
646 -- corner case of deleting no items from the back end of the vector to
647 -- be treated as a no-op. (It is assumed that specifying an index value
648 -- greater than Last + 1 indicates some deeper flaw in the caller's
649 -- algorithm, so that case is treated as a proper error.)
651 if Index > Old_Last then
652 if Index > Old_Last + 1 then
653 raise Constraint_Error with "Index is out of range (too large)";
659 -- Here and elsewhere we treat deleting 0 items from the container as a
660 -- no-op, even when the container is busy, so we simply return.
666 -- The tampering bits exist to prevent an item from being deleted (or
667 -- otherwise harmfully manipulated) while it is being visited. Query,
668 -- Update, and Iterate increment the busy count on entry, and decrement
669 -- the count on exit. Delete checks the count to determine whether it is
670 -- being called while the associated callback procedure is executing.
672 if Container.Busy > 0 then
673 raise Program_Error with
674 "attempt to tamper with cursors (vector is busy)";
677 -- We first calculate what's available for deletion starting at
678 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
679 -- Count_Type'Base as the type for intermediate values. (See function
680 -- Length for more information.)
682 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
683 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
685 Count2 := Count_Type'Base (Old_Last - Index + 1);
688 -- If more elements are requested (Count) for deletion than are
689 -- available (Count2) for deletion beginning at Index, then everything
690 -- from Index is deleted. There are no elements to slide down, and so
691 -- all we need to do is set the value of Container.Last.
693 if Count >= Count2 then
694 Container.Last := Index - 1;
698 -- There are some elements aren't being deleted (the requested count was
699 -- less than the available count), so we must slide them down to
700 -- Index. We first calculate the index values of the respective array
701 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
702 -- type for intermediate calculations. For the elements that slide down,
703 -- index value New_Last is the last index value of their new home, and
704 -- index value J is the first index of their old home.
706 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
707 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
708 J
:= Index
+ Index_Type
'Base (Count
);
710 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
711 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
714 -- The internal elements array isn't guaranteed to exist unless we have
715 -- elements, but we have that guarantee here because we know we have
716 -- elements to slide. The array index values for each slice have
717 -- already been determined, so we just slide down to Index the elements
718 -- that weren't deleted.
721 EA
: Elements_Array
renames Container
.Elements
.EA
;
723 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
724 Container
.Last
:= New_Last
;
729 (Container
: in out Vector
;
730 Position
: in out Cursor
;
731 Count
: Count_Type
:= 1)
733 pragma Warnings
(Off
, Position
);
736 if Position
.Container
= null then
737 raise Constraint_Error
with "Position cursor has no element";
739 elsif Position
.Container
/= Container
'Unrestricted_Access then
740 raise Program_Error
with "Position cursor denotes wrong container";
742 elsif Position
.Index
> Container
.Last
then
743 raise Program_Error
with "Position index is out of range";
746 Delete
(Container
, Position
.Index
, Count
);
747 Position
:= No_Element
;
755 procedure Delete_First
756 (Container
: in out Vector
;
757 Count
: Count_Type
:= 1)
763 elsif Count
>= Length
(Container
) then
768 Delete
(Container
, Index_Type
'First, Count
);
776 procedure Delete_Last
777 (Container
: in out Vector
;
778 Count
: Count_Type
:= 1)
781 -- It is not permitted to delete items while the container is busy (for
782 -- example, we're in the middle of a passive iteration). However, we
783 -- always treat deleting 0 items as a no-op, even when we're busy, so we
784 -- simply return without checking.
790 -- The tampering bits exist to prevent an item from being deleted (or
791 -- otherwise harmfully manipulated) while it is being visited. Query,
792 -- Update, and Iterate increment the busy count on entry, and decrement
793 -- the count on exit. Delete_Last checks the count to determine whether
794 -- it is being called while the associated callback procedure is
797 if Container
.Busy
> 0 then
798 raise Program_Error
with
799 "attempt to tamper with cursors (vector is busy)";
802 -- There is no restriction on how large Count can be when deleting
803 -- items. If it is equal or greater than the current length, then this
804 -- is equivalent to clearing the vector. (In particular, there's no need
805 -- for us to actually calculate the new value for Last.)
807 -- If the requested count is less than the current length, then we must
808 -- calculate the new value for Last. For the type we use the widest of
809 -- Index_Type'Base and Count_Type'Base for the intermediate values of
810 -- our calculation. (See the comments in Length for more information.)
812 if Count
>= Container
.Length
then
813 Container
.Last
:= No_Index
;
815 elsif Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
816 Container.Last := Container.Last - Index_Type'Base (Count);
820 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
830 Index : Index_Type) return Element_Type
833 if Index > Container.Last then
834 raise Constraint_Error with "Index is out of range";
836 return Container.Elements.EA (Index);
840 function Element (Position : Cursor) return Element_Type is
842 if Position.Container = null then
843 raise Constraint_Error with "Position cursor has no element";
844 elsif Position.Index > Position.Container.Last then
845 raise Constraint_Error with "Position cursor is out of range";
847 return Position.Container.Elements.EA (Position.Index);
855 procedure Finalize (Container : in out Vector) is
856 X : Elements_Access := Container.Elements;
859 if Container.Busy > 0 then
860 raise Program_Error with
861 "attempt to tamper with cursors (vector is busy)";
864 Container.Elements := null;
865 Container.Last := No_Index;
870 procedure Finalize (Object : in out Iterator) is
871 B : Natural renames Object.Container.Busy;
876 procedure Finalize (Control : in out Reference_Control_Type) is
878 if Control.Container /= null then
880 C : Vector renames Control.Container.all;
881 B : Natural renames C.Busy;
882 L : Natural renames C.Lock;
888 Control.Container := null;
899 Position : Cursor := No_Element) return Cursor
902 if Position.Container /= null then
903 if Position.Container /= Container'Unrestricted_Access then
904 raise Program_Error with "Position cursor denotes wrong container";
907 if Position.Index > Container.Last then
908 raise Program_Error with "Position index is out of range";
912 -- Per AI05-0022, the container implementation is required to detect
913 -- element tampering by a generic actual subprogram.
916 B : Natural renames Container'Unrestricted_Access.Busy;
917 L : Natural renames Container'Unrestricted_Access.Lock;
919 Result : Index_Type'Base;
926 for J in Position.Index .. Container.Last loop
927 if Container.Elements.EA (J) = Item then
936 if Result = No_Index then
939 return Cursor'(Container
'Unrestricted_Access, Result
);
957 Index
: Index_Type
:= Index_Type
'First) return Extended_Index
959 B
: Natural renames Container
'Unrestricted_Access.Busy
;
960 L
: Natural renames Container
'Unrestricted_Access.Lock
;
962 Result
: Index_Type
'Base;
965 -- Per AI05-0022, the container implementation is required to detect
966 -- element tampering by a generic actual subprogram.
972 for Indx
in Index
.. Container
.Last
loop
973 if Container
.Elements
.EA
(Indx
) = Item
then
995 function First
(Container
: Vector
) return Cursor
is
997 if Is_Empty
(Container
) then
1000 return (Container
'Unrestricted_Access, Index_Type
'First);
1004 function First
(Object
: Iterator
) return Cursor
is
1006 -- The value of the iterator object's Index component influences the
1007 -- behavior of the First (and Last) selector function.
1009 -- When the Index component is No_Index, this means the iterator
1010 -- object was constructed without a start expression, in which case the
1011 -- (forward) iteration starts from the (logical) beginning of the entire
1012 -- sequence of items (corresponding to Container.First, for a forward
1015 -- Otherwise, this is iteration over a partial sequence of items.
1016 -- When the Index component isn't No_Index, the iterator object was
1017 -- constructed with a start expression, that specifies the position
1018 -- from which the (forward) partial iteration begins.
1020 if Object
.Index
= No_Index
then
1021 return First
(Object
.Container
.all);
1023 return Cursor
'(Object.Container, Object.Index);
1031 function First_Element (Container : Vector) return Element_Type is
1033 if Container.Last = No_Index then
1034 raise Constraint_Error with "Container is empty";
1036 return Container.Elements.EA (Index_Type'First);
1044 function First_Index (Container : Vector) return Index_Type is
1045 pragma Unreferenced (Container);
1047 return Index_Type'First;
1050 ---------------------
1051 -- Generic_Sorting --
1052 ---------------------
1054 package body Generic_Sorting is
1060 function Is_Sorted (Container : Vector) return Boolean is
1062 if Container.Last <= Index_Type'First then
1066 -- Per AI05-0022, the container implementation is required to detect
1067 -- element tampering by a generic actual subprogram.
1070 EA : Elements_Array renames Container.Elements.EA;
1072 B : Natural renames Container'Unrestricted_Access.Busy;
1073 L : Natural renames Container'Unrestricted_Access.Lock;
1082 for J in Index_Type'First .. Container.Last - 1 loop
1083 if EA (J + 1) < EA (J) then
1106 procedure Merge (Target, Source : in out Vector) is
1107 I : Index_Type'Base := Target.Last;
1108 J : Index_Type'Base;
1111 -- The semantics of Merge changed slightly per AI05-0021. It was
1112 -- originally the case that if Target and Source denoted the same
1113 -- container object, then the GNAT implementation of Merge did
1114 -- nothing. However, it was argued that RM05 did not precisely
1115 -- specify the semantics for this corner case. The decision of the
1116 -- ARG was that if Target and Source denote the same non-empty
1117 -- container object, then Program_Error is raised.
1119 if Source.Last < Index_Type'First then -- Source is empty
1123 if Target'Address = Source'Address then
1124 raise Program_Error with
1125 "Target and Source denote same non-empty container";
1128 if Target.Last < Index_Type'First then -- Target is empty
1129 Move (Target => Target, Source => Source);
1133 if Source.Busy > 0 then
1134 raise Program_Error with
1135 "attempt to tamper with cursors (vector is busy)";
1138 Target.Set_Length (Length (Target) + Length (Source));
1140 -- Per AI05-0022, the container implementation is required to detect
1141 -- element tampering by a generic actual subprogram.
1144 TA : Elements_Array renames Target.Elements.EA;
1145 SA : Elements_Array renames Source.Elements.EA;
1147 TB : Natural renames Target.Busy;
1148 TL : Natural renames Target.Lock;
1150 SB : Natural renames Source.Busy;
1151 SL : Natural renames Source.Lock;
1161 while Source.Last >= Index_Type'First loop
1162 pragma Assert (Source.Last <= Index_Type'First
1163 or else not (SA (Source.Last) <
1164 SA (Source.Last - 1)));
1166 if I < Index_Type'First then
1167 TA (Index_Type'First .. J) :=
1168 SA (Index_Type'First .. Source.Last);
1170 Source.Last := No_Index;
1174 pragma Assert (I <= Index_Type'First
1175 or else not (TA (I) < TA (I - 1)));
1177 if SA (Source.Last) < TA (I) then
1182 TA (J) := SA (Source.Last);
1183 Source.Last := Source.Last - 1;
1211 procedure Sort (Container : in out Vector) is
1213 new Generic_Array_Sort
1214 (Index_Type => Index_Type,
1215 Element_Type => Element_Type,
1216 Array_Type => Elements_Array,
1220 if Container.Last <= Index_Type'First then
1224 -- The exception behavior for the vector container must match that
1225 -- for the list container, so we check for cursor tampering here
1226 -- (which will catch more things) instead of for element tampering
1227 -- (which will catch fewer things). It's true that the elements of
1228 -- this vector container could be safely moved around while (say) an
1229 -- iteration is taking place (iteration only increments the busy
1230 -- counter), and so technically all we would need here is a test for
1231 -- element tampering (indicated by the lock counter), that's simply
1232 -- an artifact of our array-based implementation. Logically Sort
1233 -- requires a check for cursor tampering.
1235 if Container.Busy > 0 then
1236 raise Program_Error with
1237 "attempt to tamper with cursors (vector is busy)";
1240 -- Per AI05-0022, the container implementation is required to detect
1241 -- element tampering by a generic actual subprogram.
1244 B : Natural renames Container.Busy;
1245 L : Natural renames Container.Lock;
1251 Sort (Container.Elements.EA (Index_Type'First .. Container.Last));
1264 end Generic_Sorting;
1270 function Has_Element (Position : Cursor) return Boolean is
1272 return Position /= No_Element;
1280 (Container : in out Vector;
1281 Before : Extended_Index;
1282 New_Item : Element_Type;
1283 Count : Count_Type := 1)
1285 Old_Length : constant Count_Type := Container.Length;
1287 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1288 New_Length : Count_Type'Base; -- sum of current length and Count
1289 New_Last : Index_Type'Base; -- last index of vector after insertion
1291 Index : Index_Type'Base; -- scratch for intermediate values
1292 J : Count_Type'Base; -- scratch
1294 New_Capacity : Count_Type'Base; -- length of new, expanded array
1295 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1296 Dst : Elements_Access; -- new, expanded internal array
1299 -- As a precondition on the generic actual Index_Type, the base type
1300 -- must include Index_Type'Pred (Index_Type'First); this is the value
1301 -- that Container.Last assumes when the vector is empty. However, we do
1302 -- not allow that as the value for Index when specifying where the new
1303 -- items should be inserted, so we must manually check. (That the user
1304 -- is allowed to specify the value at all here is a consequence of the
1305 -- declaration of the Extended_Index subtype, which includes the values
1306 -- in the base range that immediately precede and immediately follow the
1307 -- values in the Index_Type.)
1309 if Before < Index_Type'First then
1310 raise Constraint_Error with
1311 "Before index is out of range (too small)";
1314 -- We do allow a value greater than Container.Last to be specified as
1315 -- the Index, but only if it's immediately greater. This allows for the
1316 -- case of appending items to the back end of the vector. (It is assumed
1317 -- that specifying an index value greater than Last + 1 indicates some
1318 -- deeper flaw in the caller's algorithm, so that case is treated as a
1321 if Before > Container.Last and then Before > Container.Last + 1 then
1322 raise Constraint_Error with
1323 "Before index is out of range (too large)";
1326 -- We treat inserting 0 items into the container as a no-op, even when
1327 -- the container is busy, so we simply return.
1333 -- There are two constraints we need to satisfy. The first constraint is
1334 -- that a container cannot have more than Count_Type'Last elements, so
1335 -- we must check the sum of the current length and the insertion count.
1336 -- Note: we cannot simply add these values, because of the possibility
1339 if Old_Length > Count_Type'Last - Count then
1340 raise Constraint_Error with "Count is out of range";
1343 -- It is now safe compute the length of the new vector, without fear of
1346 New_Length := Old_Length + Count;
1348 -- The second constraint is that the new Last index value cannot exceed
1349 -- Index_Type'Last. In each branch below, we calculate the maximum
1350 -- length (computed from the range of values in Index_Type), and then
1351 -- compare the new length to the maximum length. If the new length is
1352 -- acceptable, then we compute the new last index from that.
1354 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1356 -- We have to handle the case when there might be more values in the
1357 -- range of Index_Type than in the range of Count_Type.
1359 if Index_Type
'First <= 0 then
1361 -- We know that No_Index (the same as Index_Type'First - 1) is
1362 -- less than 0, so it is safe to compute the following sum without
1363 -- fear of overflow.
1365 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
1367 if Index
<= Index_Type
'Last then
1369 -- We have determined that range of Index_Type has at least as
1370 -- many values as in Count_Type, so Count_Type'Last is the
1371 -- maximum number of items that are allowed.
1373 Max_Length
:= Count_Type
'Last;
1376 -- The range of Index_Type has fewer values than in Count_Type,
1377 -- so the maximum number of items is computed from the range of
1380 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1384 -- No_Index is equal or greater than 0, so we can safely compute
1385 -- the difference without fear of overflow (which we would have to
1386 -- worry about if No_Index were less than 0, but that case is
1389 if Index_Type
'Last - No_Index
>=
1390 Count_Type
'Pos (Count_Type
'Last)
1392 -- We have determined that range of Index_Type has at least as
1393 -- many values as in Count_Type, so Count_Type'Last is the
1394 -- maximum number of items that are allowed.
1396 Max_Length
:= Count_Type
'Last;
1399 -- The range of Index_Type has fewer values than in Count_Type,
1400 -- so the maximum number of items is computed from the range of
1403 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1407 elsif Index_Type
'First <= 0 then
1409 -- We know that No_Index (the same as Index_Type'First - 1) is less
1410 -- than 0, so it is safe to compute the following sum without fear of
1413 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
1415 if J
<= Count_Type
'Base (Index_Type
'Last) then
1417 -- We have determined that range of Index_Type has at least as
1418 -- many values as in Count_Type, so Count_Type'Last is the maximum
1419 -- number of items that are allowed.
1421 Max_Length
:= Count_Type
'Last;
1424 -- The range of Index_Type has fewer values than Count_Type does,
1425 -- so the maximum number of items is computed from the range of
1429 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1433 -- No_Index is equal or greater than 0, so we can safely compute the
1434 -- difference without fear of overflow (which we would have to worry
1435 -- about if No_Index were less than 0, but that case is handled
1439 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1442 -- We have just computed the maximum length (number of items). We must
1443 -- now compare the requested length to the maximum length, as we do not
1444 -- allow a vector expand beyond the maximum (because that would create
1445 -- an internal array with a last index value greater than
1446 -- Index_Type'Last, with no way to index those elements).
1448 if New_Length
> Max_Length
then
1449 raise Constraint_Error
with "Count is out of range";
1452 -- New_Last is the last index value of the items in the container after
1453 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1454 -- compute its value from the New_Length.
1456 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1457 New_Last := No_Index + Index_Type'Base (New_Length);
1459 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1462 if Container.Elements = null then
1463 pragma Assert (Container.Last = No_Index);
1465 -- This is the simplest case, with which we must always begin: we're
1466 -- inserting items into an empty vector that hasn't allocated an
1467 -- internal array yet. Note that we don't need to check the busy bit
1468 -- here, because an empty container cannot be busy.
1470 -- In order to preserve container invariants, we allocate the new
1471 -- internal array first, before setting the Last index value, in case
1472 -- the allocation fails (which can happen either because there is no
1473 -- storage available, or because element initialization fails).
1475 Container.Elements := new Elements_Type'
1477 EA
=> (others => New_Item
));
1479 -- The allocation of the new, internal array succeeded, so it is now
1480 -- safe to update the Last index, restoring container invariants.
1482 Container
.Last
:= New_Last
;
1487 -- The tampering bits exist to prevent an item from being harmfully
1488 -- manipulated while it is being visited. Query, Update, and Iterate
1489 -- increment the busy count on entry, and decrement the count on
1490 -- exit. Insert checks the count to determine whether it is being called
1491 -- while the associated callback procedure is executing.
1493 if Container
.Busy
> 0 then
1494 raise Program_Error
with
1495 "attempt to tamper with cursors (vector is busy)";
1498 -- An internal array has already been allocated, so we must determine
1499 -- whether there is enough unused storage for the new items.
1501 if New_Length
<= Container
.Elements
.EA
'Length then
1503 -- In this case, we're inserting elements into a vector that has
1504 -- already allocated an internal array, and the existing array has
1505 -- enough unused storage for the new items.
1508 EA
: Elements_Array
renames Container
.Elements
.EA
;
1511 if Before
> Container
.Last
then
1513 -- The new items are being appended to the vector, so no
1514 -- sliding of existing elements is required.
1516 EA
(Before
.. New_Last
) := (others => New_Item
);
1519 -- The new items are being inserted before some existing
1520 -- elements, so we must slide the existing elements up to their
1521 -- new home. We use the wider of Index_Type'Base and
1522 -- Count_Type'Base as the type for intermediate index values.
1524 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1525 Index := Before + Index_Type'Base (Count);
1527 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1530 EA (Index .. New_Last) := EA (Before .. Container.Last);
1531 EA (Before .. Index - 1) := (others => New_Item);
1535 Container.Last := New_Last;
1539 -- In this case, we're inserting elements into a vector that has already
1540 -- allocated an internal array, but the existing array does not have
1541 -- enough storage, so we must allocate a new, longer array. In order to
1542 -- guarantee that the amortized insertion cost is O(1), we always
1543 -- allocate an array whose length is some power-of-two factor of the
1544 -- current array length. (The new array cannot have a length less than
1545 -- the New_Length of the container, but its last index value cannot be
1546 -- greater than Index_Type'Last.)
1548 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1549 while New_Capacity < New_Length loop
1550 if New_Capacity > Count_Type'Last / 2 then
1551 New_Capacity := Count_Type'Last;
1554 New_Capacity := 2 * New_Capacity;
1558 if New_Capacity > Max_Length then
1560 -- We have reached the limit of capacity, so no further expansion
1561 -- will occur. (This is not a problem, as there is never a need to
1562 -- have more capacity than the maximum container length.)
1564 New_Capacity := Max_Length;
1567 -- We have computed the length of the new internal array (and this is
1568 -- what "vector capacity" means), so use that to compute its last index.
1570 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1571 Dst_Last
:= No_Index
+ Index_Type
'Base (New_Capacity
);
1574 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Capacity
);
1577 -- Now we allocate the new, longer internal array. If the allocation
1578 -- fails, we have not changed any container state, so no side-effect
1579 -- will occur as a result of propagating the exception.
1581 Dst
:= new Elements_Type
(Dst_Last
);
1583 -- We have our new internal array. All that needs to be done now is to
1584 -- copy the existing items (if any) from the old array (the "source"
1585 -- array, object SA below) to the new array (the "destination" array,
1586 -- object DA below), and then deallocate the old array.
1589 SA
: Elements_Array
renames Container
.Elements
.EA
; -- source
1590 DA
: Elements_Array
renames Dst
.EA
; -- destination
1593 DA
(Index_Type
'First .. Before
- 1) :=
1594 SA
(Index_Type
'First .. Before
- 1);
1596 if Before
> Container
.Last
then
1597 DA
(Before
.. New_Last
) := (others => New_Item
);
1600 -- The new items are being inserted before some existing elements,
1601 -- so we must slide the existing elements up to their new home.
1603 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1604 Index := Before + Index_Type'Base (Count);
1606 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1609 DA (Before .. Index - 1) := (others => New_Item);
1610 DA (Index .. New_Last) := SA (Before .. Container.Last);
1619 -- We have successfully copied the items onto the new array, so the
1620 -- final thing to do is deallocate the old array.
1623 X : Elements_Access := Container.Elements;
1626 -- We first isolate the old internal array, removing it from the
1627 -- container and replacing it with the new internal array, before we
1628 -- deallocate the old array (which can fail if finalization of
1629 -- elements propagates an exception).
1631 Container.Elements := Dst;
1632 Container.Last := New_Last;
1634 -- The container invariants have been restored, so it is now safe to
1635 -- attempt to deallocate the old array.
1642 (Container : in out Vector;
1643 Before : Extended_Index;
1646 N : constant Count_Type := Length (New_Item);
1647 J : Index_Type'Base;
1650 -- Use Insert_Space to create the "hole" (the destination slice) into
1651 -- which we copy the source items.
1653 Insert_Space (Container, Before, Count => N);
1657 -- There's nothing else to do here (vetting of parameters was
1658 -- performed already in Insert_Space), so we simply return.
1663 -- We calculate the last index value of the destination slice using the
1664 -- wider of Index_Type'Base and count_Type'Base.
1666 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1667 J
:= (Before
- 1) + Index_Type
'Base (N
);
1669 J
:= Index_Type
'Base (Count_Type
'Base (Before
- 1) + N
);
1672 if Container
'Address /= New_Item
'Address then
1674 -- This is the simple case. New_Item denotes an object different
1675 -- from Container, so there's nothing special we need to do to copy
1676 -- the source items to their destination, because all of the source
1677 -- items are contiguous.
1679 Container
.Elements
.EA
(Before
.. J
) :=
1680 New_Item
.Elements
.EA
(Index_Type
'First .. New_Item
.Last
);
1685 -- New_Item denotes the same object as Container, so an insertion has
1686 -- potentially split the source items. The destination is always the
1687 -- range [Before, J], but the source is [Index_Type'First, Before) and
1688 -- (J, Container.Last]. We perform the copy in two steps, using each of
1689 -- the two slices of the source items.
1692 L
: constant Index_Type
'Base := Before
- 1;
1694 subtype Src_Index_Subtype
is Index_Type
'Base range
1695 Index_Type
'First .. L
;
1697 Src
: Elements_Array
renames
1698 Container
.Elements
.EA
(Src_Index_Subtype
);
1700 K
: Index_Type
'Base;
1703 -- We first copy the source items that precede the space we
1704 -- inserted. Index value K is the last index of that portion
1705 -- destination that receives this slice of the source. (If Before
1706 -- equals Index_Type'First, then this first source slice will be
1707 -- empty, which is harmless.)
1709 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1710 K := L + Index_Type'Base (Src'Length);
1712 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1715 Container.Elements.EA (Before .. K) := Src;
1717 if Src'Length = N then
1719 -- The new items were effectively appended to the container, so we
1720 -- have already copied all of the items that need to be copied.
1721 -- We return early here, even though the source slice below is
1722 -- empty (so the assignment would be harmless), because we want to
1723 -- avoid computing J + 1, which will overflow if J equals
1724 -- Index_Type'Base'Last
.
1731 -- Note that we want to avoid computing J + 1 here, in case J equals
1732 -- Index_Type'Base'Last. We prevent that by returning early above,
1733 -- immediately after copying the first slice of the source, and
1734 -- determining that this second slice of the source is empty.
1736 F
: constant Index_Type
'Base := J
+ 1;
1738 subtype Src_Index_Subtype
is Index_Type
'Base range
1739 F
.. Container
.Last
;
1741 Src
: Elements_Array
renames
1742 Container
.Elements
.EA
(Src_Index_Subtype
);
1744 K
: Index_Type
'Base;
1747 -- We next copy the source items that follow the space we inserted.
1748 -- Index value K is the first index of that portion of the
1749 -- destination that receives this slice of the source. (For the
1750 -- reasons given above, this slice is guaranteed to be non-empty.)
1752 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1753 K := F - Index_Type'Base (Src'Length);
1755 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1758 Container.Elements.EA (K .. J) := Src;
1763 (Container : in out Vector;
1767 Index : Index_Type'Base;
1770 if Before.Container /= null
1771 and then Before.Container /= Container'Unrestricted_Access
1773 raise Program_Error with "Before cursor denotes wrong container";
1776 if Is_Empty (New_Item) then
1780 if Before.Container = null or else Before.Index > Container.Last then
1781 if Container.Last = Index_Type'Last then
1782 raise Constraint_Error with
1783 "vector is already at its maximum length";
1786 Index := Container.Last + 1;
1789 Index := Before.Index;
1792 Insert (Container, Index, New_Item);
1796 (Container : in out Vector;
1799 Position : out Cursor)
1801 Index : Index_Type'Base;
1804 if Before.Container /= null
1805 and then Before.Container /= Container'Unrestricted_Access
1807 raise Program_Error with "Before cursor denotes wrong container";
1810 if Is_Empty (New_Item) then
1811 if Before.Container = null or else Before.Index > Container.Last then
1812 Position := No_Element;
1814 Position := (Container'Unrestricted_Access, Before.Index);
1820 if Before.Container = null or else Before.Index > Container.Last then
1821 if Container.Last = Index_Type'Last then
1822 raise Constraint_Error with
1823 "vector is already at its maximum length";
1826 Index := Container.Last + 1;
1829 Index := Before.Index;
1832 Insert (Container, Index, New_Item);
1834 Position := (Container'Unrestricted_Access, Index);
1838 (Container : in out Vector;
1840 New_Item : Element_Type;
1841 Count : Count_Type := 1)
1843 Index : Index_Type'Base;
1846 if Before.Container /= null
1847 and then Before.Container /= Container'Unrestricted_Access
1849 raise Program_Error with "Before cursor denotes wrong container";
1856 if Before.Container = null or else Before.Index > Container.Last then
1857 if Container.Last = Index_Type'Last then
1858 raise Constraint_Error with
1859 "vector is already at its maximum length";
1861 Index := Container.Last + 1;
1865 Index := Before.Index;
1868 Insert (Container, Index, New_Item, Count);
1872 (Container : in out Vector;
1874 New_Item : Element_Type;
1875 Position : out Cursor;
1876 Count : Count_Type := 1)
1878 Index : Index_Type'Base;
1881 if Before.Container /= null
1882 and then Before.Container /= Container'Unrestricted_Access
1884 raise Program_Error with "Before cursor denotes wrong container";
1888 if Before.Container = null or else Before.Index > Container.Last then
1889 Position := No_Element;
1891 Position := (Container'Unrestricted_Access, Before.Index);
1897 if Before.Container = null or else Before.Index > Container.Last then
1898 if Container.Last = Index_Type'Last then
1899 raise Constraint_Error with
1900 "vector is already at its maximum length";
1903 Index := Container.Last + 1;
1906 Index := Before.Index;
1909 Insert (Container, Index, New_Item, Count);
1911 Position := (Container'Unrestricted_Access, Index);
1915 (Container : in out Vector;
1916 Before : Extended_Index;
1917 Count : Count_Type := 1)
1919 New_Item : Element_Type; -- Default-initialized value
1920 pragma Warnings (Off, New_Item);
1923 Insert (Container, Before, New_Item, Count);
1927 (Container : in out Vector;
1929 Position : out Cursor;
1930 Count : Count_Type := 1)
1932 New_Item : Element_Type; -- Default-initialized value
1933 pragma Warnings (Off, New_Item);
1935 Insert (Container, Before, New_Item, Position, Count);
1942 procedure Insert_Space
1943 (Container : in out Vector;
1944 Before : Extended_Index;
1945 Count : Count_Type := 1)
1947 Old_Length : constant Count_Type := Container.Length;
1949 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1950 New_Length : Count_Type'Base; -- sum of current length and Count
1951 New_Last : Index_Type'Base; -- last index of vector after insertion
1953 Index : Index_Type'Base; -- scratch for intermediate values
1954 J : Count_Type'Base; -- scratch
1956 New_Capacity : Count_Type'Base; -- length of new, expanded array
1957 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1958 Dst : Elements_Access; -- new, expanded internal array
1961 -- As a precondition on the generic actual Index_Type, the base type
1962 -- must include Index_Type'Pred (Index_Type'First); this is the value
1963 -- that Container.Last assumes when the vector is empty. However, we do
1964 -- not allow that as the value for Index when specifying where the new
1965 -- items should be inserted, so we must manually check. (That the user
1966 -- is allowed to specify the value at all here is a consequence of the
1967 -- declaration of the Extended_Index subtype, which includes the values
1968 -- in the base range that immediately precede and immediately follow the
1969 -- values in the Index_Type.)
1971 if Before < Index_Type'First then
1972 raise Constraint_Error with
1973 "Before index is out of range (too small)";
1976 -- We do allow a value greater than Container.Last to be specified as
1977 -- the Index, but only if it's immediately greater. This allows for the
1978 -- case of appending items to the back end of the vector. (It is assumed
1979 -- that specifying an index value greater than Last + 1 indicates some
1980 -- deeper flaw in the caller's algorithm, so that case is treated as a
1983 if Before > Container.Last and then Before > Container.Last + 1 then
1984 raise Constraint_Error with
1985 "Before index is out of range (too large)";
1988 -- We treat inserting 0 items into the container as a no-op, even when
1989 -- the container is busy, so we simply return.
1995 -- There are two constraints we need to satisfy. The first constraint is
1996 -- that a container cannot have more than Count_Type'Last elements, so
1997 -- we must check the sum of the current length and the insertion count.
1998 -- Note: we cannot simply add these values, because of the possibility
2001 if Old_Length > Count_Type'Last - Count then
2002 raise Constraint_Error with "Count is out of range";
2005 -- It is now safe compute the length of the new vector, without fear of
2008 New_Length := Old_Length + Count;
2010 -- The second constraint is that the new Last index value cannot exceed
2011 -- Index_Type'Last. In each branch below, we calculate the maximum
2012 -- length (computed from the range of values in Index_Type), and then
2013 -- compare the new length to the maximum length. If the new length is
2014 -- acceptable, then we compute the new last index from that.
2016 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2018 -- We have to handle the case when there might be more values in the
2019 -- range of Index_Type than in the range of Count_Type.
2021 if Index_Type
'First <= 0 then
2023 -- We know that No_Index (the same as Index_Type'First - 1) is
2024 -- less than 0, so it is safe to compute the following sum without
2025 -- fear of overflow.
2027 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
2029 if Index
<= Index_Type
'Last then
2031 -- We have determined that range of Index_Type has at least as
2032 -- many values as in Count_Type, so Count_Type'Last is the
2033 -- maximum number of items that are allowed.
2035 Max_Length
:= Count_Type
'Last;
2038 -- The range of Index_Type has fewer values than in Count_Type,
2039 -- so the maximum number of items is computed from the range of
2042 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2046 -- No_Index is equal or greater than 0, so we can safely compute
2047 -- the difference without fear of overflow (which we would have to
2048 -- worry about if No_Index were less than 0, but that case is
2051 if Index_Type
'Last - No_Index
>=
2052 Count_Type
'Pos (Count_Type
'Last)
2054 -- We have determined that range of Index_Type has at least as
2055 -- many values as in Count_Type, so Count_Type'Last is the
2056 -- maximum number of items that are allowed.
2058 Max_Length
:= Count_Type
'Last;
2061 -- The range of Index_Type has fewer values than in Count_Type,
2062 -- so the maximum number of items is computed from the range of
2065 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2069 elsif Index_Type
'First <= 0 then
2071 -- We know that No_Index (the same as Index_Type'First - 1) is less
2072 -- than 0, so it is safe to compute the following sum without fear of
2075 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
2077 if J
<= Count_Type
'Base (Index_Type
'Last) then
2079 -- We have determined that range of Index_Type has at least as
2080 -- many values as in Count_Type, so Count_Type'Last is the maximum
2081 -- number of items that are allowed.
2083 Max_Length
:= Count_Type
'Last;
2086 -- The range of Index_Type has fewer values than Count_Type does,
2087 -- so the maximum number of items is computed from the range of
2091 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2095 -- No_Index is equal or greater than 0, so we can safely compute the
2096 -- difference without fear of overflow (which we would have to worry
2097 -- about if No_Index were less than 0, but that case is handled
2101 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2104 -- We have just computed the maximum length (number of items). We must
2105 -- now compare the requested length to the maximum length, as we do not
2106 -- allow a vector expand beyond the maximum (because that would create
2107 -- an internal array with a last index value greater than
2108 -- Index_Type'Last, with no way to index those elements).
2110 if New_Length
> Max_Length
then
2111 raise Constraint_Error
with "Count is out of range";
2114 -- New_Last is the last index value of the items in the container after
2115 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2116 -- compute its value from the New_Length.
2118 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2119 New_Last := No_Index + Index_Type'Base (New_Length);
2121 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2124 if Container.Elements = null then
2125 pragma Assert (Container.Last = No_Index);
2127 -- This is the simplest case, with which we must always begin: we're
2128 -- inserting items into an empty vector that hasn't allocated an
2129 -- internal array yet. Note that we don't need to check the busy bit
2130 -- here, because an empty container cannot be busy.
2132 -- In order to preserve container invariants, we allocate the new
2133 -- internal array first, before setting the Last index value, in case
2134 -- the allocation fails (which can happen either because there is no
2135 -- storage available, or because default-valued element
2136 -- initialization fails).
2138 Container.Elements := new Elements_Type (New_Last);
2140 -- The allocation of the new, internal array succeeded, so it is now
2141 -- safe to update the Last index, restoring container invariants.
2143 Container.Last := New_Last;
2148 -- The tampering bits exist to prevent an item from being harmfully
2149 -- manipulated while it is being visited. Query, Update, and Iterate
2150 -- increment the busy count on entry, and decrement the count on
2151 -- exit. Insert checks the count to determine whether it is being called
2152 -- while the associated callback procedure is executing.
2154 if Container.Busy > 0 then
2155 raise Program_Error with
2156 "attempt to tamper with cursors (vector is busy)";
2159 -- An internal array has already been allocated, so we must determine
2160 -- whether there is enough unused storage for the new items.
2162 if New_Last <= Container.Elements.Last then
2164 -- In this case, we're inserting space into a vector that has already
2165 -- allocated an internal array, and the existing array has enough
2166 -- unused storage for the new items.
2169 EA : Elements_Array renames Container.Elements.EA;
2172 if Before <= Container.Last then
2174 -- The space is being inserted before some existing elements,
2175 -- so we must slide the existing elements up to their new
2176 -- home. We use the wider of Index_Type'Base and
2177 -- Count_Type'Base as the type for intermediate index values.
2179 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2180 Index
:= Before
+ Index_Type
'Base (Count
);
2183 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2186 EA
(Index
.. New_Last
) := EA
(Before
.. Container
.Last
);
2190 Container
.Last
:= New_Last
;
2194 -- In this case, we're inserting space into a vector that has already
2195 -- allocated an internal array, but the existing array does not have
2196 -- enough storage, so we must allocate a new, longer array. In order to
2197 -- guarantee that the amortized insertion cost is O(1), we always
2198 -- allocate an array whose length is some power-of-two factor of the
2199 -- current array length. (The new array cannot have a length less than
2200 -- the New_Length of the container, but its last index value cannot be
2201 -- greater than Index_Type'Last.)
2203 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
2204 while New_Capacity
< New_Length
loop
2205 if New_Capacity
> Count_Type
'Last / 2 then
2206 New_Capacity
:= Count_Type
'Last;
2210 New_Capacity
:= 2 * New_Capacity
;
2213 if New_Capacity
> Max_Length
then
2215 -- We have reached the limit of capacity, so no further expansion
2216 -- will occur. (This is not a problem, as there is never a need to
2217 -- have more capacity than the maximum container length.)
2219 New_Capacity
:= Max_Length
;
2222 -- We have computed the length of the new internal array (and this is
2223 -- what "vector capacity" means), so use that to compute its last index.
2225 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2226 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2229 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2232 -- Now we allocate the new, longer internal array. If the allocation
2233 -- fails, we have not changed any container state, so no side-effect
2234 -- will occur as a result of propagating the exception.
2236 Dst := new Elements_Type (Dst_Last);
2238 -- We have our new internal array. All that needs to be done now is to
2239 -- copy the existing items (if any) from the old array (the "source"
2240 -- array, object SA below) to the new array (the "destination" array,
2241 -- object DA below), and then deallocate the old array.
2244 SA : Elements_Array renames Container.Elements.EA; -- source
2245 DA : Elements_Array renames Dst.EA; -- destination
2248 DA (Index_Type'First .. Before - 1) :=
2249 SA (Index_Type'First .. Before - 1);
2251 if Before <= Container.Last then
2253 -- The space is being inserted before some existing elements, so
2254 -- we must slide the existing elements up to their new home.
2256 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2257 Index
:= Before
+ Index_Type
'Base (Count
);
2259 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2262 DA
(Index
.. New_Last
) := SA
(Before
.. Container
.Last
);
2271 -- We have successfully copied the items onto the new array, so the
2272 -- final thing to do is restore invariants, and deallocate the old
2276 X
: Elements_Access
:= Container
.Elements
;
2279 -- We first isolate the old internal array, removing it from the
2280 -- container and replacing it with the new internal array, before we
2281 -- deallocate the old array (which can fail if finalization of
2282 -- elements propagates an exception).
2284 Container
.Elements
:= Dst
;
2285 Container
.Last
:= New_Last
;
2287 -- The container invariants have been restored, so it is now safe to
2288 -- attempt to deallocate the old array.
2294 procedure Insert_Space
2295 (Container
: in out Vector
;
2297 Position
: out Cursor
;
2298 Count
: Count_Type
:= 1)
2300 Index
: Index_Type
'Base;
2303 if Before
.Container
/= null
2304 and then Before
.Container
/= Container
'Unrestricted_Access
2306 raise Program_Error
with "Before cursor denotes wrong container";
2310 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2311 Position
:= No_Element
;
2313 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2319 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2320 if Container
.Last
= Index_Type
'Last then
2321 raise Constraint_Error
with
2322 "vector is already at its maximum length";
2324 Index
:= Container
.Last
+ 1;
2328 Index
:= Before
.Index
;
2331 Insert_Space
(Container
, Index
, Count
=> Count
);
2333 Position
:= (Container
'Unrestricted_Access, Index
);
2340 function Is_Empty
(Container
: Vector
) return Boolean is
2342 return Container
.Last
< Index_Type
'First;
2350 (Container
: Vector
;
2351 Process
: not null access procedure (Position
: Cursor
))
2353 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
2359 for Indx
in Index_Type
'First .. Container
.Last
loop
2360 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
2372 (Container : Vector)
2373 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2375 V : constant Vector_Access := Container'Unrestricted_Access;
2376 B : Natural renames V.Busy;
2379 -- The value of its Index component influences the behavior of the First
2380 -- and Last selector functions of the iterator object. When the Index
2381 -- component is No_Index (as is the case here), this means the iterator
2382 -- object was constructed without a start expression. This is a complete
2383 -- iterator, meaning that the iteration starts from the (logical)
2384 -- beginning of the sequence of items.
2386 -- Note: For a forward iterator, Container.First is the beginning, and
2387 -- for a reverse iterator, Container.Last is the beginning.
2389 return It : constant Iterator :=
2390 (Limited_Controlled with
2399 (Container : Vector;
2401 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2403 V : constant Vector_Access := Container'Unrestricted_Access;
2404 B : Natural renames V.Busy;
2407 -- It was formerly the case that when Start = No_Element, the partial
2408 -- iterator was defined to behave the same as for a complete iterator,
2409 -- and iterate over the entire sequence of items. However, those
2410 -- semantics were unintuitive and arguably error-prone (it is too easy
2411 -- to accidentally create an endless loop), and so they were changed,
2412 -- per the ARG meeting in Denver on 2011/11. However, there was no
2413 -- consensus about what positive meaning this corner case should have,
2414 -- and so it was decided to simply raise an exception. This does imply,
2415 -- however, that it is not possible to use a partial iterator to specify
2416 -- an empty sequence of items.
2418 if Start.Container = null then
2419 raise Constraint_Error with
2420 "Start position for iterator equals No_Element";
2423 if Start.Container /= V then
2424 raise Program_Error with
2425 "Start cursor of Iterate designates wrong vector";
2428 if Start.Index > V.Last then
2429 raise Constraint_Error with
2430 "Start position for iterator equals No_Element";
2433 -- The value of its Index component influences the behavior of the First
2434 -- and Last selector functions of the iterator object. When the Index
2435 -- component is not No_Index (as is the case here), it means that this
2436 -- is a partial iteration, over a subset of the complete sequence of
2437 -- items. The iterator object was constructed with a start expression,
2438 -- indicating the position from which the iteration begins. Note that
2439 -- the start position has the same value irrespective of whether this
2440 -- is a forward or reverse iteration.
2442 return It : constant Iterator :=
2443 (Limited_Controlled with
2445 Index => Start.Index)
2455 function Last (Container : Vector) return Cursor is
2457 if Is_Empty (Container) then
2460 return (Container'Unrestricted_Access, Container.Last);
2464 function Last (Object : Iterator) return Cursor is
2466 -- The value of the iterator object's Index component influences the
2467 -- behavior of the Last (and First) selector function.
2469 -- When the Index component is No_Index, this means the iterator
2470 -- object was constructed without a start expression, in which case the
2471 -- (reverse) iteration starts from the (logical) beginning of the entire
2472 -- sequence (corresponding to Container.Last, for a reverse iterator).
2474 -- Otherwise, this is iteration over a partial sequence of items.
2475 -- When the Index component is not No_Index, the iterator object was
2476 -- constructed with a start expression, that specifies the position
2477 -- from which the (reverse) partial iteration begins.
2479 if Object.Index = No_Index then
2480 return Last (Object.Container.all);
2482 return Cursor'(Object
.Container
, Object
.Index
);
2490 function Last_Element
(Container
: Vector
) return Element_Type
is
2492 if Container
.Last
= No_Index
then
2493 raise Constraint_Error
with "Container is empty";
2495 return Container
.Elements
.EA
(Container
.Last
);
2503 function Last_Index
(Container
: Vector
) return Extended_Index
is
2505 return Container
.Last
;
2512 function Length
(Container
: Vector
) return Count_Type
is
2513 L
: constant Index_Type
'Base := Container
.Last
;
2514 F
: constant Index_Type
:= Index_Type
'First;
2517 -- The base range of the index type (Index_Type'Base) might not include
2518 -- all values for length (Count_Type). Contrariwise, the index type
2519 -- might include values outside the range of length. Hence we use
2520 -- whatever type is wider for intermediate values when calculating
2521 -- length. Note that no matter what the index type is, the maximum
2522 -- length to which a vector is allowed to grow is always the minimum
2523 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2525 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2526 -- to have a base range of -128 .. 127, but the corresponding vector
2527 -- would have lengths in the range 0 .. 255. In this case we would need
2528 -- to use Count_Type'Base for intermediate values.
2530 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2531 -- vector would have a maximum length of 10, but the index values lie
2532 -- outside the range of Count_Type (which is only 32 bits). In this
2533 -- case we would need to use Index_Type'Base for intermediate values.
2535 if Count_Type
'Base'Last >= Index_Type'Pos (Index_Type'Base'Last
) then
2536 return Count_Type
'Base (L
) - Count_Type
'Base (F
) + 1;
2538 return Count_Type
(L
- F
+ 1);
2547 (Target
: in out Vector
;
2548 Source
: in out Vector
)
2551 if Target
'Address = Source
'Address then
2555 if Target
.Busy
> 0 then
2556 raise Program_Error
with
2557 "attempt to tamper with cursors (Target is busy)";
2560 if Source
.Busy
> 0 then
2561 raise Program_Error
with
2562 "attempt to tamper with cursors (Source is busy)";
2566 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
2568 Target
.Elements
:= Source
.Elements
;
2569 Source
.Elements
:= Target_Elements
;
2572 Target
.Last
:= Source
.Last
;
2573 Source
.Last
:= No_Index
;
2580 function Next
(Position
: Cursor
) return Cursor
is
2582 if Position
.Container
= null then
2584 elsif Position
.Index
< Position
.Container
.Last
then
2585 return (Position
.Container
, Position
.Index
+ 1);
2591 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2593 if Position
.Container
= null then
2595 elsif Position
.Container
/= Object
.Container
then
2596 raise Program_Error
with
2597 "Position cursor of Next designates wrong vector";
2599 return Next
(Position
);
2603 procedure Next
(Position
: in out Cursor
) is
2605 if Position
.Container
= null then
2607 elsif Position
.Index
< Position
.Container
.Last
then
2608 Position
.Index
:= Position
.Index
+ 1;
2610 Position
:= No_Element
;
2618 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
2620 Insert
(Container
, Index_Type
'First, New_Item
);
2624 (Container
: in out Vector
;
2625 New_Item
: Element_Type
;
2626 Count
: Count_Type
:= 1)
2629 Insert
(Container
, Index_Type
'First, New_Item
, Count
);
2636 function Previous
(Position
: Cursor
) return Cursor
is
2638 if Position
.Container
= null then
2640 elsif Position
.Index
> Index_Type
'First then
2641 return (Position
.Container
, Position
.Index
- 1);
2647 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2649 if Position
.Container
= null then
2651 elsif Position
.Container
/= Object
.Container
then
2652 raise Program_Error
with
2653 "Position cursor of Previous designates wrong vector";
2655 return Previous
(Position
);
2659 procedure Previous
(Position
: in out Cursor
) is
2661 if Position
.Container
= null then
2663 elsif Position
.Index
> Index_Type
'First then
2664 Position
.Index
:= Position
.Index
- 1;
2666 Position
:= No_Element
;
2674 procedure Query_Element
2675 (Container
: Vector
;
2677 Process
: not null access procedure (Element
: Element_Type
))
2679 V
: Vector
renames Container
'Unrestricted_Access.all;
2680 B
: Natural renames V
.Busy
;
2681 L
: Natural renames V
.Lock
;
2684 if Index
> Container
.Last
then
2685 raise Constraint_Error
with "Index is out of range";
2692 Process
(V
.Elements
.EA
(Index
));
2704 procedure Query_Element
2706 Process
: not null access procedure (Element
: Element_Type
))
2709 if Position
.Container
= null then
2710 raise Constraint_Error
with "Position cursor has no element";
2712 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
2721 (Stream
: not null access Root_Stream_Type
'Class;
2722 Container
: out Vector
)
2724 Length
: Count_Type
'Base;
2725 Last
: Index_Type
'Base := No_Index
;
2730 Count_Type
'Base'Read (Stream, Length);
2732 if Length > Capacity (Container) then
2733 Reserve_Capacity (Container, Capacity => Length);
2736 for J in Count_Type range 1 .. Length loop
2738 Element_Type'Read (Stream, Container.Elements.EA (Last));
2739 Container.Last := Last;
2744 (Stream : not null access Root_Stream_Type'Class;
2745 Position : out Cursor)
2748 raise Program_Error with "attempt to stream vector cursor";
2752 (Stream : not null access Root_Stream_Type'Class;
2753 Item : out Reference_Type)
2756 raise Program_Error with "attempt to stream reference";
2760 (Stream : not null access Root_Stream_Type'Class;
2761 Item : out Constant_Reference_Type)
2764 raise Program_Error with "attempt to stream reference";
2772 (Container : aliased in out Vector;
2773 Position : Cursor) return Reference_Type
2776 if Position.Container = null then
2777 raise Constraint_Error with "Position cursor has no element";
2780 if Position.Container /= Container'Unrestricted_Access then
2781 raise Program_Error with "Position cursor denotes wrong container";
2784 if Position.Index > Position.Container.Last then
2785 raise Constraint_Error with "Position cursor is out of range";
2789 C : Vector renames Position.Container.all;
2790 B : Natural renames C.Busy;
2791 L : Natural renames C.Lock;
2793 return R : constant Reference_Type :=
2794 (Element => Container.Elements.EA (Position.Index)'Access,
2795 Control => (Controlled with Position.Container))
2804 (Container : aliased in out Vector;
2805 Index : Index_Type) return Reference_Type
2808 if Index > Container.Last then
2809 raise Constraint_Error with "Index is out of range";
2813 C : Vector renames Container'Unrestricted_Access.all;
2814 B : Natural renames C.Busy;
2815 L : Natural renames C.Lock;
2817 return R : constant Reference_Type :=
2818 (Element => Container.Elements.EA (Index)'Access,
2819 Control => (Controlled with Container'Unrestricted_Access))
2828 ---------------------
2829 -- Replace_Element --
2830 ---------------------
2832 procedure Replace_Element
2833 (Container : in out Vector;
2835 New_Item : Element_Type)
2838 if Index > Container.Last then
2839 raise Constraint_Error with "Index is out of range";
2840 elsif Container.Lock > 0 then
2841 raise Program_Error with
2842 "attempt to tamper with elements (vector is locked)";
2844 Container.Elements.EA (Index) := New_Item;
2846 end Replace_Element;
2848 procedure Replace_Element
2849 (Container : in out Vector;
2851 New_Item : Element_Type)
2854 if Position.Container = null then
2855 raise Constraint_Error with "Position cursor has no element";
2857 elsif Position.Container /= Container'Unrestricted_Access then
2858 raise Program_Error with "Position cursor denotes wrong container";
2860 elsif Position.Index > Container.Last then
2861 raise Constraint_Error with "Position cursor is out of range";
2864 if Container.Lock > 0 then
2865 raise Program_Error with
2866 "attempt to tamper with elements (vector is locked)";
2869 Container.Elements.EA (Position.Index) := New_Item;
2871 end Replace_Element;
2873 ----------------------
2874 -- Reserve_Capacity --
2875 ----------------------
2877 procedure Reserve_Capacity
2878 (Container : in out Vector;
2879 Capacity : Count_Type)
2881 N : constant Count_Type := Length (Container);
2883 Index : Count_Type'Base;
2884 Last : Index_Type'Base;
2887 -- Reserve_Capacity can be used to either expand the storage available
2888 -- for elements (this would be its typical use, in anticipation of
2889 -- future insertion), or to trim back storage. In the latter case,
2890 -- storage can only be trimmed back to the limit of the container
2891 -- length. Note that Reserve_Capacity neither deletes (active) elements
2892 -- nor inserts elements; it only affects container capacity, never
2893 -- container length.
2895 if Capacity = 0 then
2897 -- This is a request to trim back storage, to the minimum amount
2898 -- possible given the current state of the container.
2902 -- The container is empty, so in this unique case we can
2903 -- deallocate the entire internal array. Note that an empty
2904 -- container can never be busy, so there's no need to check the
2908 X : Elements_Access := Container.Elements;
2911 -- First we remove the internal array from the container, to
2912 -- handle the case when the deallocation raises an exception.
2914 Container.Elements := null;
2916 -- Container invariants have been restored, so it is now safe
2917 -- to attempt to deallocate the internal array.
2922 elsif N < Container.Elements.EA'Length then
2924 -- The container is not empty, and the current length is less than
2925 -- the current capacity, so there's storage available to trim. In
2926 -- this case, we allocate a new internal array having a length
2927 -- that exactly matches the number of items in the
2928 -- container. (Reserve_Capacity does not delete active elements,
2929 -- so this is the best we can do with respect to minimizing
2932 if Container.Busy > 0 then
2933 raise Program_Error with
2934 "attempt to tamper with cursors (vector is busy)";
2938 subtype Src_Index_Subtype is Index_Type'Base range
2939 Index_Type'First .. Container.Last;
2941 Src : Elements_Array renames
2942 Container.Elements.EA (Src_Index_Subtype);
2944 X : Elements_Access := Container.Elements;
2947 -- Although we have isolated the old internal array that we're
2948 -- going to deallocate, we don't deallocate it until we have
2949 -- successfully allocated a new one. If there is an exception
2950 -- during allocation (either because there is not enough
2951 -- storage, or because initialization of the elements fails),
2952 -- we let it propagate without causing any side-effect.
2954 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
2956 -- We have successfully allocated a new internal array (with a
2957 -- smaller length than the old one, and containing a copy of
2958 -- just the active elements in the container), so it is now
2959 -- safe to attempt to deallocate the old array. The old array
2960 -- has been isolated, and container invariants have been
2961 -- restored, so if the deallocation fails (because finalization
2962 -- of the elements fails), we simply let it propagate.
2971 -- Reserve_Capacity can be used to expand the storage available for
2972 -- elements, but we do not let the capacity grow beyond the number of
2973 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2974 -- to refer to the elements with an index value greater than
2975 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2976 -- the Last index value of the new internal array, in a way that avoids
2977 -- any possibility of overflow.
2979 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2981 -- We perform a two-part test. First we determine whether the
2982 -- computed Last value lies in the base range of the type, and then
2983 -- determine whether it lies in the range of the index (sub)type.
2985 -- Last must satisfy this relation:
2986 -- First + Length - 1 <= Last
2987 -- We regroup terms:
2988 -- First - 1 <= Last - Length
2989 -- Which can rewrite as:
2990 -- No_Index <= Last - Length
2992 if Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
then
2993 raise Constraint_Error
with "Capacity is out of range";
2996 -- We now know that the computed value of Last is within the base
2997 -- range of the type, so it is safe to compute its value:
2999 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
3001 -- Finally we test whether the value is within the range of the
3002 -- generic actual index subtype:
3004 if Last
> Index_Type
'Last then
3005 raise Constraint_Error
with "Capacity is out of range";
3008 elsif Index_Type
'First <= 0 then
3010 -- Here we can compute Last directly, in the normal way. We know that
3011 -- No_Index is less than 0, so there is no danger of overflow when
3012 -- adding the (positive) value of Capacity.
3014 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
3016 if Index
> Count_Type
'Base (Index_Type
'Last) then
3017 raise Constraint_Error
with "Capacity is out of range";
3020 -- We know that the computed value (having type Count_Type) of Last
3021 -- is within the range of the generic actual index subtype, so it is
3022 -- safe to convert to Index_Type:
3024 Last
:= Index_Type
'Base (Index
);
3027 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3028 -- must test the length indirectly (by working backwards from the
3029 -- largest possible value of Last), in order to prevent overflow.
3031 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
3033 if Index
< Count_Type
'Base (No_Index
) then
3034 raise Constraint_Error
with "Capacity is out of range";
3037 -- We have determined that the value of Capacity would not create a
3038 -- Last index value outside of the range of Index_Type, so we can now
3039 -- safely compute its value.
3041 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
3044 -- The requested capacity is non-zero, but we don't know yet whether
3045 -- this is a request for expansion or contraction of storage.
3047 if Container
.Elements
= null then
3049 -- The container is empty (it doesn't even have an internal array),
3050 -- so this represents a request to allocate (expand) storage having
3051 -- the given capacity.
3053 Container
.Elements
:= new Elements_Type
(Last
);
3057 if Capacity
<= N
then
3059 -- This is a request to trim back storage, but only to the limit of
3060 -- what's already in the container. (Reserve_Capacity never deletes
3061 -- active elements, it only reclaims excess storage.)
3063 if N
< Container
.Elements
.EA
'Length then
3065 -- The container is not empty (because the requested capacity is
3066 -- positive, and less than or equal to the container length), and
3067 -- the current length is less than the current capacity, so
3068 -- there's storage available to trim. In this case, we allocate a
3069 -- new internal array having a length that exactly matches the
3070 -- number of items in the container.
3072 if Container
.Busy
> 0 then
3073 raise Program_Error
with
3074 "attempt to tamper with cursors (vector is busy)";
3078 subtype Src_Index_Subtype
is Index_Type
'Base range
3079 Index_Type
'First .. Container
.Last
;
3081 Src
: Elements_Array
renames
3082 Container
.Elements
.EA
(Src_Index_Subtype
);
3084 X
: Elements_Access
:= Container
.Elements
;
3087 -- Although we have isolated the old internal array that we're
3088 -- going to deallocate, we don't deallocate it until we have
3089 -- successfully allocated a new one. If there is an exception
3090 -- during allocation (either because there is not enough
3091 -- storage, or because initialization of the elements fails),
3092 -- we let it propagate without causing any side-effect.
3094 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
3096 -- We have successfully allocated a new internal array (with a
3097 -- smaller length than the old one, and containing a copy of
3098 -- just the active elements in the container), so it is now
3099 -- safe to attempt to deallocate the old array. The old array
3100 -- has been isolated, and container invariants have been
3101 -- restored, so if the deallocation fails (because finalization
3102 -- of the elements fails), we simply let it propagate.
3111 -- The requested capacity is larger than the container length (the
3112 -- number of active elements). Whether this represents a request for
3113 -- expansion or contraction of the current capacity depends on what the
3114 -- current capacity is.
3116 if Capacity = Container.Elements.EA'Length then
3118 -- The requested capacity matches the existing capacity, so there's
3119 -- nothing to do here. We treat this case as a no-op, and simply
3120 -- return without checking the busy bit.
3125 -- There is a change in the capacity of a non-empty container, so a new
3126 -- internal array will be allocated. (The length of the new internal
3127 -- array could be less or greater than the old internal array. We know
3128 -- only that the length of the new internal array is greater than the
3129 -- number of active elements in the container.) We must check whether
3130 -- the container is busy before doing anything else.
3132 if Container.Busy > 0 then
3133 raise Program_Error with
3134 "attempt to tamper with cursors (vector is busy)";
3137 -- We now allocate a new internal array, having a length different from
3138 -- its current value.
3141 E : Elements_Access := new Elements_Type (Last);
3144 -- We have successfully allocated the new internal array. We first
3145 -- attempt to copy the existing elements from the old internal array
3146 -- ("src" elements) onto the new internal array ("tgt" elements).
3149 subtype Index_Subtype is Index_Type'Base range
3150 Index_Type'First .. Container.Last;
3152 Src : Elements_Array renames
3153 Container.Elements.EA (Index_Subtype);
3155 Tgt : Elements_Array renames E.EA (Index_Subtype);
3166 -- We have successfully copied the existing elements onto the new
3167 -- internal array, so now we can attempt to deallocate the old one.
3170 X : Elements_Access := Container.Elements;
3173 -- First we isolate the old internal array, and replace it in the
3174 -- container with the new internal array.
3176 Container.Elements := E;
3178 -- Container invariants have been restored, so it is now safe to
3179 -- attempt to deallocate the old internal array.
3184 end Reserve_Capacity;
3186 ----------------------
3187 -- Reverse_Elements --
3188 ----------------------
3190 procedure Reverse_Elements (Container : in out Vector) is
3192 if Container.Length <= 1 then
3196 -- The exception behavior for the vector container must match that for
3197 -- the list container, so we check for cursor tampering here (which will
3198 -- catch more things) instead of for element tampering (which will catch
3199 -- fewer things). It's true that the elements of this vector container
3200 -- could be safely moved around while (say) an iteration is taking place
3201 -- (iteration only increments the busy counter), and so technically
3202 -- all we would need here is a test for element tampering (indicated
3203 -- by the lock counter), that's simply an artifact of our array-based
3204 -- implementation. Logically Reverse_Elements requires a check for
3205 -- cursor tampering.
3207 if Container.Busy > 0 then
3208 raise Program_Error with
3209 "attempt to tamper with cursors (vector is busy)";
3215 E : Elements_Type renames Container.Elements.all;
3218 K := Index_Type'First;
3219 J := Container.Last;
3222 EK : constant Element_Type := E.EA (K);
3224 E.EA (K) := E.EA (J);
3232 end Reverse_Elements;
3238 function Reverse_Find
3239 (Container : Vector;
3240 Item : Element_Type;
3241 Position : Cursor := No_Element) return Cursor
3243 Last : Index_Type'Base;
3246 if Position.Container /= null
3247 and then Position.Container /= Container'Unrestricted_Access
3249 raise Program_Error with "Position cursor denotes wrong container";
3253 (if Position.Container = null or else Position.Index > Container.Last
3255 else Position.Index);
3257 -- Per AI05-0022, the container implementation is required to detect
3258 -- element tampering by a generic actual subprogram.
3261 B : Natural renames Container'Unrestricted_Access.Busy;
3262 L : Natural renames Container'Unrestricted_Access.Lock;
3264 Result : Index_Type'Base;
3271 for Indx in reverse Index_Type'First .. Last loop
3272 if Container.Elements.EA (Indx) = Item then
3281 if Result = No_Index then
3284 return Cursor'(Container
'Unrestricted_Access, Result
);
3295 ------------------------
3296 -- Reverse_Find_Index --
3297 ------------------------
3299 function Reverse_Find_Index
3300 (Container
: Vector
;
3301 Item
: Element_Type
;
3302 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
3304 B
: Natural renames Container
'Unrestricted_Access.Busy
;
3305 L
: Natural renames Container
'Unrestricted_Access.Lock
;
3307 Last
: constant Index_Type
'Base :=
3308 Index_Type
'Min (Container
.Last
, Index
);
3310 Result
: Index_Type
'Base;
3313 -- Per AI05-0022, the container implementation is required to detect
3314 -- element tampering by a generic actual subprogram.
3320 for Indx
in reverse Index_Type
'First .. Last
loop
3321 if Container
.Elements
.EA
(Indx
) = Item
then
3337 end Reverse_Find_Index
;
3339 ---------------------
3340 -- Reverse_Iterate --
3341 ---------------------
3343 procedure Reverse_Iterate
3344 (Container
: Vector
;
3345 Process
: not null access procedure (Position
: Cursor
))
3347 V
: Vector
renames Container
'Unrestricted_Access.all;
3348 B
: Natural renames V
.Busy
;
3354 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
3355 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
3364 end Reverse_Iterate;
3370 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
3371 Count : constant Count_Type'Base := Container.Length - Length;
3374 -- Set_Length allows the user to set the length explicitly, instead
3375 -- of implicitly as a side-effect of deletion or insertion. If the
3376 -- requested length is less than the current length, this is equivalent
3377 -- to deleting items from the back end of the vector. If the requested
3378 -- length is greater than the current length, then this is equivalent
3379 -- to inserting "space" (nonce items) at the end.
3382 Container.Delete_Last (Count);
3384 elsif Container.Last >= Index_Type'Last then
3385 raise Constraint_Error with "vector is already at its maximum length";
3388 Container.Insert_Space (Container.Last + 1, -Count);
3396 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3398 if I > Container.Last then
3399 raise Constraint_Error with "I index is out of range";
3402 if J > Container.Last then
3403 raise Constraint_Error with "J index is out of range";
3410 if Container.Lock > 0 then
3411 raise Program_Error with
3412 "attempt to tamper with elements (vector is locked)";
3416 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3418 Container.Elements.EA (I) := Container.Elements.EA (J);
3419 Container.Elements.EA (J) := EI_Copy;
3423 procedure Swap (Container : in out Vector; I, J : Cursor) is
3425 if I.Container = null then
3426 raise Constraint_Error with "I cursor has no element";
3428 elsif J.Container = null then
3429 raise Constraint_Error with "J cursor has no element";
3431 elsif I.Container /= Container'Unrestricted_Access then
3432 raise Program_Error with "I cursor denotes wrong container";
3434 elsif J.Container /= Container'Unrestricted_Access then
3435 raise Program_Error with "J cursor denotes wrong container";
3438 Swap (Container, I.Index, J.Index);
3447 (Container : Vector;
3448 Index : Extended_Index) return Cursor
3451 if Index not in Index_Type'First .. Container.Last then
3454 return (Container'Unrestricted_Access, Index);
3462 function To_Index (Position : Cursor) return Extended_Index is
3464 if Position.Container = null then
3466 elsif Position.Index <= Position.Container.Last then
3467 return Position.Index;
3477 function To_Vector (Length : Count_Type) return Vector is
3478 Index : Count_Type'Base;
3479 Last : Index_Type'Base;
3480 Elements : Elements_Access;
3484 return Empty_Vector;
3487 -- We create a vector object with a capacity that matches the specified
3488 -- Length, but we do not allow the vector capacity (the length of the
3489 -- internal array) to exceed the number of values in Index_Type'Range
3490 -- (otherwise, there would be no way to refer to those components via an
3491 -- index). We must therefore check whether the specified Length would
3492 -- create a Last index value greater than Index_Type'Last.
3494 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
3496 -- We perform a two-part test. First we determine whether the
3497 -- computed Last value lies in the base range of the type, and then
3498 -- determine whether it lies in the range of the index (sub)type.
3500 -- Last must satisfy this relation:
3501 -- First + Length - 1 <= Last
3502 -- We regroup terms:
3503 -- First - 1 <= Last - Length
3504 -- Which can rewrite as:
3505 -- No_Index <= Last - Length
3507 if Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index then
3508 raise Constraint_Error with "Length is out of range";
3511 -- We now know that the computed value of Last is within the base
3512 -- range of the type, so it is safe to compute its value:
3514 Last := No_Index + Index_Type'Base (Length);
3516 -- Finally we test whether the value is within the range of the
3517 -- generic actual index subtype:
3519 if Last > Index_Type'Last then
3520 raise Constraint_Error with "Length is out of range";
3523 elsif Index_Type'First <= 0 then
3525 -- Here we can compute Last directly, in the normal way. We know that
3526 -- No_Index is less than 0, so there is no danger of overflow when
3527 -- adding the (positive) value of Length.
3529 Index := Count_Type'Base (No_Index) + Length; -- Last
3531 if Index > Count_Type'Base (Index_Type'Last) then
3532 raise Constraint_Error with "Length is out of range";
3535 -- We know that the computed value (having type Count_Type) of Last
3536 -- is within the range of the generic actual index subtype, so it is
3537 -- safe to convert to Index_Type:
3539 Last := Index_Type'Base (Index);
3542 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3543 -- must test the length indirectly (by working backwards from the
3544 -- largest possible value of Last), in order to prevent overflow.
3546 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3548 if Index < Count_Type'Base (No_Index) then
3549 raise Constraint_Error with "Length is out of range";
3552 -- We have determined that the value of Length would not create a
3553 -- Last index value outside of the range of Index_Type, so we can now
3554 -- safely compute its value.
3556 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3559 Elements := new Elements_Type (Last);
3561 return Vector'(Controlled
with Elements
, Last
, 0, 0);
3565 (New_Item
: Element_Type
;
3566 Length
: Count_Type
) return Vector
3568 Index
: Count_Type
'Base;
3569 Last
: Index_Type
'Base;
3570 Elements
: Elements_Access
;
3574 return Empty_Vector
;
3577 -- We create a vector object with a capacity that matches the specified
3578 -- Length, but we do not allow the vector capacity (the length of the
3579 -- internal array) to exceed the number of values in Index_Type'Range
3580 -- (otherwise, there would be no way to refer to those components via an
3581 -- index). We must therefore check whether the specified Length would
3582 -- create a Last index value greater than Index_Type'Last.
3584 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3586 -- We perform a two-part test. First we determine whether the
3587 -- computed Last value lies in the base range of the type, and then
3588 -- determine whether it lies in the range of the index (sub)type.
3590 -- Last must satisfy this relation:
3591 -- First + Length - 1 <= Last
3592 -- We regroup terms:
3593 -- First - 1 <= Last - Length
3594 -- Which can rewrite as:
3595 -- No_Index <= Last - Length
3597 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
3598 raise Constraint_Error
with "Length is out of range";
3601 -- We now know that the computed value of Last is within the base
3602 -- range of the type, so it is safe to compute its value:
3604 Last
:= No_Index
+ Index_Type
'Base (Length
);
3606 -- Finally we test whether the value is within the range of the
3607 -- generic actual index subtype:
3609 if Last
> Index_Type
'Last then
3610 raise Constraint_Error
with "Length is out of range";
3613 elsif Index_Type
'First <= 0 then
3615 -- Here we can compute Last directly, in the normal way. We know that
3616 -- No_Index is less than 0, so there is no danger of overflow when
3617 -- adding the (positive) value of Length.
3619 Index
:= Count_Type
'Base (No_Index
) + Length
; -- same value as V.Last
3621 if Index
> Count_Type
'Base (Index_Type
'Last) then
3622 raise Constraint_Error
with "Length is out of range";
3625 -- We know that the computed value (having type Count_Type) of Last
3626 -- is within the range of the generic actual index subtype, so it is
3627 -- safe to convert to Index_Type:
3629 Last
:= Index_Type
'Base (Index
);
3632 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3633 -- must test the length indirectly (by working backwards from the
3634 -- largest possible value of Last), in order to prevent overflow.
3636 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
3638 if Index
< Count_Type
'Base (No_Index
) then
3639 raise Constraint_Error
with "Length is out of range";
3642 -- We have determined that the value of Length would not create a
3643 -- Last index value outside of the range of Index_Type, so we can now
3644 -- safely compute its value.
3646 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
3649 Elements
:= new Elements_Type
'(Last, EA => (others => New_Item));
3651 return Vector'(Controlled
with Elements
, Last
, 0, 0);
3654 --------------------
3655 -- Update_Element --
3656 --------------------
3658 procedure Update_Element
3659 (Container
: in out Vector
;
3661 Process
: not null access procedure (Element
: in out Element_Type
))
3663 B
: Natural renames Container
.Busy
;
3664 L
: Natural renames Container
.Lock
;
3667 if Index
> Container
.Last
then
3668 raise Constraint_Error
with "Index is out of range";
3675 Process
(Container
.Elements
.EA
(Index
));
3687 procedure Update_Element
3688 (Container
: in out Vector
;
3690 Process
: not null access procedure (Element
: in out Element_Type
))
3693 if Position
.Container
= null then
3694 raise Constraint_Error
with "Position cursor has no element";
3695 elsif Position
.Container
/= Container
'Unrestricted_Access then
3696 raise Program_Error
with "Position cursor denotes wrong container";
3698 Update_Element
(Container
, Position
.Index
, Process
);
3707 (Stream
: not null access Root_Stream_Type
'Class;
3711 Count_Type
'Base'Write (Stream, Length (Container));
3713 for J in Index_Type'First .. Container.Last loop
3714 Element_Type'Write (Stream, Container.Elements.EA (J));
3719 (Stream : not null access Root_Stream_Type'Class;
3723 raise Program_Error with "attempt to stream vector cursor";
3727 (Stream : not null access Root_Stream_Type'Class;
3728 Item : Reference_Type)
3731 raise Program_Error with "attempt to stream reference";
3735 (Stream : not null access Root_Stream_Type'Class;
3736 Item : Constant_Reference_Type)
3739 raise Program_Error with "attempt to stream reference";
3742 end Ada.Containers.Vectors;