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 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
1392 elsif Index_Type
'First <= 0 then
1394 -- We know that No_Index (the same as Index_Type'First - 1) is less
1395 -- than 0, so it is safe to compute the following sum without fear of
1398 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
1400 if J
<= Count_Type
'Base (Index_Type
'Last) then
1402 -- We have determined that range of Index_Type has at least as
1403 -- many values as in Count_Type, so Count_Type'Last is the maximum
1404 -- number of items that are allowed.
1406 Max_Length
:= Count_Type
'Last;
1409 -- The range of Index_Type has fewer values than Count_Type does,
1410 -- so the maximum number of items is computed from the range of
1414 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1418 -- No_Index is equal or greater than 0, so we can safely compute the
1419 -- difference without fear of overflow (which we would have to worry
1420 -- about if No_Index were less than 0, but that case is handled
1424 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
1427 -- We have just computed the maximum length (number of items). We must
1428 -- now compare the requested length to the maximum length, as we do not
1429 -- allow a vector expand beyond the maximum (because that would create
1430 -- an internal array with a last index value greater than
1431 -- Index_Type'Last, with no way to index those elements).
1433 if New_Length
> Max_Length
then
1434 raise Constraint_Error
with "Count is out of range";
1437 -- New_Last is the last index value of the items in the container after
1438 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1439 -- compute its value from the New_Length.
1441 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1442 New_Last := No_Index + Index_Type'Base (New_Length);
1444 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1447 if Container.Elements = null then
1448 pragma Assert (Container.Last = No_Index);
1450 -- This is the simplest case, with which we must always begin: we're
1451 -- inserting items into an empty vector that hasn't allocated an
1452 -- internal array yet. Note that we don't need to check the busy bit
1453 -- here, because an empty container cannot be busy.
1455 -- In order to preserve container invariants, we allocate the new
1456 -- internal array first, before setting the Last index value, in case
1457 -- the allocation fails (which can happen either because there is no
1458 -- storage available, or because element initialization fails).
1460 Container.Elements := new Elements_Type'
1462 EA
=> (others => New_Item
));
1464 -- The allocation of the new, internal array succeeded, so it is now
1465 -- safe to update the Last index, restoring container invariants.
1467 Container
.Last
:= New_Last
;
1472 -- The tampering bits exist to prevent an item from being harmfully
1473 -- manipulated while it is being visited. Query, Update, and Iterate
1474 -- increment the busy count on entry, and decrement the count on
1475 -- exit. Insert checks the count to determine whether it is being called
1476 -- while the associated callback procedure is executing.
1478 if Container
.Busy
> 0 then
1479 raise Program_Error
with
1480 "attempt to tamper with cursors (vector is busy)";
1483 -- An internal array has already been allocated, so we must determine
1484 -- whether there is enough unused storage for the new items.
1486 if New_Length
<= Container
.Elements
.EA
'Length then
1488 -- In this case, we're inserting elements into a vector that has
1489 -- already allocated an internal array, and the existing array has
1490 -- enough unused storage for the new items.
1493 EA
: Elements_Array
renames Container
.Elements
.EA
;
1496 if Before
> Container
.Last
then
1498 -- The new items are being appended to the vector, so no
1499 -- sliding of existing elements is required.
1501 EA
(Before
.. New_Last
) := (others => New_Item
);
1504 -- The new items are being inserted before some existing
1505 -- elements, so we must slide the existing elements up to their
1506 -- new home. We use the wider of Index_Type'Base and
1507 -- Count_Type'Base as the type for intermediate index values.
1509 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1510 Index := Before + Index_Type'Base (Count);
1512 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1515 EA (Index .. New_Last) := EA (Before .. Container.Last);
1516 EA (Before .. Index - 1) := (others => New_Item);
1520 Container.Last := New_Last;
1524 -- In this case, we're inserting elements into a vector that has already
1525 -- allocated an internal array, but the existing array does not have
1526 -- enough storage, so we must allocate a new, longer array. In order to
1527 -- guarantee that the amortized insertion cost is O(1), we always
1528 -- allocate an array whose length is some power-of-two factor of the
1529 -- current array length. (The new array cannot have a length less than
1530 -- the New_Length of the container, but its last index value cannot be
1531 -- greater than Index_Type'Last.)
1533 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length);
1534 while New_Capacity < New_Length loop
1535 if New_Capacity > Count_Type'Last / 2 then
1536 New_Capacity := Count_Type'Last;
1539 New_Capacity := 2 * New_Capacity;
1543 if New_Capacity > Max_Length then
1545 -- We have reached the limit of capacity, so no further expansion
1546 -- will occur. (This is not a problem, as there is never a need to
1547 -- have more capacity than the maximum container length.)
1549 New_Capacity := Max_Length;
1552 -- We have computed the length of the new internal array (and this is
1553 -- what "vector capacity" means), so use that to compute its last index.
1555 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1556 Dst_Last
:= No_Index
+ Index_Type
'Base (New_Capacity
);
1559 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Capacity
);
1562 -- Now we allocate the new, longer internal array. If the allocation
1563 -- fails, we have not changed any container state, so no side-effect
1564 -- will occur as a result of propagating the exception.
1566 Dst
:= new Elements_Type
(Dst_Last
);
1568 -- We have our new internal array. All that needs to be done now is to
1569 -- copy the existing items (if any) from the old array (the "source"
1570 -- array, object SA below) to the new array (the "destination" array,
1571 -- object DA below), and then deallocate the old array.
1574 SA
: Elements_Array
renames Container
.Elements
.EA
; -- source
1575 DA
: Elements_Array
renames Dst
.EA
; -- destination
1578 DA
(Index_Type
'First .. Before
- 1) :=
1579 SA
(Index_Type
'First .. Before
- 1);
1581 if Before
> Container
.Last
then
1582 DA
(Before
.. New_Last
) := (others => New_Item
);
1585 -- The new items are being inserted before some existing elements,
1586 -- so we must slide the existing elements up to their new home.
1588 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1589 Index := Before + Index_Type'Base (Count);
1591 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1594 DA (Before .. Index - 1) := (others => New_Item);
1595 DA (Index .. New_Last) := SA (Before .. Container.Last);
1604 -- We have successfully copied the items onto the new array, so the
1605 -- final thing to do is deallocate the old array.
1608 X : Elements_Access := Container.Elements;
1611 -- We first isolate the old internal array, removing it from the
1612 -- container and replacing it with the new internal array, before we
1613 -- deallocate the old array (which can fail if finalization of
1614 -- elements propagates an exception).
1616 Container.Elements := Dst;
1617 Container.Last := New_Last;
1619 -- The container invariants have been restored, so it is now safe to
1620 -- attempt to deallocate the old array.
1627 (Container : in out Vector;
1628 Before : Extended_Index;
1631 N : constant Count_Type := Length (New_Item);
1632 J : Index_Type'Base;
1635 -- Use Insert_Space to create the "hole" (the destination slice) into
1636 -- which we copy the source items.
1638 Insert_Space (Container, Before, Count => N);
1642 -- There's nothing else to do here (vetting of parameters was
1643 -- performed already in Insert_Space), so we simply return.
1648 -- We calculate the last index value of the destination slice using the
1649 -- wider of Index_Type'Base and count_Type'Base.
1651 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1652 J
:= (Before
- 1) + Index_Type
'Base (N
);
1654 J
:= Index_Type
'Base (Count_Type
'Base (Before
- 1) + N
);
1657 if Container
'Address /= New_Item
'Address then
1659 -- This is the simple case. New_Item denotes an object different
1660 -- from Container, so there's nothing special we need to do to copy
1661 -- the source items to their destination, because all of the source
1662 -- items are contiguous.
1664 Container
.Elements
.EA
(Before
.. J
) :=
1665 New_Item
.Elements
.EA
(Index_Type
'First .. New_Item
.Last
);
1670 -- New_Item denotes the same object as Container, so an insertion has
1671 -- potentially split the source items. The destination is always the
1672 -- range [Before, J], but the source is [Index_Type'First, Before) and
1673 -- (J, Container.Last]. We perform the copy in two steps, using each of
1674 -- the two slices of the source items.
1677 L
: constant Index_Type
'Base := Before
- 1;
1679 subtype Src_Index_Subtype
is Index_Type
'Base range
1680 Index_Type
'First .. L
;
1682 Src
: Elements_Array
renames
1683 Container
.Elements
.EA
(Src_Index_Subtype
);
1685 K
: Index_Type
'Base;
1688 -- We first copy the source items that precede the space we
1689 -- inserted. Index value K is the last index of that portion
1690 -- destination that receives this slice of the source. (If Before
1691 -- equals Index_Type'First, then this first source slice will be
1692 -- empty, which is harmless.)
1694 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1695 K := L + Index_Type'Base (Src'Length);
1697 K := Index_Type'Base (Count_Type'Base (L) + Src'Length);
1700 Container.Elements.EA (Before .. K) := Src;
1702 if Src'Length = N then
1704 -- The new items were effectively appended to the container, so we
1705 -- have already copied all of the items that need to be copied.
1706 -- We return early here, even though the source slice below is
1707 -- empty (so the assignment would be harmless), because we want to
1708 -- avoid computing J + 1, which will overflow if J equals
1709 -- Index_Type'Base'Last
.
1716 -- Note that we want to avoid computing J + 1 here, in case J equals
1717 -- Index_Type'Base'Last. We prevent that by returning early above,
1718 -- immediately after copying the first slice of the source, and
1719 -- determining that this second slice of the source is empty.
1721 F
: constant Index_Type
'Base := J
+ 1;
1723 subtype Src_Index_Subtype
is Index_Type
'Base range
1724 F
.. Container
.Last
;
1726 Src
: Elements_Array
renames
1727 Container
.Elements
.EA
(Src_Index_Subtype
);
1729 K
: Index_Type
'Base;
1732 -- We next copy the source items that follow the space we inserted.
1733 -- Index value K is the first index of that portion of the
1734 -- destination that receives this slice of the source. (For the
1735 -- reasons given above, this slice is guaranteed to be non-empty.)
1737 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1738 K := F - Index_Type'Base (Src'Length);
1740 K := Index_Type'Base (Count_Type'Base (F) - Src'Length);
1743 Container.Elements.EA (K .. J) := Src;
1748 (Container : in out Vector;
1752 Index : Index_Type'Base;
1755 if Before.Container /= null
1756 and then Before.Container /= Container'Unrestricted_Access
1758 raise Program_Error with "Before cursor denotes wrong container";
1761 if Is_Empty (New_Item) then
1765 if Before.Container = null or else Before.Index > Container.Last then
1766 if Container.Last = Index_Type'Last then
1767 raise Constraint_Error with
1768 "vector is already at its maximum length";
1771 Index := Container.Last + 1;
1774 Index := Before.Index;
1777 Insert (Container, Index, New_Item);
1781 (Container : in out Vector;
1784 Position : out Cursor)
1786 Index : Index_Type'Base;
1789 if Before.Container /= null
1790 and then Before.Container /= Container'Unrestricted_Access
1792 raise Program_Error with "Before cursor denotes wrong container";
1795 if Is_Empty (New_Item) then
1796 if Before.Container = null or else Before.Index > Container.Last then
1797 Position := No_Element;
1799 Position := (Container'Unrestricted_Access, Before.Index);
1805 if Before.Container = null or else Before.Index > Container.Last then
1806 if Container.Last = Index_Type'Last then
1807 raise Constraint_Error with
1808 "vector is already at its maximum length";
1811 Index := Container.Last + 1;
1814 Index := Before.Index;
1817 Insert (Container, Index, New_Item);
1819 Position := (Container'Unrestricted_Access, Index);
1823 (Container : in out Vector;
1825 New_Item : Element_Type;
1826 Count : Count_Type := 1)
1828 Index : Index_Type'Base;
1831 if Before.Container /= null
1832 and then Before.Container /= Container'Unrestricted_Access
1834 raise Program_Error with "Before cursor denotes wrong container";
1841 if Before.Container = null or else Before.Index > Container.Last then
1842 if Container.Last = Index_Type'Last then
1843 raise Constraint_Error with
1844 "vector is already at its maximum length";
1846 Index := Container.Last + 1;
1850 Index := Before.Index;
1853 Insert (Container, Index, New_Item, Count);
1857 (Container : in out Vector;
1859 New_Item : Element_Type;
1860 Position : out Cursor;
1861 Count : Count_Type := 1)
1863 Index : Index_Type'Base;
1866 if Before.Container /= null
1867 and then Before.Container /= Container'Unrestricted_Access
1869 raise Program_Error with "Before cursor denotes wrong container";
1873 if Before.Container = null or else Before.Index > Container.Last then
1874 Position := No_Element;
1876 Position := (Container'Unrestricted_Access, Before.Index);
1882 if Before.Container = null or else Before.Index > Container.Last then
1883 if Container.Last = Index_Type'Last then
1884 raise Constraint_Error with
1885 "vector is already at its maximum length";
1888 Index := Container.Last + 1;
1891 Index := Before.Index;
1894 Insert (Container, Index, New_Item, Count);
1896 Position := (Container'Unrestricted_Access, Index);
1900 (Container : in out Vector;
1901 Before : Extended_Index;
1902 Count : Count_Type := 1)
1904 New_Item : Element_Type; -- Default-initialized value
1905 pragma Warnings (Off, New_Item);
1908 Insert (Container, Before, New_Item, Count);
1912 (Container : in out Vector;
1914 Position : out Cursor;
1915 Count : Count_Type := 1)
1917 New_Item : Element_Type; -- Default-initialized value
1918 pragma Warnings (Off, New_Item);
1920 Insert (Container, Before, New_Item, Position, Count);
1927 procedure Insert_Space
1928 (Container : in out Vector;
1929 Before : Extended_Index;
1930 Count : Count_Type := 1)
1932 Old_Length : constant Count_Type := Container.Length;
1934 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1935 New_Length : Count_Type'Base; -- sum of current length and Count
1936 New_Last : Index_Type'Base; -- last index of vector after insertion
1938 Index : Index_Type'Base; -- scratch for intermediate values
1939 J : Count_Type'Base; -- scratch
1941 New_Capacity : Count_Type'Base; -- length of new, expanded array
1942 Dst_Last : Index_Type'Base; -- last index of new, expanded array
1943 Dst : Elements_Access; -- new, expanded internal array
1946 -- As a precondition on the generic actual Index_Type, the base type
1947 -- must include Index_Type'Pred (Index_Type'First); this is the value
1948 -- that Container.Last assumes when the vector is empty. However, we do
1949 -- not allow that as the value for Index when specifying where the new
1950 -- items should be inserted, so we must manually check. (That the user
1951 -- is allowed to specify the value at all here is a consequence of the
1952 -- declaration of the Extended_Index subtype, which includes the values
1953 -- in the base range that immediately precede and immediately follow the
1954 -- values in the Index_Type.)
1956 if Before < Index_Type'First then
1957 raise Constraint_Error with
1958 "Before index is out of range (too small)";
1961 -- We do allow a value greater than Container.Last to be specified as
1962 -- the Index, but only if it's immediately greater. This allows for the
1963 -- case of appending items to the back end of the vector. (It is assumed
1964 -- that specifying an index value greater than Last + 1 indicates some
1965 -- deeper flaw in the caller's algorithm, so that case is treated as a
1968 if Before > Container.Last and then Before > Container.Last + 1 then
1969 raise Constraint_Error with
1970 "Before index is out of range (too large)";
1973 -- We treat inserting 0 items into the container as a no-op, even when
1974 -- the container is busy, so we simply return.
1980 -- There are two constraints we need to satisfy. The first constraint is
1981 -- that a container cannot have more than Count_Type'Last elements, so
1982 -- we must check the sum of the current length and the insertion count.
1983 -- Note: we cannot simply add these values, because of the possibility
1986 if Old_Length > Count_Type'Last - Count then
1987 raise Constraint_Error with "Count is out of range";
1990 -- It is now safe compute the length of the new vector, without fear of
1993 New_Length := Old_Length + Count;
1995 -- The second constraint is that the new Last index value cannot exceed
1996 -- Index_Type'Last. In each branch below, we calculate the maximum
1997 -- length (computed from the range of values in Index_Type), and then
1998 -- compare the new length to the maximum length. If the new length is
1999 -- acceptable, then we compute the new last index from that.
2001 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2003 -- We have to handle the case when there might be more values in the
2004 -- range of Index_Type than in the range of Count_Type.
2006 if Index_Type
'First <= 0 then
2008 -- We know that No_Index (the same as Index_Type'First - 1) is
2009 -- less than 0, so it is safe to compute the following sum without
2010 -- fear of overflow.
2012 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
2014 if Index
<= Index_Type
'Last then
2016 -- We have determined that range of Index_Type has at least as
2017 -- many values as in Count_Type, so Count_Type'Last is the
2018 -- maximum number of items that are allowed.
2020 Max_Length
:= Count_Type
'Last;
2023 -- The range of Index_Type has fewer values than in Count_Type,
2024 -- so the maximum number of items is computed from the range of
2027 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2031 -- No_Index is equal or greater than 0, so we can safely compute
2032 -- the difference without fear of overflow (which we would have to
2033 -- worry about if No_Index were less than 0, but that case is
2036 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2039 elsif Index_Type
'First <= 0 then
2041 -- We know that No_Index (the same as Index_Type'First - 1) is less
2042 -- than 0, so it is safe to compute the following sum without fear of
2045 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
2047 if J
<= Count_Type
'Base (Index_Type
'Last) then
2049 -- We have determined that range of Index_Type has at least as
2050 -- many values as in Count_Type, so Count_Type'Last is the maximum
2051 -- number of items that are allowed.
2053 Max_Length
:= Count_Type
'Last;
2056 -- The range of Index_Type has fewer values than Count_Type does,
2057 -- so the maximum number of items is computed from the range of
2061 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2065 -- No_Index is equal or greater than 0, so we can safely compute the
2066 -- difference without fear of overflow (which we would have to worry
2067 -- about if No_Index were less than 0, but that case is handled
2071 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2074 -- We have just computed the maximum length (number of items). We must
2075 -- now compare the requested length to the maximum length, as we do not
2076 -- allow a vector expand beyond the maximum (because that would create
2077 -- an internal array with a last index value greater than
2078 -- Index_Type'Last, with no way to index those elements).
2080 if New_Length
> Max_Length
then
2081 raise Constraint_Error
with "Count is out of range";
2084 -- New_Last is the last index value of the items in the container after
2085 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2086 -- compute its value from the New_Length.
2088 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2089 New_Last := No_Index + Index_Type'Base (New_Length);
2091 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2094 if Container.Elements = null then
2095 pragma Assert (Container.Last = No_Index);
2097 -- This is the simplest case, with which we must always begin: we're
2098 -- inserting items into an empty vector that hasn't allocated an
2099 -- internal array yet. Note that we don't need to check the busy bit
2100 -- here, because an empty container cannot be busy.
2102 -- In order to preserve container invariants, we allocate the new
2103 -- internal array first, before setting the Last index value, in case
2104 -- the allocation fails (which can happen either because there is no
2105 -- storage available, or because default-valued element
2106 -- initialization fails).
2108 Container.Elements := new Elements_Type (New_Last);
2110 -- The allocation of the new, internal array succeeded, so it is now
2111 -- safe to update the Last index, restoring container invariants.
2113 Container.Last := New_Last;
2118 -- The tampering bits exist to prevent an item from being harmfully
2119 -- manipulated while it is being visited. Query, Update, and Iterate
2120 -- increment the busy count on entry, and decrement the count on
2121 -- exit. Insert checks the count to determine whether it is being called
2122 -- while the associated callback procedure is executing.
2124 if Container.Busy > 0 then
2125 raise Program_Error with
2126 "attempt to tamper with cursors (vector is busy)";
2129 -- An internal array has already been allocated, so we must determine
2130 -- whether there is enough unused storage for the new items.
2132 if New_Last <= Container.Elements.Last then
2134 -- In this case, we're inserting space into a vector that has already
2135 -- allocated an internal array, and the existing array has enough
2136 -- unused storage for the new items.
2139 EA : Elements_Array renames Container.Elements.EA;
2142 if Before <= Container.Last then
2144 -- The space is being inserted before some existing elements,
2145 -- so we must slide the existing elements up to their new
2146 -- home. We use the wider of Index_Type'Base and
2147 -- Count_Type'Base as the type for intermediate index values.
2149 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2150 Index
:= Before
+ Index_Type
'Base (Count
);
2153 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2156 EA
(Index
.. New_Last
) := EA
(Before
.. Container
.Last
);
2160 Container
.Last
:= New_Last
;
2164 -- In this case, we're inserting space into a vector that has already
2165 -- allocated an internal array, but the existing array does not have
2166 -- enough storage, so we must allocate a new, longer array. In order to
2167 -- guarantee that the amortized insertion cost is O(1), we always
2168 -- allocate an array whose length is some power-of-two factor of the
2169 -- current array length. (The new array cannot have a length less than
2170 -- the New_Length of the container, but its last index value cannot be
2171 -- greater than Index_Type'Last.)
2173 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
2174 while New_Capacity
< New_Length
loop
2175 if New_Capacity
> Count_Type
'Last / 2 then
2176 New_Capacity
:= Count_Type
'Last;
2180 New_Capacity
:= 2 * New_Capacity
;
2183 if New_Capacity
> Max_Length
then
2185 -- We have reached the limit of capacity, so no further expansion
2186 -- will occur. (This is not a problem, as there is never a need to
2187 -- have more capacity than the maximum container length.)
2189 New_Capacity
:= Max_Length
;
2192 -- We have computed the length of the new internal array (and this is
2193 -- what "vector capacity" means), so use that to compute its last index.
2195 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2196 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2199 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2202 -- Now we allocate the new, longer internal array. If the allocation
2203 -- fails, we have not changed any container state, so no side-effect
2204 -- will occur as a result of propagating the exception.
2206 Dst := new Elements_Type (Dst_Last);
2208 -- We have our new internal array. All that needs to be done now is to
2209 -- copy the existing items (if any) from the old array (the "source"
2210 -- array, object SA below) to the new array (the "destination" array,
2211 -- object DA below), and then deallocate the old array.
2214 SA : Elements_Array renames Container.Elements.EA; -- source
2215 DA : Elements_Array renames Dst.EA; -- destination
2218 DA (Index_Type'First .. Before - 1) :=
2219 SA (Index_Type'First .. Before - 1);
2221 if Before <= Container.Last then
2223 -- The space is being inserted before some existing elements, so
2224 -- we must slide the existing elements up to their new home.
2226 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2227 Index
:= Before
+ Index_Type
'Base (Count
);
2229 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2232 DA
(Index
.. New_Last
) := SA
(Before
.. Container
.Last
);
2241 -- We have successfully copied the items onto the new array, so the
2242 -- final thing to do is restore invariants, and deallocate the old
2246 X
: Elements_Access
:= Container
.Elements
;
2249 -- We first isolate the old internal array, removing it from the
2250 -- container and replacing it with the new internal array, before we
2251 -- deallocate the old array (which can fail if finalization of
2252 -- elements propagates an exception).
2254 Container
.Elements
:= Dst
;
2255 Container
.Last
:= New_Last
;
2257 -- The container invariants have been restored, so it is now safe to
2258 -- attempt to deallocate the old array.
2264 procedure Insert_Space
2265 (Container
: in out Vector
;
2267 Position
: out Cursor
;
2268 Count
: Count_Type
:= 1)
2270 Index
: Index_Type
'Base;
2273 if Before
.Container
/= null
2274 and then Before
.Container
/= Container
'Unrestricted_Access
2276 raise Program_Error
with "Before cursor denotes wrong container";
2280 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2281 Position
:= No_Element
;
2283 Position
:= (Container
'Unrestricted_Access, Before
.Index
);
2289 if Before
.Container
= null or else Before
.Index
> Container
.Last
then
2290 if Container
.Last
= Index_Type
'Last then
2291 raise Constraint_Error
with
2292 "vector is already at its maximum length";
2294 Index
:= Container
.Last
+ 1;
2298 Index
:= Before
.Index
;
2301 Insert_Space
(Container
, Index
, Count
=> Count
);
2303 Position
:= (Container
'Unrestricted_Access, Index
);
2310 function Is_Empty
(Container
: Vector
) return Boolean is
2312 return Container
.Last
< Index_Type
'First;
2320 (Container
: Vector
;
2321 Process
: not null access procedure (Position
: Cursor
))
2323 B
: Natural renames Container
'Unrestricted_Access.all.Busy
;
2329 for Indx
in Index_Type
'First .. Container
.Last
loop
2330 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
2342 (Container : Vector)
2343 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
2345 V : constant Vector_Access := Container'Unrestricted_Access;
2346 B : Natural renames V.Busy;
2349 -- The value of its Index component influences the behavior of the First
2350 -- and Last selector functions of the iterator object. When the Index
2351 -- component is No_Index (as is the case here), this means the iterator
2352 -- object was constructed without a start expression. This is a complete
2353 -- iterator, meaning that the iteration starts from the (logical)
2354 -- beginning of the sequence of items.
2356 -- Note: For a forward iterator, Container.First is the beginning, and
2357 -- for a reverse iterator, Container.Last is the beginning.
2359 return It : constant Iterator :=
2360 (Limited_Controlled with
2369 (Container : Vector;
2371 return Vector_Iterator_Interfaces.Reversible_Iterator'class
2373 V : constant Vector_Access := Container'Unrestricted_Access;
2374 B : Natural renames V.Busy;
2377 -- It was formerly the case that when Start = No_Element, the partial
2378 -- iterator was defined to behave the same as for a complete iterator,
2379 -- and iterate over the entire sequence of items. However, those
2380 -- semantics were unintuitive and arguably error-prone (it is too easy
2381 -- to accidentally create an endless loop), and so they were changed,
2382 -- per the ARG meeting in Denver on 2011/11. However, there was no
2383 -- consensus about what positive meaning this corner case should have,
2384 -- and so it was decided to simply raise an exception. This does imply,
2385 -- however, that it is not possible to use a partial iterator to specify
2386 -- an empty sequence of items.
2388 if Start.Container = null then
2389 raise Constraint_Error with
2390 "Start position for iterator equals No_Element";
2393 if Start.Container /= V then
2394 raise Program_Error with
2395 "Start cursor of Iterate designates wrong vector";
2398 if Start.Index > V.Last then
2399 raise Constraint_Error with
2400 "Start position for iterator equals No_Element";
2403 -- The value of its Index component influences the behavior of the First
2404 -- and Last selector functions of the iterator object. When the Index
2405 -- component is not No_Index (as is the case here), it means that this
2406 -- is a partial iteration, over a subset of the complete sequence of
2407 -- items. The iterator object was constructed with a start expression,
2408 -- indicating the position from which the iteration begins. Note that
2409 -- the start position has the same value irrespective of whether this
2410 -- is a forward or reverse iteration.
2412 return It : constant Iterator :=
2413 (Limited_Controlled with
2415 Index => Start.Index)
2425 function Last (Container : Vector) return Cursor is
2427 if Is_Empty (Container) then
2430 return (Container'Unrestricted_Access, Container.Last);
2434 function Last (Object : Iterator) return Cursor is
2436 -- The value of the iterator object's Index component influences the
2437 -- behavior of the Last (and First) selector function.
2439 -- When the Index component is No_Index, this means the iterator
2440 -- object was constructed without a start expression, in which case the
2441 -- (reverse) iteration starts from the (logical) beginning of the entire
2442 -- sequence (corresponding to Container.Last, for a reverse iterator).
2444 -- Otherwise, this is iteration over a partial sequence of items.
2445 -- When the Index component is not No_Index, the iterator object was
2446 -- constructed with a start expression, that specifies the position
2447 -- from which the (reverse) partial iteration begins.
2449 if Object.Index = No_Index then
2450 return Last (Object.Container.all);
2452 return Cursor'(Object
.Container
, Object
.Index
);
2460 function Last_Element
(Container
: Vector
) return Element_Type
is
2462 if Container
.Last
= No_Index
then
2463 raise Constraint_Error
with "Container is empty";
2465 return Container
.Elements
.EA
(Container
.Last
);
2473 function Last_Index
(Container
: Vector
) return Extended_Index
is
2475 return Container
.Last
;
2482 function Length
(Container
: Vector
) return Count_Type
is
2483 L
: constant Index_Type
'Base := Container
.Last
;
2484 F
: constant Index_Type
:= Index_Type
'First;
2487 -- The base range of the index type (Index_Type'Base) might not include
2488 -- all values for length (Count_Type). Contrariwise, the index type
2489 -- might include values outside the range of length. Hence we use
2490 -- whatever type is wider for intermediate values when calculating
2491 -- length. Note that no matter what the index type is, the maximum
2492 -- length to which a vector is allowed to grow is always the minimum
2493 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2495 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2496 -- to have a base range of -128 .. 127, but the corresponding vector
2497 -- would have lengths in the range 0 .. 255. In this case we would need
2498 -- to use Count_Type'Base for intermediate values.
2500 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2501 -- vector would have a maximum length of 10, but the index values lie
2502 -- outside the range of Count_Type (which is only 32 bits). In this
2503 -- case we would need to use Index_Type'Base for intermediate values.
2505 if Count_Type
'Base'Last >= Index_Type'Pos (Index_Type'Base'Last
) then
2506 return Count_Type
'Base (L
) - Count_Type
'Base (F
) + 1;
2508 return Count_Type
(L
- F
+ 1);
2517 (Target
: in out Vector
;
2518 Source
: in out Vector
)
2521 if Target
'Address = Source
'Address then
2525 if Target
.Busy
> 0 then
2526 raise Program_Error
with
2527 "attempt to tamper with cursors (Target is busy)";
2530 if Source
.Busy
> 0 then
2531 raise Program_Error
with
2532 "attempt to tamper with cursors (Source is busy)";
2536 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
2538 Target
.Elements
:= Source
.Elements
;
2539 Source
.Elements
:= Target_Elements
;
2542 Target
.Last
:= Source
.Last
;
2543 Source
.Last
:= No_Index
;
2550 function Next
(Position
: Cursor
) return Cursor
is
2552 if Position
.Container
= null then
2554 elsif Position
.Index
< Position
.Container
.Last
then
2555 return (Position
.Container
, Position
.Index
+ 1);
2561 function Next
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2563 if Position
.Container
= null then
2565 elsif Position
.Container
/= Object
.Container
then
2566 raise Program_Error
with
2567 "Position cursor of Next designates wrong vector";
2569 return Next
(Position
);
2573 procedure Next
(Position
: in out Cursor
) is
2575 if Position
.Container
= null then
2577 elsif Position
.Index
< Position
.Container
.Last
then
2578 Position
.Index
:= Position
.Index
+ 1;
2580 Position
:= No_Element
;
2588 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
2590 Insert
(Container
, Index_Type
'First, New_Item
);
2594 (Container
: in out Vector
;
2595 New_Item
: Element_Type
;
2596 Count
: Count_Type
:= 1)
2599 Insert
(Container
, Index_Type
'First, New_Item
, Count
);
2606 function Previous
(Position
: Cursor
) return Cursor
is
2608 if Position
.Container
= null then
2610 elsif Position
.Index
> Index_Type
'First then
2611 return (Position
.Container
, Position
.Index
- 1);
2617 function Previous
(Object
: Iterator
; Position
: Cursor
) return Cursor
is
2619 if Position
.Container
= null then
2621 elsif Position
.Container
/= Object
.Container
then
2622 raise Program_Error
with
2623 "Position cursor of Previous designates wrong vector";
2625 return Previous
(Position
);
2629 procedure Previous
(Position
: in out Cursor
) is
2631 if Position
.Container
= null then
2633 elsif Position
.Index
> Index_Type
'First then
2634 Position
.Index
:= Position
.Index
- 1;
2636 Position
:= No_Element
;
2644 procedure Query_Element
2645 (Container
: Vector
;
2647 Process
: not null access procedure (Element
: Element_Type
))
2649 V
: Vector
renames Container
'Unrestricted_Access.all;
2650 B
: Natural renames V
.Busy
;
2651 L
: Natural renames V
.Lock
;
2654 if Index
> Container
.Last
then
2655 raise Constraint_Error
with "Index is out of range";
2662 Process
(V
.Elements
.EA
(Index
));
2674 procedure Query_Element
2676 Process
: not null access procedure (Element
: Element_Type
))
2679 if Position
.Container
= null then
2680 raise Constraint_Error
with "Position cursor has no element";
2682 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
2691 (Stream
: not null access Root_Stream_Type
'Class;
2692 Container
: out Vector
)
2694 Length
: Count_Type
'Base;
2695 Last
: Index_Type
'Base := No_Index
;
2700 Count_Type
'Base'Read (Stream, Length);
2702 if Length > Capacity (Container) then
2703 Reserve_Capacity (Container, Capacity => Length);
2706 for J in Count_Type range 1 .. Length loop
2708 Element_Type'Read (Stream, Container.Elements.EA (Last));
2709 Container.Last := Last;
2714 (Stream : not null access Root_Stream_Type'Class;
2715 Position : out Cursor)
2718 raise Program_Error with "attempt to stream vector cursor";
2722 (Stream : not null access Root_Stream_Type'Class;
2723 Item : out Reference_Type)
2726 raise Program_Error with "attempt to stream reference";
2730 (Stream : not null access Root_Stream_Type'Class;
2731 Item : out Constant_Reference_Type)
2734 raise Program_Error with "attempt to stream reference";
2742 (Container : aliased in out Vector;
2743 Position : Cursor) return Reference_Type
2746 if Position.Container = null then
2747 raise Constraint_Error with "Position cursor has no element";
2750 if Position.Container /= Container'Unrestricted_Access then
2751 raise Program_Error with "Position cursor denotes wrong container";
2754 if Position.Index > Position.Container.Last then
2755 raise Constraint_Error with "Position cursor is out of range";
2759 C : Vector renames Position.Container.all;
2760 B : Natural renames C.Busy;
2761 L : Natural renames C.Lock;
2763 return R : constant Reference_Type :=
2764 (Element => Container.Elements.EA (Position.Index)'Access,
2765 Control => (Controlled with Position.Container))
2774 (Container : aliased in out Vector;
2775 Index : Index_Type) return Reference_Type
2778 if Index > Container.Last then
2779 raise Constraint_Error with "Index is out of range";
2783 C : Vector renames Container'Unrestricted_Access.all;
2784 B : Natural renames C.Busy;
2785 L : Natural renames C.Lock;
2787 return R : constant Reference_Type :=
2788 (Element => Container.Elements.EA (Index)'Access,
2789 Control => (Controlled with Container'Unrestricted_Access))
2798 ---------------------
2799 -- Replace_Element --
2800 ---------------------
2802 procedure Replace_Element
2803 (Container : in out Vector;
2805 New_Item : Element_Type)
2808 if Index > Container.Last then
2809 raise Constraint_Error with "Index is out of range";
2810 elsif Container.Lock > 0 then
2811 raise Program_Error with
2812 "attempt to tamper with elements (vector is locked)";
2814 Container.Elements.EA (Index) := New_Item;
2816 end Replace_Element;
2818 procedure Replace_Element
2819 (Container : in out Vector;
2821 New_Item : Element_Type)
2824 if Position.Container = null then
2825 raise Constraint_Error with "Position cursor has no element";
2827 elsif Position.Container /= Container'Unrestricted_Access then
2828 raise Program_Error with "Position cursor denotes wrong container";
2830 elsif Position.Index > Container.Last then
2831 raise Constraint_Error with "Position cursor is out of range";
2834 if Container.Lock > 0 then
2835 raise Program_Error with
2836 "attempt to tamper with elements (vector is locked)";
2839 Container.Elements.EA (Position.Index) := New_Item;
2841 end Replace_Element;
2843 ----------------------
2844 -- Reserve_Capacity --
2845 ----------------------
2847 procedure Reserve_Capacity
2848 (Container : in out Vector;
2849 Capacity : Count_Type)
2851 N : constant Count_Type := Length (Container);
2853 Index : Count_Type'Base;
2854 Last : Index_Type'Base;
2857 -- Reserve_Capacity can be used to either expand the storage available
2858 -- for elements (this would be its typical use, in anticipation of
2859 -- future insertion), or to trim back storage. In the latter case,
2860 -- storage can only be trimmed back to the limit of the container
2861 -- length. Note that Reserve_Capacity neither deletes (active) elements
2862 -- nor inserts elements; it only affects container capacity, never
2863 -- container length.
2865 if Capacity = 0 then
2867 -- This is a request to trim back storage, to the minimum amount
2868 -- possible given the current state of the container.
2872 -- The container is empty, so in this unique case we can
2873 -- deallocate the entire internal array. Note that an empty
2874 -- container can never be busy, so there's no need to check the
2878 X : Elements_Access := Container.Elements;
2881 -- First we remove the internal array from the container, to
2882 -- handle the case when the deallocation raises an exception.
2884 Container.Elements := null;
2886 -- Container invariants have been restored, so it is now safe
2887 -- to attempt to deallocate the internal array.
2892 elsif N < Container.Elements.EA'Length then
2894 -- The container is not empty, and the current length is less than
2895 -- the current capacity, so there's storage available to trim. In
2896 -- this case, we allocate a new internal array having a length
2897 -- that exactly matches the number of items in the
2898 -- container. (Reserve_Capacity does not delete active elements,
2899 -- so this is the best we can do with respect to minimizing
2902 if Container.Busy > 0 then
2903 raise Program_Error with
2904 "attempt to tamper with cursors (vector is busy)";
2908 subtype Src_Index_Subtype is Index_Type'Base range
2909 Index_Type'First .. Container.Last;
2911 Src : Elements_Array renames
2912 Container.Elements.EA (Src_Index_Subtype);
2914 X : Elements_Access := Container.Elements;
2917 -- Although we have isolated the old internal array that we're
2918 -- going to deallocate, we don't deallocate it until we have
2919 -- successfully allocated a new one. If there is an exception
2920 -- during allocation (either because there is not enough
2921 -- storage, or because initialization of the elements fails),
2922 -- we let it propagate without causing any side-effect.
2924 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
2926 -- We have successfully allocated a new internal array (with a
2927 -- smaller length than the old one, and containing a copy of
2928 -- just the active elements in the container), so it is now
2929 -- safe to attempt to deallocate the old array. The old array
2930 -- has been isolated, and container invariants have been
2931 -- restored, so if the deallocation fails (because finalization
2932 -- of the elements fails), we simply let it propagate.
2941 -- Reserve_Capacity can be used to expand the storage available for
2942 -- elements, but we do not let the capacity grow beyond the number of
2943 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2944 -- to refer to the elements with an index value greater than
2945 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2946 -- the Last index value of the new internal array, in a way that avoids
2947 -- any possibility of overflow.
2949 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2951 -- We perform a two-part test. First we determine whether the
2952 -- computed Last value lies in the base range of the type, and then
2953 -- determine whether it lies in the range of the index (sub)type.
2955 -- Last must satisfy this relation:
2956 -- First + Length - 1 <= Last
2957 -- We regroup terms:
2958 -- First - 1 <= Last - Length
2959 -- Which can rewrite as:
2960 -- No_Index <= Last - Length
2962 if Index_Type'Base'Last
- Index_Type
'Base (Capacity
) < No_Index
then
2963 raise Constraint_Error
with "Capacity is out of range";
2966 -- We now know that the computed value of Last is within the base
2967 -- range of the type, so it is safe to compute its value:
2969 Last
:= No_Index
+ Index_Type
'Base (Capacity
);
2971 -- Finally we test whether the value is within the range of the
2972 -- generic actual index subtype:
2974 if Last
> Index_Type
'Last then
2975 raise Constraint_Error
with "Capacity is out of range";
2978 elsif Index_Type
'First <= 0 then
2980 -- Here we can compute Last directly, in the normal way. We know that
2981 -- No_Index is less than 0, so there is no danger of overflow when
2982 -- adding the (positive) value of Capacity.
2984 Index
:= Count_Type
'Base (No_Index
) + Capacity
; -- Last
2986 if Index
> Count_Type
'Base (Index_Type
'Last) then
2987 raise Constraint_Error
with "Capacity is out of range";
2990 -- We know that the computed value (having type Count_Type) of Last
2991 -- is within the range of the generic actual index subtype, so it is
2992 -- safe to convert to Index_Type:
2994 Last
:= Index_Type
'Base (Index
);
2997 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2998 -- must test the length indirectly (by working backwards from the
2999 -- largest possible value of Last), in order to prevent overflow.
3001 Index
:= Count_Type
'Base (Index_Type
'Last) - Capacity
; -- No_Index
3003 if Index
< Count_Type
'Base (No_Index
) then
3004 raise Constraint_Error
with "Capacity is out of range";
3007 -- We have determined that the value of Capacity would not create a
3008 -- Last index value outside of the range of Index_Type, so we can now
3009 -- safely compute its value.
3011 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Capacity
);
3014 -- The requested capacity is non-zero, but we don't know yet whether
3015 -- this is a request for expansion or contraction of storage.
3017 if Container
.Elements
= null then
3019 -- The container is empty (it doesn't even have an internal array),
3020 -- so this represents a request to allocate (expand) storage having
3021 -- the given capacity.
3023 Container
.Elements
:= new Elements_Type
(Last
);
3027 if Capacity
<= N
then
3029 -- This is a request to trim back storage, but only to the limit of
3030 -- what's already in the container. (Reserve_Capacity never deletes
3031 -- active elements, it only reclaims excess storage.)
3033 if N
< Container
.Elements
.EA
'Length then
3035 -- The container is not empty (because the requested capacity is
3036 -- positive, and less than or equal to the container length), and
3037 -- the current length is less than the current capacity, so
3038 -- there's storage available to trim. In this case, we allocate a
3039 -- new internal array having a length that exactly matches the
3040 -- number of items in the container.
3042 if Container
.Busy
> 0 then
3043 raise Program_Error
with
3044 "attempt to tamper with cursors (vector is busy)";
3048 subtype Src_Index_Subtype
is Index_Type
'Base range
3049 Index_Type
'First .. Container
.Last
;
3051 Src
: Elements_Array
renames
3052 Container
.Elements
.EA
(Src_Index_Subtype
);
3054 X
: Elements_Access
:= Container
.Elements
;
3057 -- Although we have isolated the old internal array that we're
3058 -- going to deallocate, we don't deallocate it until we have
3059 -- successfully allocated a new one. If there is an exception
3060 -- during allocation (either because there is not enough
3061 -- storage, or because initialization of the elements fails),
3062 -- we let it propagate without causing any side-effect.
3064 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
3066 -- We have successfully allocated a new internal array (with a
3067 -- smaller length than the old one, and containing a copy of
3068 -- just the active elements in the container), so it is now
3069 -- safe to attempt to deallocate the old array. The old array
3070 -- has been isolated, and container invariants have been
3071 -- restored, so if the deallocation fails (because finalization
3072 -- of the elements fails), we simply let it propagate.
3081 -- The requested capacity is larger than the container length (the
3082 -- number of active elements). Whether this represents a request for
3083 -- expansion or contraction of the current capacity depends on what the
3084 -- current capacity is.
3086 if Capacity = Container.Elements.EA'Length then
3088 -- The requested capacity matches the existing capacity, so there's
3089 -- nothing to do here. We treat this case as a no-op, and simply
3090 -- return without checking the busy bit.
3095 -- There is a change in the capacity of a non-empty container, so a new
3096 -- internal array will be allocated. (The length of the new internal
3097 -- array could be less or greater than the old internal array. We know
3098 -- only that the length of the new internal array is greater than the
3099 -- number of active elements in the container.) We must check whether
3100 -- the container is busy before doing anything else.
3102 if Container.Busy > 0 then
3103 raise Program_Error with
3104 "attempt to tamper with cursors (vector is busy)";
3107 -- We now allocate a new internal array, having a length different from
3108 -- its current value.
3111 E : Elements_Access := new Elements_Type (Last);
3114 -- We have successfully allocated the new internal array. We first
3115 -- attempt to copy the existing elements from the old internal array
3116 -- ("src" elements) onto the new internal array ("tgt" elements).
3119 subtype Index_Subtype is Index_Type'Base range
3120 Index_Type'First .. Container.Last;
3122 Src : Elements_Array renames
3123 Container.Elements.EA (Index_Subtype);
3125 Tgt : Elements_Array renames E.EA (Index_Subtype);
3136 -- We have successfully copied the existing elements onto the new
3137 -- internal array, so now we can attempt to deallocate the old one.
3140 X : Elements_Access := Container.Elements;
3143 -- First we isolate the old internal array, and replace it in the
3144 -- container with the new internal array.
3146 Container.Elements := E;
3148 -- Container invariants have been restored, so it is now safe to
3149 -- attempt to deallocate the old internal array.
3154 end Reserve_Capacity;
3156 ----------------------
3157 -- Reverse_Elements --
3158 ----------------------
3160 procedure Reverse_Elements (Container : in out Vector) is
3162 if Container.Length <= 1 then
3166 -- The exception behavior for the vector container must match that for
3167 -- the list container, so we check for cursor tampering here (which will
3168 -- catch more things) instead of for element tampering (which will catch
3169 -- fewer things). It's true that the elements of this vector container
3170 -- could be safely moved around while (say) an iteration is taking place
3171 -- (iteration only increments the busy counter), and so technically
3172 -- all we would need here is a test for element tampering (indicated
3173 -- by the lock counter), that's simply an artifact of our array-based
3174 -- implementation. Logically Reverse_Elements requires a check for
3175 -- cursor tampering.
3177 if Container.Busy > 0 then
3178 raise Program_Error with
3179 "attempt to tamper with cursors (vector is busy)";
3185 E : Elements_Type renames Container.Elements.all;
3188 K := Index_Type'First;
3189 J := Container.Last;
3192 EK : constant Element_Type := E.EA (K);
3194 E.EA (K) := E.EA (J);
3202 end Reverse_Elements;
3208 function Reverse_Find
3209 (Container : Vector;
3210 Item : Element_Type;
3211 Position : Cursor := No_Element) return Cursor
3213 Last : Index_Type'Base;
3216 if Position.Container /= null
3217 and then Position.Container /= Container'Unrestricted_Access
3219 raise Program_Error with "Position cursor denotes wrong container";
3223 (if Position.Container = null or else Position.Index > Container.Last
3225 else Position.Index);
3227 -- Per AI05-0022, the container implementation is required to detect
3228 -- element tampering by a generic actual subprogram.
3231 B : Natural renames Container'Unrestricted_Access.Busy;
3232 L : Natural renames Container'Unrestricted_Access.Lock;
3234 Result : Index_Type'Base;
3241 for Indx in reverse Index_Type'First .. Last loop
3242 if Container.Elements.EA (Indx) = Item then
3251 if Result = No_Index then
3254 return Cursor'(Container
'Unrestricted_Access, Result
);
3265 ------------------------
3266 -- Reverse_Find_Index --
3267 ------------------------
3269 function Reverse_Find_Index
3270 (Container
: Vector
;
3271 Item
: Element_Type
;
3272 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
3274 B
: Natural renames Container
'Unrestricted_Access.Busy
;
3275 L
: Natural renames Container
'Unrestricted_Access.Lock
;
3277 Last
: constant Index_Type
'Base :=
3278 Index_Type
'Min (Container
.Last
, Index
);
3280 Result
: Index_Type
'Base;
3283 -- Per AI05-0022, the container implementation is required to detect
3284 -- element tampering by a generic actual subprogram.
3290 for Indx
in reverse Index_Type
'First .. Last
loop
3291 if Container
.Elements
.EA
(Indx
) = Item
then
3307 end Reverse_Find_Index
;
3309 ---------------------
3310 -- Reverse_Iterate --
3311 ---------------------
3313 procedure Reverse_Iterate
3314 (Container
: Vector
;
3315 Process
: not null access procedure (Position
: Cursor
))
3317 V
: Vector
renames Container
'Unrestricted_Access.all;
3318 B
: Natural renames V
.Busy
;
3324 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
3325 Process
(Cursor
'(Container'Unrestricted_Access, Indx));
3334 end Reverse_Iterate;
3340 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
3341 Count : constant Count_Type'Base := Container.Length - Length;
3344 -- Set_Length allows the user to set the length explicitly, instead
3345 -- of implicitly as a side-effect of deletion or insertion. If the
3346 -- requested length is less than the current length, this is equivalent
3347 -- to deleting items from the back end of the vector. If the requested
3348 -- length is greater than the current length, then this is equivalent
3349 -- to inserting "space" (nonce items) at the end.
3352 Container.Delete_Last (Count);
3354 elsif Container.Last >= Index_Type'Last then
3355 raise Constraint_Error with "vector is already at its maximum length";
3358 Container.Insert_Space (Container.Last + 1, -Count);
3366 procedure Swap (Container : in out Vector; I, J : Index_Type) is
3368 if I > Container.Last then
3369 raise Constraint_Error with "I index is out of range";
3372 if J > Container.Last then
3373 raise Constraint_Error with "J index is out of range";
3380 if Container.Lock > 0 then
3381 raise Program_Error with
3382 "attempt to tamper with elements (vector is locked)";
3386 EI_Copy : constant Element_Type := Container.Elements.EA (I);
3388 Container.Elements.EA (I) := Container.Elements.EA (J);
3389 Container.Elements.EA (J) := EI_Copy;
3393 procedure Swap (Container : in out Vector; I, J : Cursor) is
3395 if I.Container = null then
3396 raise Constraint_Error with "I cursor has no element";
3398 elsif J.Container = null then
3399 raise Constraint_Error with "J cursor has no element";
3401 elsif I.Container /= Container'Unrestricted_Access then
3402 raise Program_Error with "I cursor denotes wrong container";
3404 elsif J.Container /= Container'Unrestricted_Access then
3405 raise Program_Error with "J cursor denotes wrong container";
3408 Swap (Container, I.Index, J.Index);
3417 (Container : Vector;
3418 Index : Extended_Index) return Cursor
3421 if Index not in Index_Type'First .. Container.Last then
3424 return (Container'Unrestricted_Access, Index);
3432 function To_Index (Position : Cursor) return Extended_Index is
3434 if Position.Container = null then
3436 elsif Position.Index <= Position.Container.Last then
3437 return Position.Index;
3447 function To_Vector (Length : Count_Type) return Vector is
3448 Index : Count_Type'Base;
3449 Last : Index_Type'Base;
3450 Elements : Elements_Access;
3454 return Empty_Vector;
3457 -- We create a vector object with a capacity that matches the specified
3458 -- Length, but we do not allow the vector capacity (the length of the
3459 -- internal array) to exceed the number of values in Index_Type'Range
3460 -- (otherwise, there would be no way to refer to those components via an
3461 -- index). We must therefore check whether the specified Length would
3462 -- create a Last index value greater than Index_Type'Last.
3464 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
3466 -- We perform a two-part test. First we determine whether the
3467 -- computed Last value lies in the base range of the type, and then
3468 -- determine whether it lies in the range of the index (sub)type.
3470 -- Last must satisfy this relation:
3471 -- First + Length - 1 <= Last
3472 -- We regroup terms:
3473 -- First - 1 <= Last - Length
3474 -- Which can rewrite as:
3475 -- No_Index <= Last - Length
3477 if Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index then
3478 raise Constraint_Error with "Length is out of range";
3481 -- We now know that the computed value of Last is within the base
3482 -- range of the type, so it is safe to compute its value:
3484 Last := No_Index + Index_Type'Base (Length);
3486 -- Finally we test whether the value is within the range of the
3487 -- generic actual index subtype:
3489 if Last > Index_Type'Last then
3490 raise Constraint_Error with "Length is out of range";
3493 elsif Index_Type'First <= 0 then
3495 -- Here we can compute Last directly, in the normal way. We know that
3496 -- No_Index is less than 0, so there is no danger of overflow when
3497 -- adding the (positive) value of Length.
3499 Index := Count_Type'Base (No_Index) + Length; -- Last
3501 if Index > Count_Type'Base (Index_Type'Last) then
3502 raise Constraint_Error with "Length is out of range";
3505 -- We know that the computed value (having type Count_Type) of Last
3506 -- is within the range of the generic actual index subtype, so it is
3507 -- safe to convert to Index_Type:
3509 Last := Index_Type'Base (Index);
3512 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3513 -- must test the length indirectly (by working backwards from the
3514 -- largest possible value of Last), in order to prevent overflow.
3516 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3518 if Index < Count_Type'Base (No_Index) then
3519 raise Constraint_Error with "Length is out of range";
3522 -- We have determined that the value of Length would not create a
3523 -- Last index value outside of the range of Index_Type, so we can now
3524 -- safely compute its value.
3526 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3529 Elements := new Elements_Type (Last);
3531 return Vector'(Controlled
with Elements
, Last
, 0, 0);
3535 (New_Item
: Element_Type
;
3536 Length
: Count_Type
) return Vector
3538 Index
: Count_Type
'Base;
3539 Last
: Index_Type
'Base;
3540 Elements
: Elements_Access
;
3544 return Empty_Vector
;
3547 -- We create a vector object with a capacity that matches the specified
3548 -- Length, but we do not allow the vector capacity (the length of the
3549 -- internal array) to exceed the number of values in Index_Type'Range
3550 -- (otherwise, there would be no way to refer to those components via an
3551 -- index). We must therefore check whether the specified Length would
3552 -- create a Last index value greater than Index_Type'Last.
3554 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3556 -- We perform a two-part test. First we determine whether the
3557 -- computed Last value lies in the base range of the type, and then
3558 -- determine whether it lies in the range of the index (sub)type.
3560 -- Last must satisfy this relation:
3561 -- First + Length - 1 <= Last
3562 -- We regroup terms:
3563 -- First - 1 <= Last - Length
3564 -- Which can rewrite as:
3565 -- No_Index <= Last - Length
3567 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
3568 raise Constraint_Error
with "Length is out of range";
3571 -- We now know that the computed value of Last is within the base
3572 -- range of the type, so it is safe to compute its value:
3574 Last
:= No_Index
+ Index_Type
'Base (Length
);
3576 -- Finally we test whether the value is within the range of the
3577 -- generic actual index subtype:
3579 if Last
> Index_Type
'Last then
3580 raise Constraint_Error
with "Length is out of range";
3583 elsif Index_Type
'First <= 0 then
3585 -- Here we can compute Last directly, in the normal way. We know that
3586 -- No_Index is less than 0, so there is no danger of overflow when
3587 -- adding the (positive) value of Length.
3589 Index
:= Count_Type
'Base (No_Index
) + Length
; -- same value as V.Last
3591 if Index
> Count_Type
'Base (Index_Type
'Last) then
3592 raise Constraint_Error
with "Length is out of range";
3595 -- We know that the computed value (having type Count_Type) of Last
3596 -- is within the range of the generic actual index subtype, so it is
3597 -- safe to convert to Index_Type:
3599 Last
:= Index_Type
'Base (Index
);
3602 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3603 -- must test the length indirectly (by working backwards from the
3604 -- largest possible value of Last), in order to prevent overflow.
3606 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
3608 if Index
< Count_Type
'Base (No_Index
) then
3609 raise Constraint_Error
with "Length is out of range";
3612 -- We have determined that the value of Length would not create a
3613 -- Last index value outside of the range of Index_Type, so we can now
3614 -- safely compute its value.
3616 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
3619 Elements
:= new Elements_Type
'(Last, EA => (others => New_Item));
3621 return Vector'(Controlled
with Elements
, Last
, 0, 0);
3624 --------------------
3625 -- Update_Element --
3626 --------------------
3628 procedure Update_Element
3629 (Container
: in out Vector
;
3631 Process
: not null access procedure (Element
: in out Element_Type
))
3633 B
: Natural renames Container
.Busy
;
3634 L
: Natural renames Container
.Lock
;
3637 if Index
> Container
.Last
then
3638 raise Constraint_Error
with "Index is out of range";
3645 Process
(Container
.Elements
.EA
(Index
));
3657 procedure Update_Element
3658 (Container
: in out Vector
;
3660 Process
: not null access procedure (Element
: in out Element_Type
))
3663 if Position
.Container
= null then
3664 raise Constraint_Error
with "Position cursor has no element";
3665 elsif Position
.Container
/= Container
'Unrestricted_Access then
3666 raise Program_Error
with "Position cursor denotes wrong container";
3668 Update_Element
(Container
, Position
.Index
, Process
);
3677 (Stream
: not null access Root_Stream_Type
'Class;
3681 Count_Type
'Base'Write (Stream, Length (Container));
3683 for J in Index_Type'First .. Container.Last loop
3684 Element_Type'Write (Stream, Container.Elements.EA (J));
3689 (Stream : not null access Root_Stream_Type'Class;
3693 raise Program_Error with "attempt to stream vector cursor";
3697 (Stream : not null access Root_Stream_Type'Class;
3698 Item : Reference_Type)
3701 raise Program_Error with "attempt to stream reference";
3705 (Stream : not null access Root_Stream_Type'Class;
3706 Item : Constant_Reference_Type)
3709 raise Program_Error with "attempt to stream reference";
3712 end Ada.Containers.Vectors;