1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
9 -- Copyright (C) 2004-2011, 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.Finalization; use Ada.Finalization;
33 with System; use type System.Address;
35 package body Ada.Containers.Bounded_Vectors is
37 type Iterator is new Limited_Controlled and
38 Vector_Iterator_Interfaces.Reversible_Iterator with
40 Container : Vector_Access;
44 overriding procedure Finalize (Object : in out Iterator);
46 overriding function First (Object : Iterator) return Cursor;
47 overriding function Last (Object : Iterator) return Cursor;
49 overriding function Next
51 Position : Cursor) return Cursor;
53 overriding function Previous
55 Position : Cursor) return Cursor;
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
61 function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
67 function "&" (Left, Right : Vector) return Vector is
68 LN : constant Count_Type := Length (Left);
69 RN : constant Count_Type := Length (Right);
70 N : Count_Type'Base; -- length of result
71 J : Count_Type'Base; -- for computing intermediate index values
72 Last : Index_Type'Base; -- Last index of result
75 -- We decide that the capacity of the result is the sum of the lengths
76 -- of the vector parameters. We could decide to make it larger, but we
77 -- have no basis for knowing how much larger, so we just allocate the
78 -- minimum amount of storage.
80 -- Here we handle the easy cases first, when one of the vector
81 -- parameters is empty. (We say "easy" because there's nothing to
82 -- compute, that can potentially overflow.)
89 return Vector'(Capacity => RN,
90 Elements => Right.Elements (1 .. RN),
96 return Vector'(Capacity => LN,
97 Elements => Left.Elements (1 .. LN),
102 -- Neither of the vector parameters is empty, so must compute the length
103 -- of the result vector and its last index. (This is the harder case,
104 -- because our computations must avoid overflow.)
106 -- There are two constraints we need to satisfy. The first constraint is
107 -- that a container cannot have more than Count_Type'Last elements, so
108 -- we must check the sum of the combined lengths. Note that we cannot
109 -- simply add the lengths, because of the possibility of overflow.
111 if LN > Count_Type'Last - RN then
112 raise Constraint_Error with "new length is out of range";
115 -- It is now safe compute the length of the new vector, without fear of
120 -- The second constraint is that the new Last index value cannot
121 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
122 -- Count_Type'Base as the type for intermediate values.
124 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
125 -- We perform a two-part test. First we determine whether the
126 -- computed Last value lies in the base range of the type, and then
127 -- determine whether it lies in the range of the index (sub)type.
129 -- Last must satisfy this relation:
130 -- First + Length - 1 <= Last
132 -- First - 1 <= Last - Length
133 -- Which can rewrite as:
134 -- No_Index <= Last - Length
136 if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then
137 raise Constraint_Error with "new length is out of range";
140 -- We now know that the computed value of Last is within the base
141 -- range of the type, so it is safe to compute its value:
143 Last := No_Index + Index_Type'Base (N);
145 -- Finally we test whether the value is within the range of the
146 -- generic actual index subtype:
148 if Last > Index_Type'Last then
149 raise Constraint_Error with "new length is out of range";
152 elsif Index_Type'First <= 0 then
153 -- Here we can compute Last directly, in the normal way. We know that
154 -- No_Index is less than 0, so there is no danger of overflow when
155 -- adding the (positive) value of length.
157 J := Count_Type'Base (No_Index) + N; -- Last
159 if J > Count_Type'Base (Index_Type'Last) then
160 raise Constraint_Error with "new length is out of range";
163 -- We know that the computed value (having type Count_Type) of Last
164 -- is within the range of the generic actual index subtype, so it is
165 -- safe to convert to Index_Type:
167 Last := Index_Type'Base (J);
170 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
171 -- must test the length indirectly (by working backwards from the
172 -- largest possible value of Last), in order to prevent overflow.
174 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
176 if J < Count_Type'Base (No_Index) then
177 raise Constraint_Error with "new length is out of range";
180 -- We have determined that the result length would not create a Last
181 -- index value outside of the range of Index_Type, so we can now
182 -- safely compute its value.
184 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
188 LE : Elements_Array renames Left.Elements (1 .. LN);
189 RE : Elements_Array renames Right.Elements (1 .. RN);
192 return Vector'(Capacity => N,
199 function "&" (Left : Vector; Right : Element_Type) return Vector is
200 LN : constant Count_Type := Length (Left);
203 -- We decide that the capacity of the result is the sum of the lengths
204 -- of the parameters. We could decide to make it larger, but we have no
205 -- basis for knowing how much larger, so we just allocate the minimum
206 -- amount of storage.
208 -- We must compute the length of the result vector and its last index,
209 -- but in such a way that overflow is avoided. We must satisfy two
210 -- constraints: the new length cannot exceed Count_Type'Last, and the
211 -- new Last index cannot exceed Index_Type'Last.
213 if LN = Count_Type'Last then
214 raise Constraint_Error with "new length is out of range";
217 if Left.Last >= Index_Type'Last then
218 raise Constraint_Error with "new length is out of range";
221 return Vector'(Capacity => LN + 1,
222 Elements => Left.Elements (1 .. LN) & Right,
223 Last => Left.Last + 1,
227 function "&" (Left : Element_Type; Right : Vector) return Vector is
228 RN : constant Count_Type := Length (Right);
231 -- We decide that the capacity of the result is the sum of the lengths
232 -- of the parameters. We could decide to make it larger, but we have no
233 -- basis for knowing how much larger, so we just allocate the minimum
234 -- amount of storage.
236 -- We compute the length of the result vector and its last index, but in
237 -- such a way that overflow is avoided. We must satisfy two constraints:
238 -- the new length cannot exceed Count_Type'Last, and the new Last index
239 -- cannot exceed Index_Type'Last.
241 if RN = Count_Type'Last then
242 raise Constraint_Error with "new length is out of range";
245 if Right.Last >= Index_Type'Last then
246 raise Constraint_Error with "new length is out of range";
249 return Vector'(Capacity => 1 + RN,
250 Elements => Left & Right.Elements (1 .. RN),
251 Last => Right.Last + 1,
255 function "&" (Left, Right : Element_Type) return Vector is
257 -- We decide that the capacity of the result is the sum of the lengths
258 -- of the parameters. We could decide to make it larger, but we have no
259 -- basis for knowing how much larger, so we just allocate the minimum
260 -- amount of storage.
262 -- We must compute the length of the result vector and its last index,
263 -- but in such a way that overflow is avoided. We must satisfy two
264 -- constraints: the new length cannot exceed Count_Type'Last (here, we
265 -- know that that condition is satisfied), and the new Last index cannot
266 -- exceed Index_Type'Last.
268 if Index_Type'First >= Index_Type'Last then
269 raise Constraint_Error with "new length is out of range";
272 return Vector'(Capacity => 2,
273 Elements => (Left, Right),
274 Last => Index_Type'First + 1,
282 overriding function "=" (Left, Right : Vector) return Boolean is
284 if Left'Address = Right'Address then
288 if Left.Last /= Right.Last then
292 for J in Count_Type range 1 .. Left.Length loop
293 if Left.Elements (J) /= Right.Elements (J) then
305 procedure Assign (Target : in out Vector; Source : Vector) is
307 if Target'Address = Source'Address then
311 if Target.Capacity < Source.Length then
312 raise Capacity_Error -- ???
313 with "Target capacity is less than Source length";
318 Target.Elements (1 .. Source.Length) :=
319 Source.Elements (1 .. Source.Length);
321 Target.Last := Source.Last;
328 procedure Append (Container : in out Vector; New_Item : Vector) is
330 if New_Item.Is_Empty then
334 if Container.Last >= Index_Type'Last then
335 raise Constraint_Error with "vector is already at its maximum length";
338 Container.Insert (Container.Last + 1, New_Item);
342 (Container : in out Vector;
343 New_Item : Element_Type;
344 Count : Count_Type := 1)
351 if Container.Last >= Index_Type'Last then
352 raise Constraint_Error with "vector is already at its maximum length";
355 Container.Insert (Container.Last + 1, New_Item, Count);
362 function Capacity (Container : Vector) return Count_Type is
364 return Container.Elements'Length;
371 procedure Clear (Container : in out Vector) is
373 if Container.Busy > 0 then
374 raise Program_Error with
375 "attempt to tamper with cursors (vector is busy)";
378 Container.Last := No_Index;
387 Item : Element_Type) return Boolean
390 return Find_Index (Container, Item) /= No_Index;
399 Capacity : Count_Type := 0) return Vector
407 elsif Capacity >= Source.Length then
412 with "Requested capacity is less than Source length";
415 return Target : Vector (C) do
416 Target.Elements (1 .. Source.Length) :=
417 Source.Elements (1 .. Source.Length);
419 Target.Last := Source.Last;
428 (Container : in out Vector;
429 Index : Extended_Index;
430 Count : Count_Type := 1)
432 Old_Last : constant Index_Type'Base := Container.Last;
433 Old_Len : constant Count_Type := Container.Length;
434 New_Last : Index_Type'Base;
435 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
436 Off : Count_Type'Base; -- Index expressed as offset from IT'First
439 -- Delete removes items from the vector, the number of which is the
440 -- minimum of the specified Count and the items (if any) that exist from
441 -- Index to Container.Last. There are no constraints on the specified
442 -- value of Count (it can be larger than what's available at this
443 -- position in the vector, for example), but there are constraints on
444 -- the allowed values of the Index.
446 -- As a precondition on the generic actual Index_Type, the base type
447 -- must include Index_Type'Pred (Index_Type'First); this is the value
448 -- that Container.Last assumes when the vector is empty. However, we do
449 -- not allow that as the value for Index when specifying which items
450 -- should be deleted, so we must manually check. (That the user is
451 -- allowed to specify the value at all here is a consequence of the
452 -- declaration of the Extended_Index subtype, which includes the values
453 -- in the base range that immediately precede and immediately follow the
454 -- values in the Index_Type.)
456 if Index < Index_Type'First then
457 raise Constraint_Error with "Index is out of range (too small)";
460 -- We do allow a value greater than Container.Last to be specified as
461 -- the Index, but only if it's immediately greater. This allows the
462 -- corner case of deleting no items from the back end of the vector to
463 -- be treated as a no-op. (It is assumed that specifying an index value
464 -- greater than Last + 1 indicates some deeper flaw in the caller's
465 -- algorithm, so that case is treated as a proper error.)
467 if Index > Old_Last then
468 if Index > Old_Last + 1 then
469 raise Constraint_Error with "Index is out of range (too large)";
475 -- Here and elsewhere we treat deleting 0 items from the container as a
476 -- no-op, even when the container is busy, so we simply return.
482 -- The tampering bits exist to prevent an item from being deleted (or
483 -- otherwise harmfully manipulated) while it is being visited. Query,
484 -- Update, and Iterate increment the busy count on entry, and decrement
485 -- the count on exit. Delete checks the count to determine whether it is
486 -- being called while the associated callback procedure is executing.
488 if Container.Busy > 0 then
489 raise Program_Error with
490 "attempt to tamper with cursors (vector is busy)";
493 -- We first calculate what's available for deletion starting at
494 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
495 -- Count_Type'Base as the type for intermediate values. (See function
496 -- Length for more information.)
498 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
499 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
502 Count2 := Count_Type'Base (Old_Last - Index + 1);
505 -- If more elements are requested (Count) for deletion than are
506 -- available (Count2) for deletion beginning at Index, then everything
507 -- from Index is deleted. There are no elements to slide down, and so
508 -- all we need to do is set the value of Container.Last.
510 if Count >= Count2 then
511 Container.Last := Index - 1;
515 -- There are some elements aren't being deleted (the requested count was
516 -- less than the available count), so we must slide them down to
517 -- Index. We first calculate the index values of the respective array
518 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
519 -- type for intermediate calculations.
521 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
522 Off := Count_Type'Base (Index - Index_Type'First);
523 New_Last := Old_Last - Index_Type'Base (Count);
526 Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
527 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
530 -- The array index values for each slice have already been determined,
531 -- so we just slide down to Index the elements that weren't deleted.
534 EA : Elements_Array renames Container.Elements;
535 Idx : constant Count_Type := EA'First + Off;
538 EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
539 Container.Last := New_Last;
544 (Container : in out Vector;
545 Position : in out Cursor;
546 Count : Count_Type := 1)
548 pragma Warnings (Off, Position);
551 if Position.Container = null then
552 raise Constraint_Error with "Position cursor has no element";
555 if Position.Container /= Container'Unrestricted_Access then
556 raise Program_Error with "Position cursor denotes wrong container";
559 if Position.Index > Container.Last then
560 raise Program_Error with "Position index is out of range";
563 Delete (Container, Position.Index, Count);
564 Position := No_Element;
571 procedure Delete_First
572 (Container : in out Vector;
573 Count : Count_Type := 1)
580 if Count >= Length (Container) then
585 Delete (Container, Index_Type'First, Count);
592 procedure Delete_Last
593 (Container : in out Vector;
594 Count : Count_Type := 1)
597 -- It is not permitted to delete items while the container is busy (for
598 -- example, we're in the middle of a passive iteration). However, we
599 -- always treat deleting 0 items as a no-op, even when we're busy, so we
600 -- simply return without checking.
606 -- The tampering bits exist to prevent an item from being deleted (or
607 -- otherwise harmfully manipulated) while it is being visited. Query,
608 -- Update, and Iterate increment the busy count on entry, and decrement
609 -- the count on exit. Delete_Last checks the count to determine whether
610 -- it is being called while the associated callback procedure is
613 if Container.Busy > 0 then
614 raise Program_Error with
615 "attempt to tamper with cursors (vector is busy)";
618 -- There is no restriction on how large Count can be when deleting
619 -- items. If it is equal or greater than the current length, then this
620 -- is equivalent to clearing the vector. (In particular, there's no need
621 -- for us to actually calculate the new value for Last.)
623 -- If the requested count is less than the current length, then we must
624 -- calculate the new value for Last. For the type we use the widest of
625 -- Index_Type'Base and Count_Type'Base for the intermediate values of
626 -- our calculation. (See the comments in Length for more information.)
628 if Count >= Container.Length then
629 Container.Last := No_Index;
631 elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
632 Container.Last := Container.Last - Index_Type'Base (Count);
636 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
646 Index : Index_Type) return Element_Type
649 if Index > Container.Last then
650 raise Constraint_Error with "Index is out of range";
652 return Container.Elements (To_Array_Index (Index));
656 function Element (Position : Cursor) return Element_Type is
658 if Position.Container = null then
659 raise Constraint_Error with "Position cursor has no element";
661 return Position.Container.Element (Position.Index);
669 procedure Finalize (Object : in out Iterator) is
671 if Object.Container /= null then
673 B : Natural renames Object.Container.all.Busy;
687 Position : Cursor := No_Element) return Cursor
690 if Position.Container /= null then
691 if Position.Container /= Container'Unrestricted_Access then
692 raise Program_Error with "Position cursor denotes wrong container";
695 if Position.Index > Container.Last then
696 raise Program_Error with "Position index is out of range";
700 for J in Position.Index .. Container.Last loop
701 if Container.Elements (To_Array_Index (J)) = Item then
702 return (Container'Unrestricted_Access, J);
716 Index : Index_Type := Index_Type'First) return Extended_Index
719 for Indx in Index .. Container.Last loop
720 if Container.Elements (To_Array_Index (Indx)) = Item then
732 function First (Container : Vector) return Cursor is
734 if Is_Empty (Container) then
737 return (Container'Unrestricted_Access, Index_Type'First);
741 function First (Object : Iterator) return Cursor is
743 if Is_Empty (Object.Container.all) then
746 return Cursor'(Object.Container, Index_Type'First);
754 function First_Element (Container : Vector) return Element_Type is
756 if Container.Last = No_Index then
757 raise Constraint_Error with "Container is empty";
759 return Container.Elements (To_Array_Index (Index_Type'First));
767 function First_Index (Container : Vector) return Index_Type is
768 pragma Unreferenced (Container);
770 return Index_Type'First;
773 ---------------------
774 -- Generic_Sorting --
775 ---------------------
777 package body Generic_Sorting is
783 function Is_Sorted (Container : Vector) return Boolean is
785 if Container.Last <= Index_Type'First then
790 EA : Elements_Array renames Container.Elements;
792 for J in 1 .. Container.Length - 1 loop
793 if EA (J + 1) < EA (J) then
806 procedure Merge (Target, Source : in out Vector) is
811 -- The semantics of Merge changed slightly per AI05-0021. It was
812 -- originally the case that if Target and Source denoted the same
813 -- container object, then the GNAT implementation of Merge did
814 -- nothing. However, it was argued that RM05 did not precisely
815 -- specify the semantics for this corner case. The decision of the
816 -- ARG was that if Target and Source denote the same non-empty
817 -- container object, then Program_Error is raised.
819 if Source.Is_Empty then
823 if Target'Address = Source'Address then
824 raise Program_Error with
825 "Target and Source denote same non-empty container";
828 if Target.Is_Empty then
829 Move (Target => Target, Source => Source);
833 if Source.Busy > 0 then
834 raise Program_Error with
835 "attempt to tamper with cursors (vector is busy)";
839 Target.Set_Length (I + Source.Length);
842 TA : Elements_Array renames Target.Elements;
843 SA : Elements_Array renames Source.Elements;
847 while not Source.Is_Empty loop
848 pragma Assert (Source.Length <= 1
849 or else not (SA (Source.Length) <
850 SA (Source.Length - 1)));
853 TA (1 .. J) := SA (1 .. Source.Length);
854 Source.Last := No_Index;
858 pragma Assert (I <= 1
859 or else not (TA (I) < TA (I - 1)));
861 if SA (Source.Length) < TA (I) then
866 TA (J) := SA (Source.Length);
867 Source.Last := Source.Last - 1;
879 procedure Sort (Container : in out Vector)
882 new Generic_Array_Sort
883 (Index_Type => Count_Type,
884 Element_Type => Element_Type,
885 Array_Type => Elements_Array,
889 if Container.Last <= Index_Type'First then
893 if Container.Lock > 0 then
894 raise Program_Error with
895 "attempt to tamper with elements (vector is locked)";
898 Sort (Container.Elements (1 .. Container.Length));
907 function Has_Element (Position : Cursor) return Boolean is
909 if Position.Container = null then
913 return Position.Index <= Position.Container.Last;
921 (Container : in out Vector;
922 Before : Extended_Index;
923 New_Item : Element_Type;
924 Count : Count_Type := 1)
926 EA : Elements_Array renames Container.Elements;
927 Old_Length : constant Count_Type := Container.Length;
929 Max_Length : Count_Type'Base; -- determined from range of Index_Type
930 New_Length : Count_Type'Base; -- sum of current length and Count
932 Index : Index_Type'Base; -- scratch for intermediate values
933 J : Count_Type'Base; -- scratch
936 -- As a precondition on the generic actual Index_Type, the base type
937 -- must include Index_Type'Pred (Index_Type'First); this is the value
938 -- that Container.Last assumes when the vector is empty. However, we do
939 -- not allow that as the value for Index when specifying where the new
940 -- items should be inserted, so we must manually check. (That the user
941 -- is allowed to specify the value at all here is a consequence of the
942 -- declaration of the Extended_Index subtype, which includes the values
943 -- in the base range that immediately precede and immediately follow the
944 -- values in the Index_Type.)
946 if Before < Index_Type'First then
947 raise Constraint_Error with
948 "Before index is out of range (too small)";
951 -- We do allow a value greater than Container.Last to be specified as
952 -- the Index, but only if it's immediately greater. This allows for the
953 -- case of appending items to the back end of the vector. (It is assumed
954 -- that specifying an index value greater than Last + 1 indicates some
955 -- deeper flaw in the caller's algorithm, so that case is treated as a
958 if Before > Container.Last
959 and then Before > Container.Last + 1
961 raise Constraint_Error with
962 "Before index is out of range (too large)";
965 -- We treat inserting 0 items into the container as a no-op, even when
966 -- the container is busy, so we simply return.
972 -- There are two constraints we need to satisfy. The first constraint is
973 -- that a container cannot have more than Count_Type'Last elements, so
974 -- we must check the sum of the current length and the insertion
975 -- count. Note that we cannot simply add these values, because of the
976 -- possibility of overflow.
978 if Old_Length > Count_Type'Last - Count then
979 raise Constraint_Error with "Count is out of range";
982 -- It is now safe compute the length of the new vector, without fear of
985 New_Length := Old_Length + Count;
987 -- The second constraint is that the new Last index value cannot exceed
988 -- Index_Type'Last. In each branch below, we calculate the maximum
989 -- length (computed from the range of values in Index_Type), and then
990 -- compare the new length to the maximum length. If the new length is
991 -- acceptable, then we compute the new last index from that.
993 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
994 -- We have to handle the case when there might be more values in the
995 -- range of Index_Type than in the range of Count_Type.
997 if Index_Type'First <= 0 then
998 -- We know that No_Index (the same as Index_Type'First - 1) is
999 -- less than 0, so it is safe to compute the following sum without
1000 -- fear of overflow.
1002 Index := No_Index + Index_Type'Base (Count_Type'Last);
1004 if Index <= Index_Type'Last then
1005 -- We have determined that range of Index_Type has at least as
1006 -- many values as in Count_Type, so Count_Type'Last is the
1007 -- maximum number of items that are allowed.
1009 Max_Length := Count_Type'Last;
1012 -- The range of Index_Type has fewer values than in Count_Type,
1013 -- so the maximum number of items is computed from the range of
1016 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1020 -- No_Index is equal or greater than 0, so we can safely compute
1021 -- the difference without fear of overflow (which we would have to
1022 -- worry about if No_Index were less than 0, but that case is
1025 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1028 elsif Index_Type'First <= 0 then
1029 -- We know that No_Index (the same as Index_Type'First - 1) is less
1030 -- than 0, so it is safe to compute the following sum without fear of
1033 J := Count_Type'Base (No_Index) + Count_Type'Last;
1035 if J <= Count_Type'Base (Index_Type'Last) then
1036 -- We have determined that range of Index_Type has at least as
1037 -- many values as in Count_Type, so Count_Type'Last is the maximum
1038 -- number of items that are allowed.
1040 Max_Length := Count_Type'Last;
1043 -- The range of Index_Type has fewer values than Count_Type does,
1044 -- so the maximum number of items is computed from the range of
1048 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1052 -- No_Index is equal or greater than 0, so we can safely compute the
1053 -- difference without fear of overflow (which we would have to worry
1054 -- about if No_Index were less than 0, but that case is handled
1058 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1061 -- We have just computed the maximum length (number of items). We must
1062 -- now compare the requested length to the maximum length, as we do not
1063 -- allow a vector expand beyond the maximum (because that would create
1064 -- an internal array with a last index value greater than
1065 -- Index_Type'Last, with no way to index those elements).
1067 if New_Length > Max_Length then
1068 raise Constraint_Error with "Count is out of range";
1071 -- The tampering bits exist to prevent an item from being harmfully
1072 -- manipulated while it is being visited. Query, Update, and Iterate
1073 -- increment the busy count on entry, and decrement the count on
1074 -- exit. Insert checks the count to determine whether it is being called
1075 -- while the associated callback procedure is executing.
1077 if Container.Busy > 0 then
1078 raise Program_Error with
1079 "attempt to tamper with cursors (vector is busy)";
1082 if New_Length > Container.Capacity then
1083 raise Capacity_Error with "New length is larger than capacity";
1086 J := To_Array_Index (Before);
1088 if Before > Container.Last then
1089 -- The new items are being appended to the vector, so no
1090 -- sliding of existing elements is required.
1092 EA (J .. New_Length) := (others => New_Item);
1095 -- The new items are being inserted before some existing
1096 -- elements, so we must slide the existing elements up to their
1099 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1100 EA (J .. J + Count - 1) := (others => New_Item);
1103 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1104 Container.Last := No_Index + Index_Type'Base (New_Length);
1108 Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1113 (Container : in out Vector;
1114 Before : Extended_Index;
1117 N : constant Count_Type := Length (New_Item);
1118 B : Count_Type; -- index Before converted to Count_Type
1121 -- Use Insert_Space to create the "hole" (the destination slice) into
1122 -- which we copy the source items.
1124 Insert_Space (Container, Before, Count => N);
1127 -- There's nothing else to do here (vetting of parameters was
1128 -- performed already in Insert_Space), so we simply return.
1133 B := To_Array_Index (Before);
1135 if Container'Address /= New_Item'Address then
1136 -- This is the simple case. New_Item denotes an object different
1137 -- from Container, so there's nothing special we need to do to copy
1138 -- the source items to their destination, because all of the source
1139 -- items are contiguous.
1141 Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N);
1145 -- We refer to array index value Before + N - 1 as J. This is the last
1146 -- index value of the destination slice.
1148 -- New_Item denotes the same object as Container, so an insertion has
1149 -- potentially split the source items. The destination is always the
1150 -- range [Before, J], but the source is [Index_Type'First, Before) and
1151 -- (J, Container.Last]. We perform the copy in two steps, using each of
1152 -- the two slices of the source items.
1155 subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1;
1157 Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
1160 -- We first copy the source items that precede the space we
1161 -- inserted. (If Before equals Index_Type'First, then this first
1162 -- source slice will be empty, which is harmless.)
1164 Container.Elements (B .. B + Src'Length - 1) := Src;
1168 subtype Src_Index_Subtype is Count_Type'Base range
1169 B + N .. Container.Length;
1171 Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
1174 -- We next copy the source items that follow the space we inserted.
1176 Container.Elements (B + N - Src'Length .. B + N - 1) := Src;
1181 (Container : in out Vector;
1185 Index : Index_Type'Base;
1188 if Before.Container /= null
1189 and then Before.Container /= Container'Unchecked_Access
1191 raise Program_Error with "Before cursor denotes wrong container";
1194 if Is_Empty (New_Item) then
1198 if Before.Container = null
1199 or else Before.Index > Container.Last
1201 if Container.Last = Index_Type'Last then
1202 raise Constraint_Error with
1203 "vector is already at its maximum length";
1206 Index := Container.Last + 1;
1209 Index := Before.Index;
1212 Insert (Container, Index, New_Item);
1216 (Container : in out Vector;
1219 Position : out Cursor)
1221 Index : Index_Type'Base;
1224 if Before.Container /= null
1225 and then Before.Container /= Container'Unchecked_Access
1227 raise Program_Error with "Before cursor denotes wrong container";
1230 if Is_Empty (New_Item) then
1231 if Before.Container = null
1232 or else Before.Index > Container.Last
1234 Position := No_Element;
1236 Position := (Container'Unchecked_Access, Before.Index);
1242 if Before.Container = null
1243 or else Before.Index > Container.Last
1245 if Container.Last = Index_Type'Last then
1246 raise Constraint_Error with
1247 "vector is already at its maximum length";
1250 Index := Container.Last + 1;
1253 Index := Before.Index;
1256 Insert (Container, Index, New_Item);
1258 Position := Cursor'(Container'Unchecked_Access, Index);
1262 (Container : in out Vector;
1264 New_Item : Element_Type;
1265 Count : Count_Type := 1)
1267 Index : Index_Type'Base;
1270 if Before.Container /= null
1271 and then Before.Container /= Container'Unchecked_Access
1273 raise Program_Error with "Before cursor denotes wrong container";
1280 if Before.Container = null
1281 or else Before.Index > Container.Last
1283 if Container.Last = Index_Type'Last then
1284 raise Constraint_Error with
1285 "vector is already at its maximum length";
1288 Index := Container.Last + 1;
1291 Index := Before.Index;
1294 Insert (Container, Index, New_Item, Count);
1298 (Container : in out Vector;
1300 New_Item : Element_Type;
1301 Position : out Cursor;
1302 Count : Count_Type := 1)
1304 Index : Index_Type'Base;
1307 if Before.Container /= null
1308 and then Before.Container /= Container'Unchecked_Access
1310 raise Program_Error with "Before cursor denotes wrong container";
1314 if Before.Container = null
1315 or else Before.Index > Container.Last
1317 Position := No_Element;
1319 Position := (Container'Unchecked_Access, Before.Index);
1325 if Before.Container = null
1326 or else Before.Index > Container.Last
1328 if Container.Last = Index_Type'Last then
1329 raise Constraint_Error with
1330 "vector is already at its maximum length";
1333 Index := Container.Last + 1;
1336 Index := Before.Index;
1339 Insert (Container, Index, New_Item, Count);
1341 Position := Cursor'(Container'Unchecked_Access, Index);
1345 (Container : in out Vector;
1346 Before : Extended_Index;
1347 Count : Count_Type := 1)
1349 New_Item : Element_Type; -- Default-initialized value
1350 pragma Warnings (Off, New_Item);
1353 Insert (Container, Before, New_Item, Count);
1357 (Container : in out Vector;
1359 Position : out Cursor;
1360 Count : Count_Type := 1)
1362 New_Item : Element_Type; -- Default-initialized value
1363 pragma Warnings (Off, New_Item);
1366 Insert (Container, Before, New_Item, Position, Count);
1373 procedure Insert_Space
1374 (Container : in out Vector;
1375 Before : Extended_Index;
1376 Count : Count_Type := 1)
1378 EA : Elements_Array renames Container.Elements;
1379 Old_Length : constant Count_Type := Container.Length;
1381 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1382 New_Length : Count_Type'Base; -- sum of current length and Count
1384 Index : Index_Type'Base; -- scratch for intermediate values
1385 J : Count_Type'Base; -- scratch
1388 -- As a precondition on the generic actual Index_Type, the base type
1389 -- must include Index_Type'Pred (Index_Type'First); this is the value
1390 -- that Container.Last assumes when the vector is empty. However, we do
1391 -- not allow that as the value for Index when specifying where the new
1392 -- items should be inserted, so we must manually check. (That the user
1393 -- is allowed to specify the value at all here is a consequence of the
1394 -- declaration of the Extended_Index subtype, which includes the values
1395 -- in the base range that immediately precede and immediately follow the
1396 -- values in the Index_Type.)
1398 if Before < Index_Type'First then
1399 raise Constraint_Error with
1400 "Before index is out of range (too small)";
1403 -- We do allow a value greater than Container.Last to be specified as
1404 -- the Index, but only if it's immediately greater. This allows for the
1405 -- case of appending items to the back end of the vector. (It is assumed
1406 -- that specifying an index value greater than Last + 1 indicates some
1407 -- deeper flaw in the caller's algorithm, so that case is treated as a
1410 if Before > Container.Last
1411 and then Before > Container.Last + 1
1413 raise Constraint_Error with
1414 "Before index is out of range (too large)";
1417 -- We treat inserting 0 items into the container as a no-op, even when
1418 -- the container is busy, so we simply return.
1424 -- There are two constraints we need to satisfy. The first constraint is
1425 -- that a container cannot have more than Count_Type'Last elements, so
1426 -- we must check the sum of the current length and the insertion count.
1427 -- Note that we cannot simply add these values, because of the
1428 -- possibility of overflow.
1430 if Old_Length > Count_Type'Last - Count then
1431 raise Constraint_Error with "Count is out of range";
1434 -- It is now safe compute the length of the new vector, without fear of
1437 New_Length := Old_Length + Count;
1439 -- The second constraint is that the new Last index value cannot exceed
1440 -- Index_Type'Last. In each branch below, we calculate the maximum
1441 -- length (computed from the range of values in Index_Type), and then
1442 -- compare the new length to the maximum length. If the new length is
1443 -- acceptable, then we compute the new last index from that.
1445 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1446 -- We have to handle the case when there might be more values in the
1447 -- range of Index_Type than in the range of Count_Type.
1449 if Index_Type'First <= 0 then
1450 -- We know that No_Index (the same as Index_Type'First - 1) is
1451 -- less than 0, so it is safe to compute the following sum without
1452 -- fear of overflow.
1454 Index := No_Index + Index_Type'Base (Count_Type'Last);
1456 if Index <= Index_Type'Last then
1457 -- We have determined that range of Index_Type has at least as
1458 -- many values as in Count_Type, so Count_Type'Last is the
1459 -- maximum number of items that are allowed.
1461 Max_Length := Count_Type'Last;
1464 -- The range of Index_Type has fewer values than in Count_Type,
1465 -- so the maximum number of items is computed from the range of
1468 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1472 -- No_Index is equal or greater than 0, so we can safely compute
1473 -- the difference without fear of overflow (which we would have to
1474 -- worry about if No_Index were less than 0, but that case is
1477 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1480 elsif Index_Type'First <= 0 then
1481 -- We know that No_Index (the same as Index_Type'First - 1) is less
1482 -- than 0, so it is safe to compute the following sum without fear of
1485 J := Count_Type'Base (No_Index) + Count_Type'Last;
1487 if J <= Count_Type'Base (Index_Type'Last) then
1488 -- We have determined that range of Index_Type has at least as
1489 -- many values as in Count_Type, so Count_Type'Last is the maximum
1490 -- number of items that are allowed.
1492 Max_Length := Count_Type'Last;
1495 -- The range of Index_Type has fewer values than Count_Type does,
1496 -- so the maximum number of items is computed from the range of
1500 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1504 -- No_Index is equal or greater than 0, so we can safely compute the
1505 -- difference without fear of overflow (which we would have to worry
1506 -- about if No_Index were less than 0, but that case is handled
1510 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1513 -- We have just computed the maximum length (number of items). We must
1514 -- now compare the requested length to the maximum length, as we do not
1515 -- allow a vector expand beyond the maximum (because that would create
1516 -- an internal array with a last index value greater than
1517 -- Index_Type'Last, with no way to index those elements).
1519 if New_Length > Max_Length then
1520 raise Constraint_Error with "Count is out of range";
1523 -- The tampering bits exist to prevent an item from being harmfully
1524 -- manipulated while it is being visited. Query, Update, and Iterate
1525 -- increment the busy count on entry, and decrement the count on
1526 -- exit. Insert checks the count to determine whether it is being called
1527 -- while the associated callback procedure is executing.
1529 if Container.Busy > 0 then
1530 raise Program_Error with
1531 "attempt to tamper with cursors (vector is busy)";
1534 -- An internal array has already been allocated, so we need to check
1535 -- whether there is enough unused storage for the new items.
1537 if New_Length > Container.Capacity then
1538 raise Capacity_Error with "New length is larger than capacity";
1541 -- In this case, we're inserting space into a vector that has already
1542 -- allocated an internal array, and the existing array has enough
1543 -- unused storage for the new items.
1545 if Before <= Container.Last then
1546 -- The space is being inserted before some existing elements,
1547 -- so we must slide the existing elements up to their new home.
1549 J := To_Array_Index (Before);
1550 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1553 -- New_Last is the last index value of the items in the container after
1554 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1555 -- compute its value from the New_Length.
1557 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1558 Container.Last := No_Index + Index_Type'Base (New_Length);
1562 Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1566 procedure Insert_Space
1567 (Container : in out Vector;
1569 Position : out Cursor;
1570 Count : Count_Type := 1)
1572 Index : Index_Type'Base;
1575 if Before.Container /= null
1576 and then Before.Container /= Container'Unchecked_Access
1578 raise Program_Error with "Before cursor denotes wrong container";
1582 if Before.Container = null
1583 or else Before.Index > Container.Last
1585 Position := No_Element;
1587 Position := (Container'Unchecked_Access, Before.Index);
1593 if Before.Container = null
1594 or else Before.Index > Container.Last
1596 if Container.Last = Index_Type'Last then
1597 raise Constraint_Error with
1598 "vector is already at its maximum length";
1601 Index := Container.Last + 1;
1604 Index := Before.Index;
1607 Insert_Space (Container, Index, Count => Count);
1609 Position := Cursor'(Container'Unchecked_Access, Index);
1616 function Is_Empty (Container : Vector) return Boolean is
1618 return Container.Last < Index_Type'First;
1626 (Container : Vector;
1627 Process : not null access procedure (Position : Cursor))
1629 B : Natural renames Container'Unrestricted_Access.all.Busy;
1635 for Indx in Index_Type'First .. Container.Last loop
1636 Process (Cursor'(Container'Unrestricted_Access, Indx));
1648 (Container : Vector)
1649 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
1651 B : Natural renames Container'Unrestricted_Access.all.Busy;
1653 return It : constant Iterator :=
1654 Iterator'(Limited_Controlled with
1655 Container => Container'Unrestricted_Access,
1656 Index => Index_Type'First)
1663 (Container : Vector;
1665 return Vector_Iterator_Interfaces.Reversible_Iterator'class
1667 B : Natural renames Container'Unrestricted_Access.all.Busy;
1669 return It : constant Iterator :=
1670 Iterator'(Limited_Controlled with
1671 Container => Container'Unrestricted_Access,
1672 Index => Start.Index)
1682 function Last (Container : Vector) return Cursor is
1684 if Is_Empty (Container) then
1687 return (Container'Unrestricted_Access, Container.Last);
1691 function Last (Object : Iterator) return Cursor is
1693 if Is_Empty (Object.Container.all) then
1696 return Cursor'(Object.Container, Object.Container.Last);
1704 function Last_Element (Container : Vector) return Element_Type is
1706 if Container.Last = No_Index then
1707 raise Constraint_Error with "Container is empty";
1709 return Container.Elements (Container.Length);
1717 function Last_Index (Container : Vector) return Extended_Index is
1719 return Container.Last;
1726 function Length (Container : Vector) return Count_Type is
1727 L : constant Index_Type'Base := Container.Last;
1728 F : constant Index_Type := Index_Type'First;
1731 -- The base range of the index type (Index_Type'Base) might not include
1732 -- all values for length (Count_Type). Contrariwise, the index type
1733 -- might include values outside the range of length. Hence we use
1734 -- whatever type is wider for intermediate values when calculating
1735 -- length. Note that no matter what the index type is, the maximum
1736 -- length to which a vector is allowed to grow is always the minimum
1737 -- of Count_Type'Last and (IT'Last - IT'First + 1).
1739 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
1740 -- to have a base range of -128 .. 127, but the corresponding vector
1741 -- would have lengths in the range 0 .. 255. In this case we would need
1742 -- to use Count_Type'Base for intermediate values.
1744 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
1745 -- vector would have a maximum length of 10, but the index values lie
1746 -- outside the range of Count_Type (which is only 32 bits). In this
1747 -- case we would need to use Index_Type'Base for intermediate values.
1749 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
1750 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
1752 return Count_Type (L - F + 1);
1761 (Target : in out Vector;
1762 Source : in out Vector)
1765 if Target'Address = Source'Address then
1769 if Target.Capacity < Source.Length then
1770 raise Capacity_Error -- ???
1771 with "Target capacity is less than Source length";
1774 if Target.Busy > 0 then
1775 raise Program_Error with
1776 "attempt to tamper with cursors (Target is busy)";
1779 if Source.Busy > 0 then
1780 raise Program_Error with
1781 "attempt to tamper with cursors (Source is busy)";
1784 -- Clear Target now, in case element assignment fails
1786 Target.Last := No_Index;
1788 Target.Elements (1 .. Source.Length) :=
1789 Source.Elements (1 .. Source.Length);
1791 Target.Last := Source.Last;
1792 Source.Last := No_Index;
1799 function Next (Position : Cursor) return Cursor is
1801 if Position.Container = null then
1805 if Position.Index < Position.Container.Last then
1806 return (Position.Container, Position.Index + 1);
1812 function Next (Object : Iterator; Position : Cursor) return Cursor is
1814 if Position.Index = Object.Container.Last then
1817 return (Object.Container, Position.Index + 1);
1821 procedure Next (Position : in out Cursor) is
1823 if Position.Container = null then
1827 if Position.Index < Position.Container.Last then
1828 Position.Index := Position.Index + 1;
1830 Position := No_Element;
1838 procedure Prepend (Container : in out Vector; New_Item : Vector) is
1840 Insert (Container, Index_Type'First, New_Item);
1844 (Container : in out Vector;
1845 New_Item : Element_Type;
1846 Count : Count_Type := 1)
1859 procedure Previous (Position : in out Cursor) is
1861 if Position.Container = null then
1865 if Position.Index > Index_Type'First then
1866 Position.Index := Position.Index - 1;
1868 Position := No_Element;
1872 function Previous (Position : Cursor) return Cursor is
1874 if Position.Container = null then
1878 if Position.Index > Index_Type'First then
1879 return (Position.Container, Position.Index - 1);
1885 function Previous (Object : Iterator; Position : Cursor) return Cursor is
1887 if Position.Index > Index_Type'First then
1888 return (Object.Container, Position.Index - 1);
1898 procedure Query_Element
1899 (Container : Vector;
1901 Process : not null access procedure (Element : Element_Type))
1903 V : Vector renames Container'Unrestricted_Access.all;
1904 B : Natural renames V.Busy;
1905 L : Natural renames V.Lock;
1908 if Index > Container.Last then
1909 raise Constraint_Error with "Index is out of range";
1916 Process (V.Elements (To_Array_Index (Index)));
1928 procedure Query_Element
1930 Process : not null access procedure (Element : Element_Type))
1933 if Position.Container = null then
1934 raise Constraint_Error with "Position cursor has no element";
1937 Query_Element (Position.Container.all, Position.Index, Process);
1945 (Stream : not null access Root_Stream_Type'Class;
1946 Container : out Vector)
1948 Length : Count_Type'Base;
1949 Last : Index_Type'Base := No_Index;
1954 Count_Type'Base'Read (Stream, Length);
1956 Reserve_Capacity (Container, Capacity => Length);
1958 for Idx in Count_Type range 1 .. Length loop
1960 Element_Type'Read (Stream, Container.Elements (Idx));
1961 Container.Last := Last;
1966 (Stream : not null access Root_Stream_Type'Class;
1967 Position : out Cursor)
1970 raise Program_Error with "attempt to stream vector cursor";
1974 (Stream : not null access Root_Stream_Type'Class;
1975 Item : out Reference_Type)
1978 raise Program_Error with "attempt to stream reference";
1982 (Stream : not null access Root_Stream_Type'Class;
1983 Item : out Constant_Reference_Type)
1986 raise Program_Error with "attempt to stream reference";
1993 function Constant_Reference
1994 (Container : Vector;
1995 Position : Cursor) -- SHOULD BE ALIASED
1996 return Constant_Reference_Type
1999 pragma Unreferenced (Container);
2001 if Position.Container = null then
2002 raise Constraint_Error with "Position cursor has no element";
2005 if Position.Index > Position.Container.Last then
2006 raise Constraint_Error with "Position cursor is out of range";
2011 Position.Container.Elements
2012 (To_Array_Index (Position.Index))'Access);
2013 end Constant_Reference;
2015 function Constant_Reference
2016 (Container : Vector;
2017 Position : Index_Type)
2018 return Constant_Reference_Type
2021 if (Position) > Container.Last then
2022 raise Constraint_Error with "Index is out of range";
2026 Container.Elements (To_Array_Index (Position))'Access);
2027 end Constant_Reference;
2030 (Container : Vector;
2032 return Reference_Type
2035 pragma Unreferenced (Container);
2037 if Position.Container = null then
2038 raise Constraint_Error with "Position cursor has no element";
2041 if Position.Index > Position.Container.Last then
2042 raise Constraint_Error with "Position cursor is out of range";
2047 Position.Container.Elements
2048 (To_Array_Index (Position.Index))'Access);
2052 (Container : Vector;
2053 Position : Index_Type)
2054 return Reference_Type
2057 if Position > Container.Last then
2058 raise Constraint_Error with "Index is out of range";
2061 Container.Elements (To_Array_Index (Position))'Unrestricted_Access);
2065 ---------------------
2066 -- Replace_Element --
2067 ---------------------
2069 procedure Replace_Element
2070 (Container : in out Vector;
2072 New_Item : Element_Type)
2075 if Index > Container.Last then
2076 raise Constraint_Error with "Index is out of range";
2079 if Container.Lock > 0 then
2080 raise Program_Error with
2081 "attempt to tamper with elements (vector is locked)";
2084 Container.Elements (To_Array_Index (Index)) := New_Item;
2085 end Replace_Element;
2087 procedure Replace_Element
2088 (Container : in out Vector;
2090 New_Item : Element_Type)
2093 if Position.Container = null then
2094 raise Constraint_Error with "Position cursor has no element";
2097 if Position.Container /= Container'Unrestricted_Access then
2098 raise Program_Error with "Position cursor denotes wrong container";
2101 if Position.Index > Container.Last then
2102 raise Constraint_Error with "Position cursor is out of range";
2105 if Container.Lock > 0 then
2106 raise Program_Error with
2107 "attempt to tamper with elements (vector is locked)";
2110 Container.Elements (To_Array_Index (Position.Index)) := New_Item;
2111 end Replace_Element;
2113 ----------------------
2114 -- Reserve_Capacity --
2115 ----------------------
2117 procedure Reserve_Capacity
2118 (Container : in out Vector;
2119 Capacity : Count_Type)
2122 if Capacity > Container.Capacity then
2123 raise Constraint_Error with "Capacity is out of range";
2125 end Reserve_Capacity;
2127 ----------------------
2128 -- Reverse_Elements --
2129 ----------------------
2131 procedure Reverse_Elements (Container : in out Vector) is
2132 E : Elements_Array renames Container.Elements;
2133 Idx, Jdx : Count_Type;
2136 if Container.Length <= 1 then
2140 if Container.Lock > 0 then
2141 raise Program_Error with
2142 "attempt to tamper with elements (vector is locked)";
2146 Jdx := Container.Length;
2147 while Idx < Jdx loop
2149 EI : constant Element_Type := E (Idx);
2159 end Reverse_Elements;
2165 function Reverse_Find
2166 (Container : Vector;
2167 Item : Element_Type;
2168 Position : Cursor := No_Element) return Cursor
2170 Last : Index_Type'Base;
2173 if Position.Container /= null
2174 and then Position.Container /= Container'Unrestricted_Access
2176 raise Program_Error with "Position cursor denotes wrong container";
2180 (if Position.Container = null or else Position.Index > Container.Last
2182 else Position.Index);
2184 for Indx in reverse Index_Type'First .. Last loop
2185 if Container.Elements (To_Array_Index (Indx)) = Item then
2186 return (Container'Unrestricted_Access, Indx);
2193 ------------------------
2194 -- Reverse_Find_Index --
2195 ------------------------
2197 function Reverse_Find_Index
2198 (Container : Vector;
2199 Item : Element_Type;
2200 Index : Index_Type := Index_Type'Last) return Extended_Index
2202 Last : constant Index_Type'Base :=
2203 Index_Type'Min (Container.Last, Index);
2206 for Indx in reverse Index_Type'First .. Last loop
2207 if Container.Elements (To_Array_Index (Indx)) = Item then
2213 end Reverse_Find_Index;
2215 ---------------------
2216 -- Reverse_Iterate --
2217 ---------------------
2219 procedure Reverse_Iterate
2220 (Container : Vector;
2221 Process : not null access procedure (Position : Cursor))
2223 V : Vector renames Container'Unrestricted_Access.all;
2224 B : Natural renames V.Busy;
2230 for Indx in reverse Index_Type'First .. Container.Last loop
2231 Process (Cursor'(Container'Unrestricted_Access, Indx));
2240 end Reverse_Iterate;
2246 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2247 Count : constant Count_Type'Base := Container.Length - Length;
2250 -- Set_Length allows the user to set the length explicitly, instead of
2251 -- implicitly as a side-effect of deletion or insertion. If the
2252 -- requested length is less then the current length, this is equivalent
2253 -- to deleting items from the back end of the vector. If the requested
2254 -- length is greater than the current length, then this is equivalent to
2255 -- inserting "space" (nonce items) at the end.
2258 Container.Delete_Last (Count);
2260 elsif Container.Last >= Index_Type'Last then
2261 raise Constraint_Error with "vector is already at its maximum length";
2264 Container.Insert_Space (Container.Last + 1, -Count);
2272 procedure Swap (Container : in out Vector; I, J : Index_Type) is
2273 E : Elements_Array renames Container.Elements;
2276 if I > Container.Last then
2277 raise Constraint_Error with "I index is out of range";
2280 if J > Container.Last then
2281 raise Constraint_Error with "J index is out of range";
2288 if Container.Lock > 0 then
2289 raise Program_Error with
2290 "attempt to tamper with elements (vector is locked)";
2294 EI_Copy : constant Element_Type := E (To_Array_Index (I));
2296 E (To_Array_Index (I)) := E (To_Array_Index (J));
2297 E (To_Array_Index (J)) := EI_Copy;
2301 procedure Swap (Container : in out Vector; I, J : Cursor) is
2303 if I.Container = null then
2304 raise Constraint_Error with "I cursor has no element";
2307 if J.Container = null then
2308 raise Constraint_Error with "J cursor has no element";
2311 if I.Container /= Container'Unrestricted_Access then
2312 raise Program_Error with "I cursor denotes wrong container";
2315 if J.Container /= Container'Unrestricted_Access then
2316 raise Program_Error with "J cursor denotes wrong container";
2319 Swap (Container, I.Index, J.Index);
2322 --------------------
2323 -- To_Array_Index --
2324 --------------------
2326 function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
2327 Offset : Count_Type'Base;
2331 -- Index >= Index_Type'First
2332 -- hence we also know that
2333 -- Index - Index_Type'First >= 0
2335 -- The issue is that even though 0 is guaranteed to be a value
2336 -- in the type Index_Type'Base, there's no guarantee that the
2337 -- difference is a value in that type. To prevent overflow we
2338 -- use the wider of Count_Type'Base and Index_Type'Base to
2339 -- perform intermediate calculations.
2341 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2342 Offset := Count_Type'Base (Index - Index_Type'First);
2345 Offset := Count_Type'Base (Index) -
2346 Count_Type'Base (Index_Type'First);
2349 -- The array index subtype for all container element arrays
2350 -- always starts with 1.
2360 (Container : Vector;
2361 Index : Extended_Index) return Cursor
2364 if Index not in Index_Type'First .. Container.Last then
2368 return Cursor'(Container'Unrestricted_Access, Index);
2375 function To_Index (Position : Cursor) return Extended_Index is
2377 if Position.Container = null then
2381 if Position.Index <= Position.Container.Last then
2382 return Position.Index;
2392 function To_Vector (Length : Count_Type) return Vector is
2393 Index : Count_Type'Base;
2394 Last : Index_Type'Base;
2398 return Empty_Vector;
2401 -- We create a vector object with a capacity that matches the specified
2402 -- Length, but we do not allow the vector capacity (the length of the
2403 -- internal array) to exceed the number of values in Index_Type'Range
2404 -- (otherwise, there would be no way to refer to those components via an
2405 -- index). We must therefore check whether the specified Length would
2406 -- create a Last index value greater than Index_Type'Last.
2408 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2409 -- We perform a two-part test. First we determine whether the
2410 -- computed Last value lies in the base range of the type, and then
2411 -- determine whether it lies in the range of the index (sub)type.
2413 -- Last must satisfy this relation:
2414 -- First + Length - 1 <= Last
2415 -- We regroup terms:
2416 -- First - 1 <= Last - Length
2417 -- Which can rewrite as:
2418 -- No_Index <= Last - Length
2420 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
2421 raise Constraint_Error with "Length is out of range";
2424 -- We now know that the computed value of Last is within the base
2425 -- range of the type, so it is safe to compute its value:
2427 Last := No_Index + Index_Type'Base (Length);
2429 -- Finally we test whether the value is within the range of the
2430 -- generic actual index subtype:
2432 if Last > Index_Type'Last then
2433 raise Constraint_Error with "Length is out of range";
2436 elsif Index_Type'First <= 0 then
2438 -- Here we can compute Last directly, in the normal way. We know that
2439 -- No_Index is less than 0, so there is no danger of overflow when
2440 -- adding the (positive) value of Length.
2442 Index := Count_Type'Base (No_Index) + Length; -- Last
2444 if Index > Count_Type'Base (Index_Type'Last) then
2445 raise Constraint_Error with "Length is out of range";
2448 -- We know that the computed value (having type Count_Type) of Last
2449 -- is within the range of the generic actual index subtype, so it is
2450 -- safe to convert to Index_Type:
2452 Last := Index_Type'Base (Index);
2455 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2456 -- must test the length indirectly (by working backwards from the
2457 -- largest possible value of Last), in order to prevent overflow.
2459 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
2461 if Index < Count_Type'Base (No_Index) then
2462 raise Constraint_Error with "Length is out of range";
2465 -- We have determined that the value of Length would not create a
2466 -- Last index value outside of the range of Index_Type, so we can now
2467 -- safely compute its value.
2469 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
2472 return V : Vector (Capacity => Length) do
2478 (New_Item : Element_Type;
2479 Length : Count_Type) return Vector
2481 Index : Count_Type'Base;
2482 Last : Index_Type'Base;
2486 return Empty_Vector;
2489 -- We create a vector object with a capacity that matches the specified
2490 -- Length, but we do not allow the vector capacity (the length of the
2491 -- internal array) to exceed the number of values in Index_Type'Range
2492 -- (otherwise, there would be no way to refer to those components via an
2493 -- index). We must therefore check whether the specified Length would
2494 -- create a Last index value greater than Index_Type'Last.
2496 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2498 -- We perform a two-part test. First we determine whether the
2499 -- computed Last value lies in the base range of the type, and then
2500 -- determine whether it lies in the range of the index (sub)type.
2502 -- Last must satisfy this relation:
2503 -- First + Length - 1 <= Last
2504 -- We regroup terms:
2505 -- First - 1 <= Last - Length
2506 -- Which can rewrite as:
2507 -- No_Index <= Last - Length
2509 if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then
2510 raise Constraint_Error with "Length is out of range";
2513 -- We now know that the computed value of Last is within the base
2514 -- range of the type, so it is safe to compute its value:
2516 Last := No_Index + Index_Type'Base (Length);
2518 -- Finally we test whether the value is within the range of the
2519 -- generic actual index subtype:
2521 if Last > Index_Type'Last then
2522 raise Constraint_Error with "Length is out of range";
2525 elsif Index_Type'First <= 0 then
2527 -- Here we can compute Last directly, in the normal way. We know that
2528 -- No_Index is less than 0, so there is no danger of overflow when
2529 -- adding the (positive) value of Length.
2531 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
2533 if Index > Count_Type'Base (Index_Type'Last) then
2534 raise Constraint_Error with "Length is out of range";
2537 -- We know that the computed value (having type Count_Type) of Last
2538 -- is within the range of the generic actual index subtype, so it is
2539 -- safe to convert to Index_Type:
2541 Last := Index_Type'Base (Index);
2544 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2545 -- must test the length indirectly (by working backwards from the
2546 -- largest possible value of Last), in order to prevent overflow.
2548 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
2550 if Index < Count_Type'Base (No_Index) then
2551 raise Constraint_Error with "Length is out of range";
2554 -- We have determined that the value of Length would not create a
2555 -- Last index value outside of the range of Index_Type, so we can now
2556 -- safely compute its value.
2558 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
2561 return V : Vector (Capacity => Length) do
2562 V.Elements := (others => New_Item);
2567 --------------------
2568 -- Update_Element --
2569 --------------------
2571 procedure Update_Element
2572 (Container : in out Vector;
2574 Process : not null access procedure (Element : in out Element_Type))
2576 B : Natural renames Container.Busy;
2577 L : Natural renames Container.Lock;
2580 if Index > Container.Last then
2581 raise Constraint_Error with "Index is out of range";
2588 Process (Container.Elements (To_Array_Index (Index)));
2600 procedure Update_Element
2601 (Container : in out Vector;
2603 Process : not null access procedure (Element : in out Element_Type))
2606 if Position.Container = null then
2607 raise Constraint_Error with "Position cursor has no element";
2610 if Position.Container /= Container'Unrestricted_Access then
2611 raise Program_Error with "Position cursor denotes wrong container";
2614 Update_Element (Container, Position.Index, Process);
2622 (Stream : not null access Root_Stream_Type'Class;
2628 N := Container.Length;
2629 Count_Type'Base'Write (Stream, N);
2631 for J in 1 .. N loop
2632 Element_Type'Write (Stream, Container.Elements (J));
2637 (Stream : not null access Root_Stream_Type'Class;
2641 raise Program_Error with "attempt to stream vector cursor";
2645 (Stream : not null access Root_Stream_Type'Class;
2646 Item : Reference_Type)
2649 raise Program_Error with "attempt to stream reference";
2653 (Stream : not null access Root_Stream_Type'Class;
2654 Item : Constant_Reference_Type)
2657 raise Program_Error with "attempt to stream reference";
2660 end Ada.Containers.Bounded_Vectors;