1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S --
9 -- Copyright (C) 2004-2010, 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
;
32 with System
; use type System
.Address
;
34 package body Ada
.Containers
.Indefinite_Vectors
is
37 new Ada
.Unchecked_Deallocation
(Elements_Type
, Elements_Access
);
40 new Ada
.Unchecked_Deallocation
(Element_Type
, Element_Access
);
46 function "&" (Left
, Right
: Vector
) return Vector
is
47 LN
: constant Count_Type
:= Length
(Left
);
48 RN
: constant Count_Type
:= Length
(Right
);
49 N
: Count_Type
'Base; -- length of result
50 J
: Count_Type
'Base; -- for computing intermediate values
51 Last
: Index_Type
'Base; -- Last index of result
54 -- We decide that the capacity of the result is the sum of the lengths
55 -- of the vector parameters. We could decide to make it larger, but we
56 -- have no basis for knowing how much larger, so we just allocate the
57 -- minimum amount of storage.
59 -- Here we handle the easy cases first, when one of the vector
60 -- parameters is empty. (We say "easy" because there's nothing to
61 -- compute, that can potentially overflow.)
69 RE
: Elements_Array
renames
70 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
72 Elements
: Elements_Access
:=
73 new Elements_Type
(Right
.Last
);
76 -- Elements of an indefinite vector are allocated, so we cannot
77 -- use simple slice assignment to give a value to our result.
78 -- Hence we must walk the array of the Right vector, and copy
79 -- each source element individually.
81 for I
in Elements
.EA
'Range loop
83 if RE
(I
) /= null then
84 Elements
.EA
(I
) := new Element_Type
'(RE (I).all);
89 for J in Index_Type'First .. I - 1 loop
90 Free (Elements.EA (J));
98 return (Controlled with Elements, Right.Last, 0, 0);
105 LE : Elements_Array renames
106 Left.Elements.EA (Index_Type'First .. Left.Last);
108 Elements : Elements_Access :=
109 new Elements_Type (Left.Last);
112 -- Elements of an indefinite vector are allocated, so we cannot
113 -- use simple slice assignment to give a value to our result.
114 -- Hence we must walk the array of the Left vector, and copy
115 -- each source element individually.
117 for I in Elements.EA'Range loop
119 if LE (I) /= null then
120 Elements.EA (I) := new Element_Type'(LE
(I
).all);
125 for J
in Index_Type
'First .. I
- 1 loop
126 Free
(Elements
.EA
(J
));
134 return (Controlled
with Elements
, Left
.Last
, 0, 0);
138 -- Neither of the vector parameters is empty, so we must compute the
139 -- length of the result vector and its last index. (This is the harder
140 -- case, because our computations must avoid overflow.)
142 -- There are two constraints we need to satisfy. The first constraint is
143 -- that a container cannot have more than Count_Type'Last elements, so
144 -- we must check the sum of the combined lengths. Note that we cannot
145 -- simply add the lengths, because of the possibilty of overflow.
147 if LN
> Count_Type
'Last - RN
then
148 raise Constraint_Error
with "new length is out of range";
151 -- It is now safe compute the length of the new vector.
155 -- The second constraint is that the new Last index value cannot
156 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
157 -- Count_Type'Base as the type for intermediate values.
159 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
161 -- We perform a two-part test. First we determine whether the
162 -- computed Last value lies in the base range of the type, and then
163 -- determine whether it lies in the range of the index (sub)type.
165 -- Last must satisfy this relation:
166 -- First + Length - 1 <= Last
168 -- First - 1 <= Last - Length
169 -- Which can rewrite as:
170 -- No_Index <= Last - Length
172 if Index_Type'Base'Last
- Index_Type
'Base (N
) < No_Index
then
173 raise Constraint_Error
with "new length is out of range";
176 -- We now know that the computed value of Last is within the base
177 -- range of the type, so it is safe to compute its value:
179 Last
:= No_Index
+ Index_Type
'Base (N
);
181 -- Finally we test whether the value is within the range of the
182 -- generic actual index subtype:
184 if Last
> Index_Type
'Last then
185 raise Constraint_Error
with "new length is out of range";
188 elsif Index_Type
'First <= 0 then
190 -- Here we can compute Last directly, in the normal way. We know that
191 -- No_Index is less than 0, so there is no danger of overflow when
192 -- adding the (positive) value of length.
194 J
:= Count_Type
'Base (No_Index
) + N
; -- Last
196 if J
> Count_Type
'Base (Index_Type
'Last) then
197 raise Constraint_Error
with "new length is out of range";
200 -- We know that the computed value (having type Count_Type) of Last
201 -- is within the range of the generic actual index subtype, so it is
202 -- safe to convert to Index_Type:
204 Last
:= Index_Type
'Base (J
);
207 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
208 -- must test the length indirectly (by working backwards from the
209 -- largest possible value of Last), in order to prevent overflow.
211 J
:= Count_Type
'Base (Index_Type
'Last) - N
; -- No_Index
213 if J
< Count_Type
'Base (No_Index
) then
214 raise Constraint_Error
with "new length is out of range";
217 -- We have determined that the result length would not create a Last
218 -- index value outside of the range of Index_Type, so we can now
219 -- safely compute its value.
221 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + N
);
225 LE
: Elements_Array
renames
226 Left
.Elements
.EA
(Index_Type
'First .. Left
.Last
);
228 RE
: Elements_Array
renames
229 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
231 Elements
: Elements_Access
:= new Elements_Type
(Last
);
233 I
: Index_Type
'Base := No_Index
;
236 -- Elements of an indefinite vector are allocated, so we cannot use
237 -- simple slice assignment to give a value to our result. Hence we
238 -- must walk the array of each vector parameter, and copy each source
239 -- element individually.
241 for LI
in LE
'Range loop
245 if LE
(LI
) /= null then
246 Elements
.EA
(I
) := new Element_Type
'(LE (LI).all);
251 for J in Index_Type'First .. I - 1 loop
252 Free (Elements.EA (J));
260 for RI in RE'Range loop
264 if RE (RI) /= null then
265 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
270 for J
in Index_Type
'First .. I
- 1 loop
271 Free
(Elements
.EA
(J
));
279 return (Controlled
with Elements
, Last
, 0, 0);
283 function "&" (Left
: Vector
; Right
: Element_Type
) return Vector
is
285 -- We decide that the capacity of the result is the sum of the lengths
286 -- of the parameters. We could decide to make it larger, but we have no
287 -- basis for knowing how much larger, so we just allocate the minimum
288 -- amount of storage.
290 -- Here we handle the easy case first, when the vector parameter (Left)
293 if Left
.Is_Empty
then
295 Elements
: Elements_Access
:= new Elements_Type
(Index_Type
'First);
299 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Right);
306 return (Controlled with Elements, Index_Type'First, 0, 0);
310 -- The vector parameter is not empty, so we must compute the length of
311 -- the result vector and its last index, but in such a way that overflow
312 -- is avoided. We must satisfy two constraints: the new length cannot
313 -- exceed Count_Type'Last, and the new Last index cannot exceed
316 if Left.Length = Count_Type'Last then
317 raise Constraint_Error with "new length is out of range";
320 if Left.Last >= Index_Type'Last then
321 raise Constraint_Error with "new length is out of range";
325 Last : constant Index_Type := Left.Last + 1;
327 LE : Elements_Array renames
328 Left.Elements.EA (Index_Type'First .. Left.Last);
330 Elements : Elements_Access :=
331 new Elements_Type (Last);
334 for I in LE'Range loop
336 if LE (I) /= null then
337 Elements.EA (I) := new Element_Type'(LE
(I
).all);
342 for J
in Index_Type
'First .. I
- 1 loop
343 Free
(Elements
.EA
(J
));
352 Elements
.EA
(Last
) := new Element_Type
'(Right);
356 for J in Index_Type'First .. Last - 1 loop
357 Free (Elements.EA (J));
364 return (Controlled with Elements, Last, 0, 0);
368 function "&" (Left : Element_Type; Right : Vector) return Vector is
370 -- We decide that the capacity of the result is the sum of the lengths
371 -- of the parameters. We could decide to make it larger, but we have no
372 -- basis for knowing how much larger, so we just allocate the minimum
373 -- amount of storage.
375 -- Here we handle the easy case first, when the vector parameter (Right)
378 if Right.Is_Empty then
380 Elements : Elements_Access := new Elements_Type (Index_Type'First);
384 Elements.EA (Index_Type'First) := new Element_Type'(Left
);
391 return (Controlled
with Elements
, Index_Type
'First, 0, 0);
395 -- The vector parameter is not empty, so we must compute the length of
396 -- the result vector and its last index, but in such a way that overflow
397 -- is avoided. We must satisfy two constraints: the new length cannot
398 -- exceed Count_Type'Last, and the new Last index cannot exceed
401 if Right
.Length
= Count_Type
'Last then
402 raise Constraint_Error
with "new length is out of range";
405 if Right
.Last
>= Index_Type
'Last then
406 raise Constraint_Error
with "new length is out of range";
410 Last
: constant Index_Type
:= Right
.Last
+ 1;
412 RE
: Elements_Array
renames
413 Right
.Elements
.EA
(Index_Type
'First .. Right
.Last
);
415 Elements
: Elements_Access
:=
416 new Elements_Type
(Last
);
418 I
: Index_Type
'Base := Index_Type
'First;
422 Elements
.EA
(I
) := new Element_Type
'(Left);
429 for RI in RE'Range loop
433 if RE (RI) /= null then
434 Elements.EA (I) := new Element_Type'(RE
(RI
).all);
439 for J
in Index_Type
'First .. I
- 1 loop
440 Free
(Elements
.EA
(J
));
448 return (Controlled
with Elements
, Last
, 0, 0);
452 function "&" (Left
, Right
: Element_Type
) return Vector
is
454 -- We decide that the capacity of the result is the sum of the lengths
455 -- of the parameters. We could decide to make it larger, but we have no
456 -- basis for knowing how much larger, so we just allocate the minimum
457 -- amount of storage.
459 -- We must compute the length of the result vector and its last index,
460 -- but in such a way that overflow is avoided. We must satisfy two
461 -- constraints: the new length cannot exceed Count_Type'Last (here, we
462 -- know that that condition is satisfied), and the new Last index cannot
463 -- exceed Index_Type'Last.
465 if Index_Type
'First >= Index_Type
'Last then
466 raise Constraint_Error
with "new length is out of range";
470 Last
: constant Index_Type
:= Index_Type
'First + 1;
471 Elements
: Elements_Access
:= new Elements_Type
(Last
);
475 Elements
.EA
(Index_Type
'First) := new Element_Type
'(Left);
483 Elements.EA (Last) := new Element_Type'(Right
);
486 Free
(Elements
.EA
(Index_Type
'First));
491 return (Controlled
with Elements
, Last
, 0, 0);
499 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
501 if Left
'Address = Right
'Address then
505 if Left
.Last
/= Right
.Last
then
509 for J
in Index_Type
'First .. Left
.Last
loop
510 if Left
.Elements
.EA
(J
) = null then
511 if Right
.Elements
.EA
(J
) /= null then
515 elsif Right
.Elements
.EA
(J
) = null then
518 elsif Left
.Elements
.EA
(J
).all /= Right
.Elements
.EA
(J
).all then
530 procedure Adjust
(Container
: in out Vector
) is
532 if Container
.Last
= No_Index
then
533 Container
.Elements
:= null;
538 L
: constant Index_Type
:= Container
.Last
;
539 E
: Elements_Array
renames
540 Container
.Elements
.EA
(Index_Type
'First .. L
);
543 Container
.Elements
:= null;
544 Container
.Last
:= No_Index
;
548 Container
.Elements
:= new Elements_Type
(L
);
550 for I
in E
'Range loop
551 if E
(I
) /= null then
552 Container
.Elements
.EA
(I
) := new Element_Type
'(E (I).all);
564 procedure Append (Container : in out Vector; New_Item : Vector) is
566 if Is_Empty (New_Item) then
570 if Container.Last = Index_Type'Last then
571 raise Constraint_Error with "vector is already at its maximum length";
581 (Container : in out Vector;
582 New_Item : Element_Type;
583 Count : Count_Type := 1)
590 if Container.Last = Index_Type'Last then
591 raise Constraint_Error with "vector is already at its maximum length";
605 function Capacity (Container : Vector) return Count_Type is
607 if Container.Elements = null then
611 return Container.Elements.EA'Length;
618 procedure Clear (Container : in out Vector) is
620 if Container.Busy > 0 then
621 raise Program_Error with
622 "attempt to tamper with elements (vector is busy)";
625 while Container.Last >= Index_Type'First loop
627 X : Element_Access := Container.Elements.EA (Container.Last);
629 Container.Elements.EA (Container.Last) := null;
630 Container.Last := Container.Last - 1;
642 Item : Element_Type) return Boolean
645 return Find_Index (Container, Item) /= No_Index;
653 (Container : in out Vector;
654 Index : Extended_Index;
655 Count : Count_Type := 1)
657 Old_Last : constant Index_Type'Base := Container.Last;
658 New_Last : Index_Type'Base;
659 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
660 J : Index_Type'Base; -- first index of items that slide down
663 -- Delete removes items from the vector, the number of which is the
664 -- minimum of the specified Count and the items (if any) that exist from
665 -- Index to Container.Last. There are no constraints on the specified
666 -- value of Count (it can be larger than what's available at this
667 -- position in the vector, for example), but there are constraints on
668 -- the allowed values of the Index.
670 -- As a precondition on the generic actual Index_Type, the base type
671 -- must include Index_Type'Pred (Index_Type'First); this is the value
672 -- that Container.Last assumes when the vector is empty. However, we do
673 -- not allow that as the value for Index when specifying which items
674 -- should be deleted, so we must manually check. (That the user is
675 -- allowed to specify the value at all here is a consequence of the
676 -- declaration of the Extended_Index subtype, which includes the values
677 -- in the base range that immediately precede and immediately follow the
678 -- values in the Index_Type.)
680 if Index < Index_Type'First then
681 raise Constraint_Error with "Index is out of range (too small)";
684 -- We do allow a value greater than Container.Last to be specified as
685 -- the Index, but only if it's immediately greater. This allows the
686 -- corner case of deleting no items from the back end of the vector to
687 -- be treated as a no-op. (It is assumed that specifying an index value
688 -- greater than Last + 1 indicates some deeper flaw in the caller's
689 -- algorithm, so that case is treated as a proper error.)
691 if Index > Old_Last then
692 if Index > Old_Last + 1 then
693 raise Constraint_Error with "Index is out of range (too large)";
699 -- Here and elsewhere we treat deleting 0 items from the container as a
700 -- no-op, even when the container is busy, so we simply return.
706 -- The internal elements array isn't guaranteed to exist unless we have
707 -- elements, so we handle that case here in order to avoid having to
708 -- check it later. (Note that an empty vector can never be busy, so
709 -- there's no semantic harm in returning early.)
711 if Container.Is_Empty then
715 -- The tampering bits exist to prevent an item from being deleted (or
716 -- otherwise harmfully manipulated) while it is being visited. Query,
717 -- Update, and Iterate increment the busy count on entry, and decrement
718 -- the count on exit. Delete checks the count to determine whether it is
719 -- being called while the associated callback procedure is executing.
721 if Container.Busy > 0 then
722 raise Program_Error with
723 "attempt to tamper with elements (vector is busy)";
726 -- We first calculate what's available for deletion starting at
727 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
728 -- Count_Type'Base as the type for intermediate values. (See function
729 -- Length for more information.)
731 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
732 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
735 Count2 := Count_Type'Base (Old_Last - Index + 1);
738 -- If the number of elements requested (Count) for deletion is equal to
739 -- (or greater than) the number of elements available (Count2) for
740 -- deletion beginning at Index, then everything from Index to
741 -- Container.Last is deleted (this is equivalent to Delete_Last).
743 if Count >= Count2 then
744 -- Elements in an indefinite vector are allocated, so we must iterate
745 -- over the loop and deallocate elements one-at-a-time. We work from
746 -- back to front, deleting the last element during each pass, in
747 -- order to gracefully handle deallocation failures.
750 EA : Elements_Array renames Container.Elements.EA;
753 while Container.Last >= Index loop
755 K : constant Index_Type := Container.Last;
756 X : Element_Access := EA (K);
759 -- We first isolate the element we're deleting, removing it
760 -- from the vector before we attempt to deallocate it, in
761 -- case the deallocation fails.
764 Container.Last := K - 1;
766 -- Container invariants have been restored, so it is now
767 -- safe to attempt to deallocate the element.
777 -- There are some elements that aren't being deleted (the requested
778 -- count was less than the available count), so we must slide them down
779 -- to Index. We first calculate the index values of the respective array
780 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
781 -- type for intermediate calculations. For the elements that slide down,
782 -- index value New_Last is the last index value of their new home, and
783 -- index value J is the first index of their old home.
785 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
786 New_Last
:= Old_Last
- Index_Type
'Base (Count
);
787 J
:= Index
+ Index_Type
'Base (Count
);
790 New_Last
:= Index_Type
'Base (Count_Type
'Base (Old_Last
) - Count
);
791 J
:= Index_Type
'Base (Count_Type
'Base (Index
) + Count
);
794 -- The internal elements array isn't guaranteed to exist unless we have
795 -- elements, but we have that guarantee here because we know we have
796 -- elements to slide. The array index values for each slice have
797 -- already been determined, so what remains to be done is to first
798 -- deallocate the elements that are being deleted, and then slide down
799 -- to Index the elements that aren't being deleted.
802 EA
: Elements_Array
renames Container
.Elements
.EA
;
805 -- Before we can slide down the elements that aren't being deleted,
806 -- we need to deallocate the elements that are being deleted.
808 for K
in Index
.. J
- 1 loop
810 X
: Element_Access
:= EA
(K
);
813 -- First we remove the element we're about to deallocate from
814 -- the vector, in case the deallocation fails, in order to
815 -- preserve representation invariants.
819 -- The element has been removed from the vector, so it is now
820 -- safe to attempt to deallocate it.
826 EA
(Index
.. New_Last
) := EA
(J
.. Old_Last
);
827 Container
.Last
:= New_Last
;
832 (Container
: in out Vector
;
833 Position
: in out Cursor
;
834 Count
: Count_Type
:= 1)
836 pragma Warnings
(Off
, Position
);
839 if Position
.Container
= null then
840 raise Constraint_Error
with "Position cursor has no element";
843 if Position
.Container
/= Container
'Unrestricted_Access then
844 raise Program_Error
with "Position cursor denotes wrong container";
847 if Position
.Index
> Container
.Last
then
848 raise Program_Error
with "Position index is out of range";
851 Delete
(Container
, Position
.Index
, Count
);
853 Position
:= No_Element
;
860 procedure Delete_First
861 (Container
: in out Vector
;
862 Count
: Count_Type
:= 1)
869 if Count
>= Length
(Container
) then
874 Delete
(Container
, Index_Type
'First, Count
);
881 procedure Delete_Last
882 (Container
: in out Vector
;
883 Count
: Count_Type
:= 1)
886 -- It is not permitted to delete items while the container is busy (for
887 -- example, we're in the middle of a passive iteration). However, we
888 -- always treat deleting 0 items as a no-op, even when we're busy, so we
889 -- simply return without checking.
895 -- We cannot simply subsume the empty case into the loop below (the loop
896 -- would iterate 0 times), because we rename the internal array object
897 -- (which is allocated), but an empty vector isn't guaranteed to have
898 -- actually allocated an array. (Note that an empty vector can never be
899 -- busy, so there's no semantic harm in returning early here.)
901 if Container
.Is_Empty
then
905 -- The tampering bits exist to prevent an item from being deleted (or
906 -- otherwise harmfully manipulated) while it is being visited. Query,
907 -- Update, and Iterate increment the busy count on entry, and decrement
908 -- the count on exit. Delete_Last checks the count to determine whether
909 -- it is being called while the associated callback procedure is
912 if Container
.Busy
> 0 then
913 raise Program_Error
with
914 "attempt to tamper with elements (vector is busy)";
917 -- Elements in an indefinite vector are allocated, so we must iterate
918 -- over the loop and deallocate elements one-at-a-time. We work from
919 -- back to front, deleting the last element during each pass, in order
920 -- to gracefully handle deallocation failures.
923 E
: Elements_Array
renames Container
.Elements
.EA
;
926 for Indx
in 1 .. Count_Type
'Min (Count
, Container
.Length
) loop
928 J
: constant Index_Type
:= Container
.Last
;
929 X
: Element_Access
:= E
(J
);
932 -- Note that we first isolate the element we're deleting,
933 -- removing it from the vector, before we actually deallocate
934 -- it, in order to preserve representation invariants even if
935 -- the deallocation fails.
938 Container
.Last
:= J
- 1;
940 -- Container invariants have been restored, so it is now safe
941 -- to deallocate the element.
955 Index
: Index_Type
) return Element_Type
958 if Index
> Container
.Last
then
959 raise Constraint_Error
with "Index is out of range";
963 EA
: constant Element_Access
:= Container
.Elements
.EA
(Index
);
967 raise Constraint_Error
with "element is empty";
974 function Element
(Position
: Cursor
) return Element_Type
is
976 if Position
.Container
= null then
977 raise Constraint_Error
with "Position cursor has no element";
980 if Position
.Index
> Position
.Container
.Last
then
981 raise Constraint_Error
with "Position cursor is out of range";
985 EA
: constant Element_Access
:=
986 Position
.Container
.Elements
.EA
(Position
.Index
);
990 raise Constraint_Error
with "element is empty";
1001 procedure Finalize
(Container
: in out Vector
) is
1003 Clear
(Container
); -- Checks busy-bit
1006 X
: Elements_Access
:= Container
.Elements
;
1008 Container
.Elements
:= null;
1018 (Container
: Vector
;
1019 Item
: Element_Type
;
1020 Position
: Cursor
:= No_Element
) return Cursor
1023 if Position
.Container
/= null then
1024 if Position
.Container
/= Container
'Unrestricted_Access then
1025 raise Program_Error
with "Position cursor denotes wrong container";
1028 if Position
.Index
> Container
.Last
then
1029 raise Program_Error
with "Position index is out of range";
1033 for J
in Position
.Index
.. Container
.Last
loop
1034 if Container
.Elements
.EA
(J
) /= null
1035 and then Container
.Elements
.EA
(J
).all = Item
1037 return (Container
'Unchecked_Access, J
);
1049 (Container
: Vector
;
1050 Item
: Element_Type
;
1051 Index
: Index_Type
:= Index_Type
'First) return Extended_Index
1054 for Indx
in Index
.. Container
.Last
loop
1055 if Container
.Elements
.EA
(Indx
) /= null
1056 and then Container
.Elements
.EA
(Indx
).all = Item
1069 function First
(Container
: Vector
) return Cursor
is
1071 if Is_Empty
(Container
) then
1075 return (Container
'Unchecked_Access, Index_Type
'First);
1082 function First_Element
(Container
: Vector
) return Element_Type
is
1084 if Container
.Last
= No_Index
then
1085 raise Constraint_Error
with "Container is empty";
1089 EA
: constant Element_Access
:=
1090 Container
.Elements
.EA
(Index_Type
'First);
1094 raise Constraint_Error
with "first element is empty";
1105 function First_Index
(Container
: Vector
) return Index_Type
is
1106 pragma Unreferenced
(Container
);
1108 return Index_Type
'First;
1111 ---------------------
1112 -- Generic_Sorting --
1113 ---------------------
1115 package body Generic_Sorting
is
1117 -----------------------
1118 -- Local Subprograms --
1119 -----------------------
1121 function Is_Less
(L
, R
: Element_Access
) return Boolean;
1122 pragma Inline
(Is_Less
);
1128 function Is_Less
(L
, R
: Element_Access
) return Boolean is
1135 return L
.all < R
.all;
1143 function Is_Sorted
(Container
: Vector
) return Boolean is
1145 if Container
.Last
<= Index_Type
'First then
1150 E
: Elements_Array
renames Container
.Elements
.EA
;
1152 for I
in Index_Type
'First .. Container
.Last
- 1 loop
1153 if Is_Less
(E
(I
+ 1), E
(I
)) then
1166 procedure Merge
(Target
, Source
: in out Vector
) is
1167 I
, J
: Index_Type
'Base;
1170 if Target
.Last
< Index_Type
'First then
1171 Move
(Target
=> Target
, Source
=> Source
);
1175 if Target
'Address = Source
'Address then
1179 if Source
.Last
< Index_Type
'First then
1183 if Source
.Busy
> 0 then
1184 raise Program_Error
with
1185 "attempt to tamper with elements (vector is busy)";
1188 I
:= Target
.Last
; -- original value (before Set_Length)
1189 Target
.Set_Length
(Length
(Target
) + Length
(Source
));
1191 J
:= Target
.Last
; -- new value (after Set_Length)
1192 while Source
.Last
>= Index_Type
'First loop
1194 (Source
.Last
<= Index_Type
'First
1195 or else not (Is_Less
1196 (Source
.Elements
.EA
(Source
.Last
),
1197 Source
.Elements
.EA
(Source
.Last
- 1))));
1199 if I
< Index_Type
'First then
1201 Src
: Elements_Array
renames
1202 Source
.Elements
.EA
(Index_Type
'First .. Source
.Last
);
1205 Target
.Elements
.EA
(Index_Type
'First .. J
) := Src
;
1206 Src
:= (others => null);
1209 Source
.Last
:= No_Index
;
1214 (I
<= Index_Type
'First
1215 or else not (Is_Less
1216 (Target
.Elements
.EA
(I
),
1217 Target
.Elements
.EA
(I
- 1))));
1220 Src
: Element_Access
renames Source
.Elements
.EA
(Source
.Last
);
1221 Tgt
: Element_Access
renames Target
.Elements
.EA
(I
);
1224 if Is_Less
(Src
, Tgt
) then
1225 Target
.Elements
.EA
(J
) := Tgt
;
1230 Target
.Elements
.EA
(J
) := Src
;
1232 Source
.Last
:= Source
.Last
- 1;
1244 procedure Sort
(Container
: in out Vector
) is
1246 procedure Sort
is new Generic_Array_Sort
1247 (Index_Type
=> Index_Type
,
1248 Element_Type
=> Element_Access
,
1249 Array_Type
=> Elements_Array
,
1252 -- Start of processing for Sort
1255 if Container
.Last
<= Index_Type
'First then
1259 if Container
.Lock
> 0 then
1260 raise Program_Error
with
1261 "attempt to tamper with cursors (vector is locked)";
1264 Sort
(Container
.Elements
.EA
(Index_Type
'First .. Container
.Last
));
1267 end Generic_Sorting
;
1273 function Has_Element
(Position
: Cursor
) return Boolean is
1275 if Position
.Container
= null then
1279 return Position
.Index
<= Position
.Container
.Last
;
1287 (Container
: in out Vector
;
1288 Before
: Extended_Index
;
1289 New_Item
: Element_Type
;
1290 Count
: Count_Type
:= 1)
1292 Old_Length
: constant Count_Type
:= Container
.Length
;
1294 Max_Length
: Count_Type
'Base; -- determined from range of Index_Type
1295 New_Length
: Count_Type
'Base; -- sum of current length and Count
1296 New_Last
: Index_Type
'Base; -- last index of vector after insertion
1298 Index
: Index_Type
'Base; -- scratch for intermediate values
1299 J
: Count_Type
'Base; -- scratch
1301 New_Capacity
: Count_Type
'Base; -- length of new, expanded array
1302 Dst_Last
: Index_Type
'Base; -- last index of new, expanded array
1303 Dst
: Elements_Access
; -- new, expanded internal array
1306 -- As a precondition on the generic actual Index_Type, the base type
1307 -- must include Index_Type'Pred (Index_Type'First); this is the value
1308 -- that Container.Last assumes when the vector is empty. However, we do
1309 -- not allow that as the value for Index when specifying where the new
1310 -- items should be inserted, so we must manually check. (That the user
1311 -- is allowed to specify the value at all here is a consequence of the
1312 -- declaration of the Extended_Index subtype, which includes the values
1313 -- in the base range that immediately precede and immediately follow the
1314 -- values in the Index_Type.)
1316 if Before
< Index_Type
'First then
1317 raise Constraint_Error
with
1318 "Before index is out of range (too small)";
1321 -- We do allow a value greater than Container.Last to be specified as
1322 -- the Index, but only if it's immediately greater. This allows for the
1323 -- case of appending items to the back end of the vector. (It is assumed
1324 -- that specifying an index value greater than Last + 1 indicates some
1325 -- deeper flaw in the caller's algorithm, so that case is treated as a
1328 if Before
> Container
.Last
1329 and then Before
> Container
.Last
+ 1
1331 raise Constraint_Error
with
1332 "Before index is out of range (too large)";
1335 -- We treat inserting 0 items into the container as a no-op, even when
1336 -- the container is busy, so we simply return.
1342 -- There are two constraints we need to satisfy. The first constraint is
1343 -- that a container cannot have more than Count_Type'Last elements, so
1344 -- we must check the sum of the current length and the insertion
1345 -- count. Note that we cannot simply add these values, because of the
1346 -- possibilty of overflow.
1348 if Old_Length
> Count_Type
'Last - Count
then
1349 raise Constraint_Error
with "Count is out of range";
1352 -- It is now safe compute the length of the new vector, without fear of
1355 New_Length
:= Old_Length
+ Count
;
1357 -- The second constraint is that the new Last index value cannot exceed
1358 -- Index_Type'Last. In each branch below, we calculate the maximum
1359 -- length (computed from the range of values in Index_Type), and then
1360 -- compare the new length to the maximum length. If the new length is
1361 -- acceptable, then we compute the new last index from that.
1363 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1364 -- We have to handle the case when there might be more values in the
1365 -- range of Index_Type than in the range of Count_Type.
1367 if Index_Type'First <= 0 then
1368 -- We know that No_Index (the same as Index_Type'First - 1) is
1369 -- less than 0, so it is safe to compute the following sum without
1370 -- fear of overflow.
1372 Index := No_Index + Index_Type'Base (Count_Type'Last);
1374 if Index <= Index_Type'Last then
1375 -- We have determined that range of Index_Type has at least as
1376 -- many values as in Count_Type, so Count_Type'Last is the
1377 -- maximum number of items that are allowed.
1379 Max_Length := Count_Type'Last;
1382 -- The range of Index_Type has fewer values than in Count_Type,
1383 -- so the maximum number of items is computed from the range of
1386 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1390 -- No_Index is equal or greater than 0, so we can safely compute
1391 -- the difference without fear of overflow (which we would have to
1392 -- worry about if No_Index were less than 0, but that case is
1395 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1398 elsif Index_Type'First <= 0 then
1399 -- We know that No_Index (the same as Index_Type'First - 1) is less
1400 -- than 0, so it is safe to compute the following sum without fear of
1403 J := Count_Type'Base (No_Index) + Count_Type'Last;
1405 if J <= Count_Type'Base (Index_Type'Last) then
1406 -- We have determined that range of Index_Type has at least as
1407 -- many values as in Count_Type, so Count_Type'Last is the maximum
1408 -- number of items that are allowed.
1410 Max_Length := Count_Type'Last;
1413 -- The range of Index_Type has fewer values than Count_Type does,
1414 -- so the maximum number of items is computed from the range of
1418 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1422 -- No_Index is equal or greater than 0, so we can safely compute the
1423 -- difference without fear of overflow (which we would have to worry
1424 -- about if No_Index were less than 0, but that case is handled
1428 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1431 -- We have just computed the maximum length (number of items). We must
1432 -- now compare the requested length to the maximum length, as we do not
1433 -- allow a vector expand beyond the maximum (because that would create
1434 -- an internal array with a last index value greater than
1435 -- Index_Type'Last, with no way to index those elements).
1437 if New_Length > Max_Length then
1438 raise Constraint_Error with "Count is out of range";
1441 -- New_Last is the last index value of the items in the container after
1442 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1443 -- compute its value from the New_Length.
1445 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1446 New_Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1449 New_Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1452 if Container
.Elements
= null then
1453 pragma Assert
(Container
.Last
= No_Index
);
1455 -- This is the simplest case, with which we must always begin: we're
1456 -- inserting items into an empty vector that hasn't allocated an
1457 -- internal array yet. Note that we don't need to check the busy bit
1458 -- here, because an empty container cannot be busy.
1460 -- In an indefinite vector, elements are allocated individually, and
1461 -- stored as access values on the internal array (the length of which
1462 -- represents the vector "capacity"), which is separately allocated.
1464 Container
.Elements
:= new Elements_Type
(New_Last
);
1466 -- The element backbone has been successfully allocated, so now we
1467 -- allocate the elements.
1469 for Idx
in Container
.Elements
.EA
'Range loop
1470 -- In order to preserve container invariants, we always attempt
1471 -- the element allocation first, before setting the Last index
1472 -- value, in case the allocation fails (either because there is no
1473 -- storage available, or because element initialization fails).
1475 Container
.Elements
.EA
(Idx
) := new Element_Type
'(New_Item);
1477 -- The allocation of the element succeeded, so it is now safe to
1478 -- update the Last index, restoring container invariants.
1480 Container.Last := Idx;
1486 -- The tampering bits exist to prevent an item from being harmfully
1487 -- manipulated while it is being visited. Query, Update, and Iterate
1488 -- increment the busy count on entry, and decrement the count on
1489 -- exit. Insert checks the count to determine whether it is being called
1490 -- while the associated callback procedure is executing.
1492 if Container.Busy > 0 then
1493 raise Program_Error with
1494 "attempt to tamper with elements (vector is busy)";
1497 if New_Length <= Container.Elements.EA'Length then
1498 -- In this case, we're inserting elements into a vector that has
1499 -- already allocated an internal array, and the existing array has
1500 -- enough unused storage for the new items.
1503 E : Elements_Array renames Container.Elements.EA;
1504 K : Index_Type'Base;
1507 if Before > Container.Last then
1508 -- The new items are being appended to the vector, so no
1509 -- sliding of existing elements is required.
1511 for Idx in Before .. New_Last loop
1512 -- In order to preserve container invariants, we always
1513 -- attempt the element allocation first, before setting the
1514 -- Last index value, in case the allocation fails (either
1515 -- because there is no storage available, or because element
1516 -- initialization fails).
1518 E (Idx) := new Element_Type'(New_Item
);
1520 -- The allocation of the element succeeded, so it is now
1521 -- safe to update the Last index, restoring container
1524 Container
.Last
:= Idx
;
1528 -- The new items are being inserted before some existing
1529 -- elements, so we must slide the existing elements up to their
1530 -- new home. We use the wider of Index_Type'Base and
1531 -- Count_Type'Base as the type for intermediate index values.
1533 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1534 Index := Before + Index_Type'Base (Count);
1537 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1540 -- The new items are being inserted in the middle of the array,
1541 -- in the range [Before, Index). Copy the existing elements to
1542 -- the end of the array, to make room for the new items.
1544 E (Index .. New_Last) := E (Before .. Container.Last);
1545 Container.Last := New_Last;
1547 -- We have copied the existing items up to the end of the
1548 -- array, to make room for the new items in the middle of
1549 -- the array. Now we actually allocate the new items.
1551 -- Note: initialize K outside loop to make it clear that
1552 -- K always has a value if the exception handler triggers.
1556 while K < Index loop
1557 E (K) := new Element_Type'(New_Item
);
1564 -- Values in the range [Before, K) were successfully
1565 -- allocated, but values in the range [K, Index) are
1566 -- stale (these array positions contain copies of the
1567 -- old items, that did not get assigned a new item,
1568 -- because the allocation failed). We must finish what
1569 -- we started by clearing out all of the stale values,
1570 -- leaving a "hole" in the middle of the array.
1572 E
(K
.. Index
- 1) := (others => null);
1581 -- In this case, we're inserting elements into a vector that has already
1582 -- allocated an internal array, but the existing array does not have
1583 -- enough storage, so we must allocate a new, longer array. In order to
1584 -- guarantee that the amortized insertion cost is O(1), we always
1585 -- allocate an array whose length is some power-of-two factor of the
1586 -- current array length. (The new array cannot have a length less than
1587 -- the New_Length of the container, but its last index value cannot be
1588 -- greater than Index_Type'Last.)
1590 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
1591 while New_Capacity
< New_Length
loop
1592 if New_Capacity
> Count_Type
'Last / 2 then
1593 New_Capacity
:= Count_Type
'Last;
1597 New_Capacity
:= 2 * New_Capacity
;
1600 if New_Capacity
> Max_Length
then
1601 -- We have reached the limit of capacity, so no further expansion
1602 -- will occur. (This is not a problem, as there is never a need to
1603 -- have more capacity than the maximum container length.)
1605 New_Capacity
:= Max_Length
;
1608 -- We have computed the length of the new internal array (and this is
1609 -- what "vector capacity" means), so use that to compute its last index.
1611 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1612 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
1616 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
1619 -- Now we allocate the new, longer internal array. If the allocation
1620 -- fails, we have not changed any container state, so no side-effect
1621 -- will occur as a result of propagating the exception.
1623 Dst := new Elements_Type (Dst_Last);
1625 -- We have our new internal array. All that needs to be done now is to
1626 -- copy the existing items (if any) from the old array (the "source"
1627 -- array) to the new array (the "destination" array), and then
1628 -- deallocate the old array.
1631 Src : Elements_Access := Container.Elements;
1634 Dst.EA (Index_Type'First .. Before - 1) :=
1635 Src.EA (Index_Type'First .. Before - 1);
1637 if Before > Container.Last then
1638 -- The new items are being appended to the vector, so no
1639 -- sliding of existing elements is required.
1641 -- We have copied the elements from to the old, source array to
1642 -- the new, destination array, so we can now deallocate the old
1645 Container.Elements := Dst;
1648 -- Now we append the new items.
1650 for Idx in Before .. New_Last loop
1651 -- In order to preserve container invariants, we always
1652 -- attempt the element allocation first, before setting the
1653 -- Last index value, in case the allocation fails (either
1654 -- because there is no storage available, or because element
1655 -- initialization fails).
1657 Dst.EA (Idx) := new Element_Type'(New_Item
);
1659 -- The allocation of the element succeeded, so it is now safe
1660 -- to update the Last index, restoring container invariants.
1662 Container
.Last
:= Idx
;
1666 -- The new items are being inserted before some existing elements,
1667 -- so we must slide the existing elements up to their new home.
1669 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1670 Index := Before + Index_Type'Base (Count);
1673 Index := Index_Type'Base (Count_Type'Base (Before) + Count);
1676 Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last);
1678 -- We have copied the elements from to the old, source array to
1679 -- the new, destination array, so we can now deallocate the old
1682 Container.Elements := Dst;
1683 Container.Last := New_Last;
1686 -- The new array has a range in the middle containing null access
1687 -- values. We now fill in that partion of the array with the new
1690 for Idx in Before .. Index - 1 loop
1691 -- Note that container invariants have already been satisfied
1692 -- (in particular, the Last index value of the vector has
1693 -- already been updated), so if this allocation fails we simply
1694 -- let it propagate.
1696 Dst.EA (Idx) := new Element_Type'(New_Item
);
1703 (Container
: in out Vector
;
1704 Before
: Extended_Index
;
1707 N
: constant Count_Type
:= Length
(New_Item
);
1708 J
: Index_Type
'Base;
1711 -- Use Insert_Space to create the "hole" (the destination slice) into
1712 -- which we copy the source items.
1714 Insert_Space
(Container
, Before
, Count
=> N
);
1717 -- There's nothing else to do here (vetting of parameters was
1718 -- performed already in Insert_Space), so we simply return.
1723 if Container
'Address /= New_Item
'Address then
1724 -- This is the simple case. New_Item denotes an object different
1725 -- from Container, so there's nothing special we need to do to copy
1726 -- the source items to their destination, because all of the source
1727 -- items are contiguous.
1730 subtype Src_Index_Subtype
is Index_Type
'Base range
1731 Index_Type
'First .. New_Item
.Last
;
1733 Src
: Elements_Array
renames
1734 New_Item
.Elements
.EA
(Src_Index_Subtype
);
1736 Dst
: Elements_Array
renames Container
.Elements
.EA
;
1738 Dst_Index
: Index_Type
'Base;
1741 Dst_Index
:= Before
- 1;
1742 for Src_Index
in Src
'Range loop
1743 Dst_Index
:= Dst_Index
+ 1;
1745 if Src
(Src_Index
) /= null then
1746 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1754 -- New_Item denotes the same object as Container, so an insertion has
1755 -- potentially split the source items. The first source slice is
1756 -- [Index_Type'First, Before), and the second source slice is
1757 -- [J, Container.Last], where index value J is the first index of the
1758 -- second slice. (J gets computed below, but only after we have
1759 -- determined that the second source slice is non-empty.) The
1760 -- destination slice is always the range [Before, J). We perform the
1761 -- copy in two steps, using each of the two slices of the source items.
1764 L : constant Index_Type'Base := Before - 1;
1766 subtype Src_Index_Subtype is Index_Type'Base range
1767 Index_Type'First .. L;
1769 Src : Elements_Array renames
1770 Container.Elements.EA (Src_Index_Subtype);
1772 Dst : Elements_Array renames Container.Elements.EA;
1774 Dst_Index : Index_Type'Base;
1777 -- We first copy the source items that precede the space we
1778 -- inserted. (If Before equals Index_Type'First, then this first
1779 -- source slice will be empty, which is harmless.)
1781 Dst_Index := Before - 1;
1782 for Src_Index in Src'Range loop
1783 Dst_Index := Dst_Index + 1;
1785 if Src (Src_Index) /= null then
1786 Dst (Dst_Index) := new Element_Type'(Src
(Src_Index
).all);
1790 if Src
'Length = N
then
1791 -- The new items were effectively appended to the container, so we
1792 -- have already copied all of the items that need to be copied.
1793 -- We return early here, even though the source slice below is
1794 -- empty (so the assignment would be harmless), because we want to
1795 -- avoid computing J, which will overflow if J is greater than
1796 -- Index_Type'Base'Last.
1802 -- Index value J is the first index of the second source slice. (It is
1803 -- also 1 greater than the last index of the destination slice.) Note
1804 -- that we want to avoid computing J, if J is greater than
1805 -- Index_Type'Base'Last, in order to avoid overflow. We prevent that by
1806 -- returning early above, immediately after copying the first slice of
1807 -- the source, and determining that this second slice of the source is
1810 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1811 J := Before + Index_Type'Base (N);
1814 J := Index_Type'Base (Count_Type'Base (Before) + N);
1818 subtype Src_Index_Subtype is Index_Type'Base range
1819 J .. Container.Last;
1821 Src : Elements_Array renames
1822 Container.Elements.EA (Src_Index_Subtype);
1824 Dst : Elements_Array renames Container.Elements.EA;
1826 Dst_Index : Index_Type'Base;
1829 -- We next copy the source items that follow the space we
1830 -- inserted. Index value Dst_Index is the first index of that portion
1831 -- of the destination that receives this slice of the source. (For
1832 -- the reasons given above, this slice is guaranteed to be
1835 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1836 Dst_Index
:= J
- Index_Type
'Base (Src
'Length);
1839 Dst_Index
:= Index_Type
'Base (Count_Type
'Base (J
) - Src
'Length);
1842 for Src_Index
in Src
'Range loop
1843 if Src
(Src_Index
) /= null then
1844 Dst
(Dst_Index
) := new Element_Type
'(Src (Src_Index).all);
1847 Dst_Index := Dst_Index + 1;
1853 (Container : in out Vector;
1857 Index : Index_Type'Base;
1860 if Before.Container /= null
1861 and then Before.Container /= Container'Unchecked_Access
1863 raise Program_Error with "Before cursor denotes wrong container";
1866 if Is_Empty (New_Item) then
1870 if Before.Container = null
1871 or else Before.Index > Container.Last
1873 if Container.Last = Index_Type'Last then
1874 raise Constraint_Error with
1875 "vector is already at its maximum length";
1878 Index := Container.Last + 1;
1881 Index := Before.Index;
1884 Insert (Container, Index, New_Item);
1888 (Container : in out Vector;
1891 Position : out Cursor)
1893 Index : Index_Type'Base;
1896 if Before.Container /= null
1897 and then Before.Container /= Vector_Access'(Container
'Unchecked_Access)
1899 raise Program_Error
with "Before cursor denotes wrong container";
1902 if Is_Empty
(New_Item
) then
1903 if Before
.Container
= null
1904 or else Before
.Index
> Container
.Last
1906 Position
:= No_Element
;
1908 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1914 if Before
.Container
= null
1915 or else Before
.Index
> Container
.Last
1917 if Container
.Last
= Index_Type
'Last then
1918 raise Constraint_Error
with
1919 "vector is already at its maximum length";
1922 Index
:= Container
.Last
+ 1;
1925 Index
:= Before
.Index
;
1928 Insert
(Container
, Index
, New_Item
);
1930 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1934 (Container : in out Vector;
1936 New_Item : Element_Type;
1937 Count : Count_Type := 1)
1939 Index : Index_Type'Base;
1942 if Before.Container /= null
1943 and then Before.Container /= Container'Unchecked_Access
1945 raise Program_Error with "Before cursor denotes wrong container";
1952 if Before.Container = null
1953 or else Before.Index > Container.Last
1955 if Container.Last = Index_Type'Last then
1956 raise Constraint_Error with
1957 "vector is already at its maximum length";
1960 Index := Container.Last + 1;
1963 Index := Before.Index;
1966 Insert (Container, Index, New_Item, Count);
1970 (Container : in out Vector;
1972 New_Item : Element_Type;
1973 Position : out Cursor;
1974 Count : Count_Type := 1)
1976 Index : Index_Type'Base;
1979 if Before.Container /= null
1980 and then Before.Container /= Container'Unchecked_Access
1982 raise Program_Error with "Before cursor denotes wrong container";
1986 if Before.Container = null
1987 or else Before.Index > Container.Last
1989 Position := No_Element;
1991 Position := (Container'Unchecked_Access, Before.Index);
1997 if Before.Container = null
1998 or else Before.Index > Container.Last
2000 if Container.Last = Index_Type'Last then
2001 raise Constraint_Error with
2002 "vector is already at its maximum length";
2005 Index := Container.Last + 1;
2008 Index := Before.Index;
2011 Insert (Container, Index, New_Item, Count);
2013 Position := (Container'Unchecked_Access, Index);
2020 procedure Insert_Space
2021 (Container : in out Vector;
2022 Before : Extended_Index;
2023 Count : Count_Type := 1)
2025 Old_Length : constant Count_Type := Container.Length;
2027 Max_Length : Count_Type'Base; -- determined from range of Index_Type
2028 New_Length : Count_Type'Base; -- sum of current length and Count
2029 New_Last : Index_Type'Base; -- last index of vector after insertion
2031 Index : Index_Type'Base; -- scratch for intermediate values
2032 J : Count_Type'Base; -- scratch
2034 New_Capacity : Count_Type'Base; -- length of new, expanded array
2035 Dst_Last : Index_Type'Base; -- last index of new, expanded array
2036 Dst : Elements_Access; -- new, expanded internal array
2039 -- As a precondition on the generic actual Index_Type, the base type
2040 -- must include Index_Type'Pred (Index_Type'First); this is the value
2041 -- that Container.Last assumes when the vector is empty. However, we do
2042 -- not allow that as the value for Index when specifying where the new
2043 -- items should be inserted, so we must manually check. (That the user
2044 -- is allowed to specify the value at all here is a consequence of the
2045 -- declaration of the Extended_Index subtype, which includes the values
2046 -- in the base range that immediately precede and immediately follow the
2047 -- values in the Index_Type.)
2049 if Before < Index_Type'First then
2050 raise Constraint_Error with
2051 "Before index is out of range (too small)";
2054 -- We do allow a value greater than Container.Last to be specified as
2055 -- the Index, but only if it's immediately greater. This allows for the
2056 -- case of appending items to the back end of the vector. (It is assumed
2057 -- that specifying an index value greater than Last + 1 indicates some
2058 -- deeper flaw in the caller's algorithm, so that case is treated as a
2061 if Before > Container.Last
2062 and then Before > Container.Last + 1
2064 raise Constraint_Error with
2065 "Before index is out of range (too large)";
2068 -- We treat inserting 0 items into the container as a no-op, even when
2069 -- the container is busy, so we simply return.
2075 -- There are two constraints we need to satisfy. The first constraint is
2076 -- that a container cannot have more than Count_Type'Last elements, so
2077 -- we must check the sum of the current length and the insertion
2078 -- count. Note that we cannot simply add these values, because of the
2079 -- possibilty of overflow.
2081 if Old_Length > Count_Type'Last - Count then
2082 raise Constraint_Error with "Count is out of range";
2085 -- It is now safe compute the length of the new vector, without fear of
2088 New_Length := Old_Length + Count;
2090 -- The second constraint is that the new Last index value cannot exceed
2091 -- Index_Type'Last. In each branch below, we calculate the maximum
2092 -- length (computed from the range of values in Index_Type), and then
2093 -- compare the new length to the maximum length. If the new length is
2094 -- acceptable, then we compute the new last index from that.
2096 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2097 -- We have to handle the case when there might be more values in the
2098 -- range of Index_Type than in the range of Count_Type.
2100 if Index_Type
'First <= 0 then
2101 -- We know that No_Index (the same as Index_Type'First - 1) is
2102 -- less than 0, so it is safe to compute the following sum without
2103 -- fear of overflow.
2105 Index
:= No_Index
+ Index_Type
'Base (Count_Type
'Last);
2107 if Index
<= Index_Type
'Last then
2108 -- We have determined that range of Index_Type has at least as
2109 -- many values as in Count_Type, so Count_Type'Last is the
2110 -- maximum number of items that are allowed.
2112 Max_Length
:= Count_Type
'Last;
2115 -- The range of Index_Type has fewer values than in Count_Type,
2116 -- so the maximum number of items is computed from the range of
2119 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2123 -- No_Index is equal or greater than 0, so we can safely compute
2124 -- the difference without fear of overflow (which we would have to
2125 -- worry about if No_Index were less than 0, but that case is
2128 Max_Length
:= Count_Type
'Base (Index_Type
'Last - No_Index
);
2131 elsif Index_Type
'First <= 0 then
2132 -- We know that No_Index (the same as Index_Type'First - 1) is less
2133 -- than 0, so it is safe to compute the following sum without fear of
2136 J
:= Count_Type
'Base (No_Index
) + Count_Type
'Last;
2138 if J
<= Count_Type
'Base (Index_Type
'Last) then
2139 -- We have determined that range of Index_Type has at least as
2140 -- many values as in Count_Type, so Count_Type'Last is the maximum
2141 -- number of items that are allowed.
2143 Max_Length
:= Count_Type
'Last;
2146 -- The range of Index_Type has fewer values than Count_Type does,
2147 -- so the maximum number of items is computed from the range of
2151 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2155 -- No_Index is equal or greater than 0, so we can safely compute the
2156 -- difference without fear of overflow (which we would have to worry
2157 -- about if No_Index were less than 0, but that case is handled
2161 Count_Type
'Base (Index_Type
'Last) - Count_Type
'Base (No_Index
);
2164 -- We have just computed the maximum length (number of items). We must
2165 -- now compare the requested length to the maximum length, as we do not
2166 -- allow a vector expand beyond the maximum (because that would create
2167 -- an internal array with a last index value greater than
2168 -- Index_Type'Last, with no way to index those elements).
2170 if New_Length
> Max_Length
then
2171 raise Constraint_Error
with "Count is out of range";
2174 -- New_Last is the last index value of the items in the container after
2175 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
2176 -- compute its value from the New_Length.
2178 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2179 New_Last := No_Index + Index_Type'Base (New_Length);
2182 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
2185 if Container.Elements = null then
2186 pragma Assert (Container.Last = No_Index);
2188 -- This is the simplest case, with which we must always begin: we're
2189 -- inserting items into an empty vector that hasn't allocated an
2190 -- internal array yet. Note that we don't need to check the busy bit
2191 -- here, because an empty container cannot be busy.
2193 -- In an indefinite vector, elements are allocated individually, and
2194 -- stored as access values on the internal array (the length of which
2195 -- represents the vector "capacity"), which is separately
2196 -- allocated. We have no elements here (because we're inserting
2197 -- "space"), so all we need to do is allocate the backbone.
2199 Container.Elements := new Elements_Type (New_Last);
2200 Container.Last := New_Last;
2205 -- The tampering bits exist to prevent an item from being harmfully
2206 -- manipulated while it is being visited. Query, Update, and Iterate
2207 -- increment the busy count on entry, and decrement the count on
2208 -- exit. Insert checks the count to determine whether it is being called
2209 -- while the associated callback procedure is executing.
2211 if Container.Busy > 0 then
2212 raise Program_Error with
2213 "attempt to tamper with elements (vector is busy)";
2216 if New_Length <= Container.Elements.EA'Length then
2217 -- In this case, we're inserting elements into a vector that has
2218 -- already allocated an internal array, and the existing array has
2219 -- enough unused storage for the new items.
2222 E : Elements_Array renames Container.Elements.EA;
2225 if Before <= Container.Last then
2226 -- The new space is being inserted before some existing
2227 -- elements, so we must slide the existing elements up to their
2228 -- new home. We use the wider of Index_Type'Base and
2229 -- Count_Type'Base as the type for intermediate index values.
2231 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2232 Index
:= Before
+ Index_Type
'Base (Count
);
2235 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2238 E
(Index
.. New_Last
) := E
(Before
.. Container
.Last
);
2239 E
(Before
.. Index
- 1) := (others => null);
2243 Container
.Last
:= New_Last
;
2247 -- In this case, we're inserting elements into a vector that has already
2248 -- allocated an internal array, but the existing array does not have
2249 -- enough storage, so we must allocate a new, longer array. In order to
2250 -- guarantee that the amortized insertion cost is O(1), we always
2251 -- allocate an array whose length is some power-of-two factor of the
2252 -- current array length. (The new array cannot have a length less than
2253 -- the New_Length of the container, but its last index value cannot be
2254 -- greater than Index_Type'Last.)
2256 New_Capacity
:= Count_Type
'Max (1, Container
.Elements
.EA
'Length);
2257 while New_Capacity
< New_Length
loop
2258 if New_Capacity
> Count_Type
'Last / 2 then
2259 New_Capacity
:= Count_Type
'Last;
2263 New_Capacity
:= 2 * New_Capacity
;
2266 if New_Capacity
> Max_Length
then
2267 -- We have reached the limit of capacity, so no further expansion
2268 -- will occur. (This is not a problem, as there is never a need to
2269 -- have more capacity than the maximum container length.)
2271 New_Capacity
:= Max_Length
;
2274 -- We have computed the length of the new internal array (and this is
2275 -- what "vector capacity" means), so use that to compute its last index.
2277 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2278 Dst_Last := No_Index + Index_Type'Base (New_Capacity);
2282 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity);
2285 -- Now we allocate the new, longer internal array. If the allocation
2286 -- fails, we have not changed any container state, so no side-effect
2287 -- will occur as a result of propagating the exception.
2289 Dst := new Elements_Type (Dst_Last);
2291 -- We have our new internal array. All that needs to be done now is to
2292 -- copy the existing items (if any) from the old array (the "source"
2293 -- array) to the new array (the "destination" array), and then
2294 -- deallocate the old array.
2297 Src : Elements_Access := Container.Elements;
2300 Dst.EA (Index_Type'First .. Before - 1) :=
2301 Src.EA (Index_Type'First .. Before - 1);
2303 if Before <= Container.Last then
2304 -- The new items are being inserted before some existing elements,
2305 -- so we must slide the existing elements up to their new home.
2307 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2308 Index
:= Before
+ Index_Type
'Base (Count
);
2311 Index
:= Index_Type
'Base (Count_Type
'Base (Before
) + Count
);
2314 Dst
.EA
(Index
.. New_Last
) := Src
.EA
(Before
.. Container
.Last
);
2317 -- We have copied the elements from to the old, source array to the
2318 -- new, destination array, so we can now restore invariants, and
2319 -- deallocate the old array.
2321 Container
.Elements
:= Dst
;
2322 Container
.Last
:= New_Last
;
2327 procedure Insert_Space
2328 (Container
: in out Vector
;
2330 Position
: out Cursor
;
2331 Count
: Count_Type
:= 1)
2333 Index
: Index_Type
'Base;
2336 if Before
.Container
/= null
2337 and then Before
.Container
/= Container
'Unchecked_Access
2339 raise Program_Error
with "Before cursor denotes wrong container";
2343 if Before
.Container
= null
2344 or else Before
.Index
> Container
.Last
2346 Position
:= No_Element
;
2348 Position
:= (Container
'Unchecked_Access, Before
.Index
);
2354 if Before
.Container
= null
2355 or else Before
.Index
> Container
.Last
2357 if Container
.Last
= Index_Type
'Last then
2358 raise Constraint_Error
with
2359 "vector is already at its maximum length";
2362 Index
:= Container
.Last
+ 1;
2365 Index
:= Before
.Index
;
2368 Insert_Space
(Container
, Index
, Count
);
2370 Position
:= Cursor
'(Container'Unchecked_Access, Index);
2377 function Is_Empty (Container : Vector) return Boolean is
2379 return Container.Last < Index_Type'First;
2387 (Container : Vector;
2388 Process : not null access procedure (Position : Cursor))
2390 V : Vector renames Container'Unrestricted_Access.all;
2391 B : Natural renames V.Busy;
2397 for Indx in Index_Type'First .. Container.Last loop
2398 Process (Cursor'(Container
'Unchecked_Access, Indx
));
2413 function Last
(Container
: Vector
) return Cursor
is
2415 if Is_Empty
(Container
) then
2419 return (Container
'Unchecked_Access, Container
.Last
);
2426 function Last_Element
(Container
: Vector
) return Element_Type
is
2428 if Container
.Last
= No_Index
then
2429 raise Constraint_Error
with "Container is empty";
2433 EA
: constant Element_Access
:=
2434 Container
.Elements
.EA
(Container
.Last
);
2438 raise Constraint_Error
with "last element is empty";
2449 function Last_Index
(Container
: Vector
) return Extended_Index
is
2451 return Container
.Last
;
2458 function Length
(Container
: Vector
) return Count_Type
is
2459 L
: constant Index_Type
'Base := Container
.Last
;
2460 F
: constant Index_Type
:= Index_Type
'First;
2463 -- The base range of the index type (Index_Type'Base) might not include
2464 -- all values for length (Count_Type). Contrariwise, the index type
2465 -- might include values outside the range of length. Hence we use
2466 -- whatever type is wider for intermediate values when calculating
2467 -- length. Note that no matter what the index type is, the maximum
2468 -- length to which a vector is allowed to grow is always the minimum
2469 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2471 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2472 -- to have a base range of -128 .. 127, but the corresponding vector
2473 -- would have lengths in the range 0 .. 255. In this case we would need
2474 -- to use Count_Type'Base for intermediate values.
2476 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2477 -- vector would have a maximum length of 10, but the index values lie
2478 -- outside the range of Count_Type (which is only 32 bits). In this
2479 -- case we would need to use Index_Type'Base for intermediate values.
2481 if Count_Type
'Base'Last >= Index_Type'Pos (Index_Type'Base'Last
) then
2482 return Count_Type
'Base (L
) - Count_Type
'Base (F
) + 1;
2484 return Count_Type
(L
- F
+ 1);
2493 (Target
: in out Vector
;
2494 Source
: in out Vector
)
2497 if Target
'Address = Source
'Address then
2501 if Source
.Busy
> 0 then
2502 raise Program_Error
with
2503 "attempt to tamper with elements (Source is busy)";
2506 Clear
(Target
); -- Checks busy-bit
2509 Target_Elements
: constant Elements_Access
:= Target
.Elements
;
2511 Target
.Elements
:= Source
.Elements
;
2512 Source
.Elements
:= Target_Elements
;
2515 Target
.Last
:= Source
.Last
;
2516 Source
.Last
:= No_Index
;
2523 function Next
(Position
: Cursor
) return Cursor
is
2525 if Position
.Container
= null then
2529 if Position
.Index
< Position
.Container
.Last
then
2530 return (Position
.Container
, Position
.Index
+ 1);
2540 procedure Next
(Position
: in out Cursor
) is
2542 if Position
.Container
= null then
2546 if Position
.Index
< Position
.Container
.Last
then
2547 Position
.Index
:= Position
.Index
+ 1;
2549 Position
:= No_Element
;
2557 procedure Prepend
(Container
: in out Vector
; New_Item
: Vector
) is
2559 Insert
(Container
, Index_Type
'First, New_Item
);
2563 (Container
: in out Vector
;
2564 New_Item
: Element_Type
;
2565 Count
: Count_Type
:= 1)
2578 procedure Previous
(Position
: in out Cursor
) is
2580 if Position
.Container
= null then
2584 if Position
.Index
> Index_Type
'First then
2585 Position
.Index
:= Position
.Index
- 1;
2587 Position
:= No_Element
;
2591 function Previous
(Position
: Cursor
) return Cursor
is
2593 if Position
.Container
= null then
2597 if Position
.Index
> Index_Type
'First then
2598 return (Position
.Container
, Position
.Index
- 1);
2608 procedure Query_Element
2609 (Container
: Vector
;
2611 Process
: not null access procedure (Element
: Element_Type
))
2613 V
: Vector
renames Container
'Unrestricted_Access.all;
2614 B
: Natural renames V
.Busy
;
2615 L
: Natural renames V
.Lock
;
2618 if Index
> Container
.Last
then
2619 raise Constraint_Error
with "Index is out of range";
2622 if V
.Elements
.EA
(Index
) = null then
2623 raise Constraint_Error
with "element is null";
2630 Process
(V
.Elements
.EA
(Index
).all);
2642 procedure Query_Element
2644 Process
: not null access procedure (Element
: Element_Type
))
2647 if Position
.Container
= null then
2648 raise Constraint_Error
with "Position cursor has no element";
2651 Query_Element
(Position
.Container
.all, Position
.Index
, Process
);
2659 (Stream
: not null access Root_Stream_Type
'Class;
2660 Container
: out Vector
)
2662 Length
: Count_Type
'Base;
2663 Last
: Index_Type
'Base := Index_Type
'Pred (Index_Type
'First);
2670 Count_Type
'Base'Read (Stream, Length);
2672 if Length > Capacity (Container) then
2673 Reserve_Capacity (Container, Capacity => Length);
2676 for J in Count_Type range 1 .. Length loop
2679 Boolean'Read (Stream, B);
2682 Container.Elements.EA (Last) :=
2683 new Element_Type'(Element_Type
'Input (Stream
));
2686 Container
.Last
:= Last
;
2691 (Stream
: not null access Root_Stream_Type
'Class;
2692 Position
: out Cursor
)
2695 raise Program_Error
with "attempt to stream vector cursor";
2698 ---------------------
2699 -- Replace_Element --
2700 ---------------------
2702 procedure Replace_Element
2703 (Container
: in out Vector
;
2705 New_Item
: Element_Type
)
2708 if Index
> Container
.Last
then
2709 raise Constraint_Error
with "Index is out of range";
2712 if Container
.Lock
> 0 then
2713 raise Program_Error
with
2714 "attempt to tamper with cursors (vector is locked)";
2718 X
: Element_Access
:= Container
.Elements
.EA
(Index
);
2720 Container
.Elements
.EA
(Index
) := new Element_Type
'(New_Item);
2723 end Replace_Element;
2725 procedure Replace_Element
2726 (Container : in out Vector;
2728 New_Item : Element_Type)
2731 if Position.Container = null then
2732 raise Constraint_Error with "Position cursor has no element";
2735 if Position.Container /= Container'Unrestricted_Access then
2736 raise Program_Error with "Position cursor denotes wrong container";
2739 if Position.Index > Container.Last then
2740 raise Constraint_Error with "Position cursor is out of range";
2743 if Container.Lock > 0 then
2744 raise Program_Error with
2745 "attempt to tamper with cursors (vector is locked)";
2749 X : Element_Access := Container.Elements.EA (Position.Index);
2751 Container.Elements.EA (Position.Index) := new Element_Type'(New_Item
);
2754 end Replace_Element
;
2756 ----------------------
2757 -- Reserve_Capacity --
2758 ----------------------
2760 procedure Reserve_Capacity
2761 (Container
: in out Vector
;
2762 Capacity
: Count_Type
)
2764 N
: constant Count_Type
:= Length
(Container
);
2766 Index
: Count_Type
'Base;
2767 Last
: Index_Type
'Base;
2770 -- Reserve_Capacity can be used to either expand the storage available
2771 -- for elements (this would be its typical use, in anticipation of
2772 -- future insertion), or to trim back storage. In the latter case,
2773 -- storage can only be trimmed back to the limit of the container
2774 -- length. Note that Reserve_Capacity neither deletes (active) elements
2775 -- nor inserts elements; it only affects container capacity, never
2776 -- container length.
2778 if Capacity
= 0 then
2779 -- This is a request to trim back storage, to the minimum amount
2780 -- possible given the current state of the container.
2783 -- The container is empty, so in this unique case we can
2784 -- deallocate the entire internal array. Note that an empty
2785 -- container can never be busy, so there's no need to check the
2789 X
: Elements_Access
:= Container
.Elements
;
2791 -- First we remove the internal array from the container, to
2792 -- handle the case when the deallocation raises an exception
2793 -- (although that's unlikely, since this is simply an array of
2794 -- access values, all of which are null).
2796 Container
.Elements
:= null;
2798 -- Container invariants have been restored, so it is now safe
2799 -- to attempt to deallocate the internal array.
2804 elsif N
< Container
.Elements
.EA
'Length then
2805 -- The container is not empty, and the current length is less than
2806 -- the current capacity, so there's storage available to trim. In
2807 -- this case, we allocate a new internal array having a length
2808 -- that exactly matches the number of items in the
2809 -- container. (Reserve_Capacity does not delete active elements,
2810 -- so this is the best we can do with respect to minimizing
2813 if Container
.Busy
> 0 then
2814 raise Program_Error
with
2815 "attempt to tamper with elements (vector is busy)";
2819 subtype Array_Index_Subtype
is Index_Type
'Base range
2820 Index_Type
'First .. Container
.Last
;
2822 Src
: Elements_Array
renames
2823 Container
.Elements
.EA
(Array_Index_Subtype
);
2825 X
: Elements_Access
:= Container
.Elements
;
2828 -- Although we have isolated the old internal array that we're
2829 -- going to deallocate, we don't deallocate it until we have
2830 -- successfully allocated a new one. If there is an exception
2831 -- during allocation (because there is not enough storage), we
2832 -- let it propagate without causing any side-effect.
2834 Container
.Elements
:= new Elements_Type
'(Container.Last, Src);
2836 -- We have succesfully allocated a new internal array (with a
2837 -- smaller length than the old one, and containing a copy of
2838 -- just the active elements in the container), so we can
2839 -- deallocate the old array.
2848 -- Reserve_Capacity can be used to expand the storage available for
2849 -- elements, but we do not let the capacity grow beyond the number of
2850 -- values in Index_Type'Range. (Were it otherwise, there would be no way
2851 -- to refer to the elements with index values greater than
2852 -- Index_Type'Last, so that storage would be wasted.) Here we compute
2853 -- the Last index value of the new internal array, in a way that avoids
2854 -- any possibility of overflow.
2856 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
2857 -- We perform a two-part test. First we determine whether the
2858 -- computed Last value lies in the base range of the type, and then
2859 -- determine whether it lies in the range of the index (sub)type.
2861 -- Last must satisfy this relation:
2862 -- First + Length - 1 <= Last
2863 -- We regroup terms:
2864 -- First - 1 <= Last - Length
2865 -- Which can rewrite as:
2866 -- No_Index <= Last - Length
2868 if Index_Type
'Base'Last - Index_Type'Base (Capacity) < No_Index then
2869 raise Constraint_Error with "Capacity is out of range";
2872 -- We now know that the computed value of Last is within the base
2873 -- range of the type, so it is safe to compute its value:
2875 Last := No_Index + Index_Type'Base (Capacity);
2877 -- Finally we test whether the value is within the range of the
2878 -- generic actual index subtype:
2880 if Last > Index_Type'Last then
2881 raise Constraint_Error with "Capacity is out of range";
2884 elsif Index_Type'First <= 0 then
2885 -- Here we can compute Last directly, in the normal way. We know that
2886 -- No_Index is less than 0, so there is no danger of overflow when
2887 -- adding the (positive) value of Capacity.
2889 Index := Count_Type'Base (No_Index) + Capacity; -- Last
2891 if Index > Count_Type'Base (Index_Type'Last) then
2892 raise Constraint_Error with "Capacity is out of range";
2895 -- We know that the computed value (having type Count_Type) of Last
2896 -- is within the range of the generic actual index subtype, so it is
2897 -- safe to convert to Index_Type:
2899 Last := Index_Type'Base (Index);
2902 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2903 -- must test the length indirectly (by working backwards from the
2904 -- largest possible value of Last), in order to prevent overflow.
2906 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index
2908 if Index < Count_Type'Base (No_Index) then
2909 raise Constraint_Error with "Capacity is out of range";
2912 -- We have determined that the value of Capacity would not create a
2913 -- Last index value outside of the range of Index_Type, so we can now
2914 -- safely compute its value.
2916 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity);
2919 -- The requested capacity is non-zero, but we don't know yet whether
2920 -- this is a request for expansion or contraction of storage.
2922 if Container.Elements = null then
2923 -- The container is empty (it doesn't even have an internal array),
2924 -- so this represents a request to allocate storage having the given
2927 Container.Elements := new Elements_Type (Last);
2931 if Capacity <= N then
2932 -- This is a request to trim back storage, but only to the limit of
2933 -- what's already in the container. (Reserve_Capacity never deletes
2934 -- active elements, it only reclaims excess storage.)
2936 if N < Container.Elements.EA'Length then
2937 -- The container is not empty (because the requested capacity is
2938 -- positive, and less than or equal to the container length), and
2939 -- the current length is less than the current capacity, so
2940 -- there's storage available to trim. In this case, we allocate a
2941 -- new internal array having a length that exactly matches the
2942 -- number of items in the container.
2944 if Container.Busy > 0 then
2945 raise Program_Error with
2946 "attempt to tamper with elements (vector is busy)";
2950 subtype Array_Index_Subtype is Index_Type'Base range
2951 Index_Type'First .. Container.Last;
2953 Src : Elements_Array renames
2954 Container.Elements.EA (Array_Index_Subtype);
2956 X : Elements_Access := Container.Elements;
2959 -- Although we have isolated the old internal array that we're
2960 -- going to deallocate, we don't deallocate it until we have
2961 -- successfully allocated a new one. If there is an exception
2962 -- during allocation (because there is not enough storage), we
2963 -- let it propagate without causing any side-effect.
2965 Container.Elements := new Elements_Type'(Container
.Last
, Src
);
2967 -- We have succesfully allocated a new internal array (with a
2968 -- smaller length than the old one, and containing a copy of
2969 -- just the active elements in the container), so it is now
2970 -- safe to deallocate the old array.
2979 -- The requested capacity is larger than the container length (the
2980 -- number of active elements). Whether this represents a request for
2981 -- expansion or contraction of the current capacity depends on what the
2982 -- current capacity is.
2984 if Capacity
= Container
.Elements
.EA
'Length then
2985 -- The requested capacity matches the existing capacity, so there's
2986 -- nothing to do here. We treat this case as a no-op, and simply
2987 -- return without checking the busy bit.
2992 -- There is a change in the capacity of a non-empty container, so a new
2993 -- internal array will be allocated. (The length of the new internal
2994 -- array could be less or greater than the old internal array. We know
2995 -- only that the length of the new internal array is greater than the
2996 -- number of active elements in the container.) We must check whether
2997 -- the container is busy before doing anything else.
2999 if Container
.Busy
> 0 then
3000 raise Program_Error
with
3001 "attempt to tamper with elements (vector is busy)";
3004 -- We now allocate a new internal array, having a length different from
3005 -- its current value.
3008 X
: Elements_Access
:= Container
.Elements
;
3010 subtype Index_Subtype
is Index_Type
'Base range
3011 Index_Type
'First .. Container
.Last
;
3014 -- We now allocate a new internal array, having a length different
3015 -- from its current value.
3017 Container
.Elements
:= new Elements_Type
(Last
);
3019 -- We have successfully allocated the new internal array, so now we
3020 -- move the existing elements from the existing the old internal
3021 -- array onto the new one. Note that we're just copying access
3022 -- values, to this should not raise any exceptions.
3024 Container
.Elements
.EA
(Index_Subtype
) := X
.EA
(Index_Subtype
);
3026 -- We have moved the elements from the old interal array, so now we
3027 -- can deallocate it.
3031 end Reserve_Capacity
;
3033 ----------------------
3034 -- Reverse_Elements --
3035 ----------------------
3037 procedure Reverse_Elements
(Container
: in out Vector
) is
3039 if Container
.Length
<= 1 then
3043 if Container
.Lock
> 0 then
3044 raise Program_Error
with
3045 "attempt to tamper with cursors (vector is locked)";
3051 E
: Elements_Array
renames Container
.Elements
.EA
;
3054 I
:= Index_Type
'First;
3055 J
:= Container
.Last
;
3058 EI
: constant Element_Access
:= E
(I
);
3069 end Reverse_Elements
;
3075 function Reverse_Find
3076 (Container
: Vector
;
3077 Item
: Element_Type
;
3078 Position
: Cursor
:= No_Element
) return Cursor
3080 Last
: Index_Type
'Base;
3083 if Position
.Container
/= null
3084 and then Position
.Container
/= Container
'Unchecked_Access
3086 raise Program_Error
with "Position cursor denotes wrong container";
3089 if Position
.Container
= null
3090 or else Position
.Index
> Container
.Last
3092 Last
:= Container
.Last
;
3094 Last
:= Position
.Index
;
3097 for Indx
in reverse Index_Type
'First .. Last
loop
3098 if Container
.Elements
.EA
(Indx
) /= null
3099 and then Container
.Elements
.EA
(Indx
).all = Item
3101 return (Container
'Unchecked_Access, Indx
);
3108 ------------------------
3109 -- Reverse_Find_Index --
3110 ------------------------
3112 function Reverse_Find_Index
3113 (Container
: Vector
;
3114 Item
: Element_Type
;
3115 Index
: Index_Type
:= Index_Type
'Last) return Extended_Index
3117 Last
: constant Index_Type
'Base :=
3118 (if Index
> Container
.Last
then Container
.Last
else Index
);
3120 for Indx
in reverse Index_Type
'First .. Last
loop
3121 if Container
.Elements
.EA
(Indx
) /= null
3122 and then Container
.Elements
.EA
(Indx
).all = Item
3129 end Reverse_Find_Index
;
3131 ---------------------
3132 -- Reverse_Iterate --
3133 ---------------------
3135 procedure Reverse_Iterate
3136 (Container
: Vector
;
3137 Process
: not null access procedure (Position
: Cursor
))
3139 V
: Vector
renames Container
'Unrestricted_Access.all;
3140 B
: Natural renames V
.Busy
;
3146 for Indx
in reverse Index_Type
'First .. Container
.Last
loop
3147 Process
(Cursor
'(Container'Unchecked_Access, Indx));
3156 end Reverse_Iterate;
3162 procedure Set_Length
3163 (Container : in out Vector;
3164 Length : Count_Type)
3166 Count : constant Count_Type'Base := Container.Length - Length;
3169 -- Set_Length allows the user to set the length explicitly, instead of
3170 -- implicitly as a side-effect of deletion or insertion. If the
3171 -- requested length is less than the current length, this is equivalent
3172 -- to deleting items from the back end of the vector. If the requested
3173 -- length is greater than the current length, then this is equivalent to
3174 -- inserting "space" (nonce items) at the end.
3177 Container.Delete_Last (Count);
3179 elsif Container.Last >= Index_Type'Last then
3180 raise Constraint_Error with "vector is already at its maximum length";
3183 Container.Insert_Space (Container.Last + 1, -Count);
3192 (Container : in out Vector;
3196 if I > Container.Last then
3197 raise Constraint_Error with "I index is out of range";
3200 if J > Container.Last then
3201 raise Constraint_Error with "J index is out of range";
3208 if Container.Lock > 0 then
3209 raise Program_Error with
3210 "attempt to tamper with cursors (vector is locked)";
3214 EI : Element_Access renames Container.Elements.EA (I);
3215 EJ : Element_Access renames Container.Elements.EA (J);
3217 EI_Copy : constant Element_Access := EI;
3226 (Container : in out Vector;
3230 if I.Container = null then
3231 raise Constraint_Error with "I cursor has no element";
3234 if J.Container = null then
3235 raise Constraint_Error with "J cursor has no element";
3238 if I.Container /= Container'Unrestricted_Access then
3239 raise Program_Error with "I cursor denotes wrong container";
3242 if J.Container /= Container'Unrestricted_Access then
3243 raise Program_Error with "J cursor denotes wrong container";
3246 Swap (Container, I.Index, J.Index);
3254 (Container : Vector;
3255 Index : Extended_Index) return Cursor
3258 if Index not in Index_Type'First .. Container.Last then
3262 return Cursor'(Container
'Unchecked_Access, Index
);
3269 function To_Index
(Position
: Cursor
) return Extended_Index
is
3271 if Position
.Container
= null then
3275 if Position
.Index
<= Position
.Container
.Last
then
3276 return Position
.Index
;
3286 function To_Vector
(Length
: Count_Type
) return Vector
is
3287 Index
: Count_Type
'Base;
3288 Last
: Index_Type
'Base;
3289 Elements
: Elements_Access
;
3293 return Empty_Vector
;
3296 -- We create a vector object with a capacity that matches the specified
3297 -- Length, but we do not allow the vector capacity (the length of the
3298 -- internal array) to exceed the number of values in Index_Type'Range
3299 -- (otherwise, there would be no way to refer to those components via an
3300 -- index). We must therefore check whether the specified Length would
3301 -- create a Last index value greater than Index_Type'Last.
3303 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
3304 -- We perform a two-part test. First we determine whether the
3305 -- computed Last value lies in the base range of the type, and then
3306 -- determine whether it lies in the range of the index (sub)type.
3308 -- Last must satisfy this relation:
3309 -- First + Length - 1 <= Last
3310 -- We regroup terms:
3311 -- First - 1 <= Last - Length
3312 -- Which can rewrite as:
3313 -- No_Index <= Last - Length
3315 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
3316 raise Constraint_Error
with "Length is out of range";
3319 -- We now know that the computed value of Last is within the base
3320 -- range of the type, so it is safe to compute its value:
3322 Last
:= No_Index
+ Index_Type
'Base (Length
);
3324 -- Finally we test whether the value is within the range of the
3325 -- generic actual index subtype:
3327 if Last
> Index_Type
'Last then
3328 raise Constraint_Error
with "Length is out of range";
3331 elsif Index_Type
'First <= 0 then
3332 -- Here we can compute Last directly, in the normal way. We know that
3333 -- No_Index is less than 0, so there is no danger of overflow when
3334 -- adding the (positive) value of Length.
3336 Index
:= Count_Type
'Base (No_Index
) + Length
; -- Last
3338 if Index
> Count_Type
'Base (Index_Type
'Last) then
3339 raise Constraint_Error
with "Length is out of range";
3342 -- We know that the computed value (having type Count_Type) of Last
3343 -- is within the range of the generic actual index subtype, so it is
3344 -- safe to convert to Index_Type:
3346 Last
:= Index_Type
'Base (Index
);
3349 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3350 -- must test the length indirectly (by working backwards from the
3351 -- largest possible value of Last), in order to prevent overflow.
3353 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
3355 if Index
< Count_Type
'Base (No_Index
) then
3356 raise Constraint_Error
with "Length is out of range";
3359 -- We have determined that the value of Length would not create a
3360 -- Last index value outside of the range of Index_Type, so we can now
3361 -- safely compute its value.
3363 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
3366 Elements
:= new Elements_Type
(Last
);
3368 return Vector
'(Controlled with Elements, Last, 0, 0);
3372 (New_Item : Element_Type;
3373 Length : Count_Type) return Vector
3375 Index : Count_Type'Base;
3376 Last : Index_Type'Base;
3377 Elements : Elements_Access;
3381 return Empty_Vector;
3384 -- We create a vector object with a capacity that matches the specified
3385 -- Length, but we do not allow the vector capacity (the length of the
3386 -- internal array) to exceed the number of values in Index_Type'Range
3387 -- (otherwise, there would be no way to refer to those components via an
3388 -- index). We must therefore check whether the specified Length would
3389 -- create a Last index value greater than Index_Type'Last.
3391 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
3392 -- We perform a two-part test. First we determine whether the
3393 -- computed Last value lies in the base range of the type, and then
3394 -- determine whether it lies in the range of the index (sub)type.
3396 -- Last must satisfy this relation:
3397 -- First + Length - 1 <= Last
3398 -- We regroup terms:
3399 -- First - 1 <= Last - Length
3400 -- Which can rewrite as:
3401 -- No_Index <= Last - Length
3403 if Index_Type
'Base'Last - Index_Type'Base (Length) < No_Index then
3404 raise Constraint_Error with "Length is out of range";
3407 -- We now know that the computed value of Last is within the base
3408 -- range of the type, so it is safe to compute its value:
3410 Last := No_Index + Index_Type'Base (Length);
3412 -- Finally we test whether the value is within the range of the
3413 -- generic actual index subtype:
3415 if Last > Index_Type'Last then
3416 raise Constraint_Error with "Length is out of range";
3419 elsif Index_Type'First <= 0 then
3420 -- Here we can compute Last directly, in the normal way. We know that
3421 -- No_Index is less than 0, so there is no danger of overflow when
3422 -- adding the (positive) value of Length.
3424 Index := Count_Type'Base (No_Index) + Length; -- Last
3426 if Index > Count_Type'Base (Index_Type'Last) then
3427 raise Constraint_Error with "Length is out of range";
3430 -- We know that the computed value (having type Count_Type) of Last
3431 -- is within the range of the generic actual index subtype, so it is
3432 -- safe to convert to Index_Type:
3434 Last := Index_Type'Base (Index);
3437 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
3438 -- must test the length indirectly (by working backwards from the
3439 -- largest possible value of Last), in order to prevent overflow.
3441 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
3443 if Index < Count_Type'Base (No_Index) then
3444 raise Constraint_Error with "Length is out of range";
3447 -- We have determined that the value of Length would not create a
3448 -- Last index value outside of the range of Index_Type, so we can now
3449 -- safely compute its value.
3451 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
3454 Elements := new Elements_Type (Last);
3456 -- We use Last as the index of the loop used to populate the internal
3457 -- array with items. In general, we prefer to initialize the loop index
3458 -- immediately prior to entering the loop. However, Last is also used in
3459 -- the exception handler (to reclaim elements that have been allocated,
3460 -- before propagating the exception), and the initialization of Last
3461 -- after entering the block containing the handler confuses some static
3462 -- analysis tools, with respect to whether Last has been properly
3463 -- initialized when the handler executes. So here we initialize our loop
3464 -- variable earlier than we prefer, before entering the block, so there
3466 Last := Index_Type'First;
3470 Elements.EA (Last) := new Element_Type'(New_Item
);
3471 exit when Last
= Elements
.Last
;
3477 for J
in Index_Type
'First .. Last
- 1 loop
3478 Free
(Elements
.EA
(J
));
3485 return (Controlled
with Elements
, Last
, 0, 0);
3488 --------------------
3489 -- Update_Element --
3490 --------------------
3492 procedure Update_Element
3493 (Container
: in out Vector
;
3495 Process
: not null access procedure (Element
: in out Element_Type
))
3497 B
: Natural renames Container
.Busy
;
3498 L
: Natural renames Container
.Lock
;
3501 if Index
> Container
.Last
then
3502 raise Constraint_Error
with "Index is out of range";
3505 if Container
.Elements
.EA
(Index
) = null then
3506 raise Constraint_Error
with "element is null";
3513 Process
(Container
.Elements
.EA
(Index
).all);
3525 procedure Update_Element
3526 (Container
: in out Vector
;
3528 Process
: not null access procedure (Element
: in out Element_Type
))
3531 if Position
.Container
= null then
3532 raise Constraint_Error
with "Position cursor has no element";
3535 if Position
.Container
/= Container
'Unrestricted_Access then
3536 raise Program_Error
with "Position cursor denotes wrong container";
3539 Update_Element
(Container
, Position
.Index
, Process
);
3547 (Stream
: not null access Root_Stream_Type
'Class;
3550 N
: constant Count_Type
:= Length
(Container
);
3553 Count_Type
'Base'Write (Stream, N);
3560 E : Elements_Array renames Container.Elements.EA;
3563 for Indx in Index_Type'First .. Container.Last loop
3564 if E (Indx) = null then
3565 Boolean'Write (Stream, False);
3567 Boolean'Write (Stream, True);
3568 Element_Type'Output (Stream, E (Indx).all);
3575 (Stream : not null access Root_Stream_Type'Class;
3579 raise Program_Error with "attempt to stream vector cursor";
3582 end Ada.Containers.Indefinite_Vectors;