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-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
30 with Ada
.Containers
.Generic_Array_Sort
;
32 with System
; use type System
.Address
;
34 package body Ada
.Containers
.Bounded_Vectors
is
36 -----------------------
37 -- Local Subprograms --
38 -----------------------
40 function To_Array_Index
(Index
: Index_Type
'Base) return Count_Type
'Base;
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 index 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.)
68 return Vector
'(Capacity => RN,
69 Elements => Right.Elements (1 .. RN),
75 return Vector'(Capacity
=> LN
,
76 Elements
=> Left
.Elements
(1 .. LN
),
81 -- Neither of the vector parameters is empty, so must compute the length
82 -- of the result vector and its last index. (This is the harder case,
83 -- because our computations must avoid overflow.)
85 -- There are two constraints we need to satisfy. The first constraint is
86 -- that a container cannot have more than Count_Type'Last elements, so
87 -- we must check the sum of the combined lengths. Note that we cannot
88 -- simply add the lengths, because of the possibility of overflow.
90 if LN
> Count_Type
'Last - RN
then
91 raise Constraint_Error
with "new length is out of range";
94 -- It is now safe to compute the length of the new vector, without fear
99 -- The second constraint is that the new Last index value cannot
100 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
101 -- Count_Type'Base as the type for intermediate values.
103 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
105 -- We perform a two-part test. First we determine whether the
106 -- computed Last value lies in the base range of the type, and then
107 -- determine whether it lies in the range of the index (sub)type.
109 -- Last must satisfy this relation:
110 -- First + Length - 1 <= Last
112 -- First - 1 <= Last - Length
113 -- Which can rewrite as:
114 -- No_Index <= Last - Length
116 if Index_Type'Base'Last
- Index_Type
'Base (N
) < No_Index
then
117 raise Constraint_Error
with "new length is out of range";
120 -- We now know that the computed value of Last is within the base
121 -- range of the type, so it is safe to compute its value:
123 Last
:= No_Index
+ Index_Type
'Base (N
);
125 -- Finally we test whether the value is within the range of the
126 -- generic actual index subtype:
128 if Last
> Index_Type
'Last then
129 raise Constraint_Error
with "new length is out of range";
132 elsif Index_Type
'First <= 0 then
134 -- Here we can compute Last directly, in the normal way. We know that
135 -- No_Index is less than 0, so there is no danger of overflow when
136 -- adding the (positive) value of length.
138 J
:= Count_Type
'Base (No_Index
) + N
; -- Last
140 if J
> Count_Type
'Base (Index_Type
'Last) then
141 raise Constraint_Error
with "new length is out of range";
144 -- We know that the computed value (having type Count_Type) of Last
145 -- is within the range of the generic actual index subtype, so it is
146 -- safe to convert to Index_Type:
148 Last
:= Index_Type
'Base (J
);
151 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
152 -- must test the length indirectly (by working backwards from the
153 -- largest possible value of Last), in order to prevent overflow.
155 J
:= Count_Type
'Base (Index_Type
'Last) - N
; -- No_Index
157 if J
< Count_Type
'Base (No_Index
) then
158 raise Constraint_Error
with "new length is out of range";
161 -- We have determined that the result length would not create a Last
162 -- index value outside of the range of Index_Type, so we can now
163 -- safely compute its value.
165 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + N
);
169 LE
: Elements_Array
renames Left
.Elements
(1 .. LN
);
170 RE
: Elements_Array
renames Right
.Elements
(1 .. RN
);
173 return Vector
'(Capacity => N,
180 function "&" (Left : Vector; Right : Element_Type) return Vector is
181 LN : constant Count_Type := Length (Left);
184 -- We decide that the capacity of the result is the sum of the lengths
185 -- of the parameters. We could decide to make it larger, but we have no
186 -- basis for knowing how much larger, so we just allocate the minimum
187 -- amount of storage.
189 -- We must compute the length of the result vector and its last index,
190 -- but in such a way that overflow is avoided. We must satisfy two
191 -- constraints: the new length cannot exceed Count_Type'Last, and the
192 -- new Last index cannot exceed Index_Type'Last.
194 if LN = Count_Type'Last then
195 raise Constraint_Error with "new length is out of range";
198 if Left.Last >= Index_Type'Last then
199 raise Constraint_Error with "new length is out of range";
202 return Vector'(Capacity
=> LN
+ 1,
203 Elements
=> Left
.Elements
(1 .. LN
) & Right
,
204 Last
=> Left
.Last
+ 1,
208 function "&" (Left
: Element_Type
; Right
: Vector
) return Vector
is
209 RN
: constant Count_Type
:= Length
(Right
);
212 -- We decide that the capacity of the result is the sum of the lengths
213 -- of the parameters. We could decide to make it larger, but we have no
214 -- basis for knowing how much larger, so we just allocate the minimum
215 -- amount of storage.
217 -- We compute the length of the result vector and its last index, but in
218 -- such a way that overflow is avoided. We must satisfy two constraints:
219 -- the new length cannot exceed Count_Type'Last, and the new Last index
220 -- cannot exceed Index_Type'Last.
222 if RN
= Count_Type
'Last then
223 raise Constraint_Error
with "new length is out of range";
226 if Right
.Last
>= Index_Type
'Last then
227 raise Constraint_Error
with "new length is out of range";
230 return Vector
'(Capacity => 1 + RN,
231 Elements => Left & Right.Elements (1 .. RN),
232 Last => Right.Last + 1,
236 function "&" (Left, Right : Element_Type) return Vector is
238 -- We decide that the capacity of the result is the sum of the lengths
239 -- of the parameters. We could decide to make it larger, but we have no
240 -- basis for knowing how much larger, so we just allocate the minimum
241 -- amount of storage.
243 -- We must compute the length of the result vector and its last index,
244 -- but in such a way that overflow is avoided. We must satisfy two
245 -- constraints: the new length cannot exceed Count_Type'Last (here, we
246 -- know that that condition is satisfied), and the new Last index cannot
247 -- exceed Index_Type'Last.
249 if Index_Type'First >= Index_Type'Last then
250 raise Constraint_Error with "new length is out of range";
253 return Vector'(Capacity
=> 2,
254 Elements
=> (Left
, Right
),
255 Last
=> Index_Type
'First + 1,
263 overriding
function "=" (Left
, Right
: Vector
) return Boolean is
264 BL
: Natural renames Left
'Unrestricted_Access.Busy
;
265 LL
: Natural renames Left
'Unrestricted_Access.Lock
;
267 BR
: Natural renames Right
'Unrestricted_Access.Busy
;
268 LR
: Natural renames Right
'Unrestricted_Access.Lock
;
273 if Left
'Address = Right
'Address then
277 if Left
.Last
/= Right
.Last
then
281 -- Per AI05-0022, the container implementation is required to detect
282 -- element tampering by a generic actual subprogram.
291 for J
in Count_Type
range 1 .. Left
.Length
loop
292 if Left
.Elements
(J
) /= Right
.Elements
(J
) then
321 procedure Assign
(Target
: in out Vector
; Source
: Vector
) is
323 if Target
'Address = Source
'Address then
327 if Target
.Capacity
< Source
.Length
then
328 raise Capacity_Error
-- ???
329 with "Target capacity is less than Source length";
334 Target
.Elements
(1 .. Source
.Length
) :=
335 Source
.Elements
(1 .. Source
.Length
);
337 Target
.Last
:= Source
.Last
;
344 procedure Append
(Container
: in out Vector
; New_Item
: Vector
) is
346 if New_Item
.Is_Empty
then
350 if Container
.Last
>= Index_Type
'Last then
351 raise Constraint_Error
with "vector is already at its maximum length";
354 Container
.Insert
(Container
.Last
+ 1, New_Item
);
358 (Container
: in out Vector
;
359 New_Item
: Element_Type
;
360 Count
: Count_Type
:= 1)
367 if Container
.Last
>= Index_Type
'Last then
368 raise Constraint_Error
with "vector is already at its maximum length";
371 Container
.Insert
(Container
.Last
+ 1, New_Item
, Count
);
378 function Capacity
(Container
: Vector
) return Count_Type
is
380 return Container
.Elements
'Length;
387 procedure Clear
(Container
: in out Vector
) is
389 if Container
.Busy
> 0 then
390 raise Program_Error
with
391 "attempt to tamper with cursors (vector is busy)";
394 Container
.Last
:= No_Index
;
397 ------------------------
398 -- Constant_Reference --
399 ------------------------
401 function Constant_Reference
402 (Container
: aliased Vector
;
403 Position
: Cursor
) return Constant_Reference_Type
406 if Position
.Container
= null then
407 raise Constraint_Error
with "Position cursor has no element";
410 if Position
.Container
/= Container
'Unrestricted_Access then
411 raise Program_Error
with "Position cursor denotes wrong container";
414 if Position
.Index
> Position
.Container
.Last
then
415 raise Constraint_Error
with "Position cursor is out of range";
419 A
: Elements_Array
renames Container
.Elements
;
420 I
: constant Count_Type
:= To_Array_Index
(Position
.Index
);
422 return (Element
=> A
(I
)'Access);
424 end Constant_Reference
;
426 function Constant_Reference
427 (Container
: aliased Vector
;
428 Index
: Index_Type
) return Constant_Reference_Type
431 if Index
> Container
.Last
then
432 raise Constraint_Error
with "Index is out of range";
436 A
: Elements_Array
renames Container
.Elements
;
437 I
: constant Count_Type
:= To_Array_Index
(Index
);
439 return (Element
=> A
(I
)'Access);
441 end Constant_Reference
;
449 Item
: Element_Type
) return Boolean
452 return Find_Index
(Container
, Item
) /= No_Index
;
461 Capacity
: Count_Type
:= 0) return Vector
469 elsif Capacity
>= Source
.Length
then
474 with "Requested capacity is less than Source length";
477 return Target
: Vector
(C
) do
478 Target
.Elements
(1 .. Source
.Length
) :=
479 Source
.Elements
(1 .. Source
.Length
);
481 Target
.Last
:= Source
.Last
;
490 (Container
: in out Vector
;
491 Index
: Extended_Index
;
492 Count
: Count_Type
:= 1)
494 Old_Last
: constant Index_Type
'Base := Container
.Last
;
495 Old_Len
: constant Count_Type
:= Container
.Length
;
496 New_Last
: Index_Type
'Base;
497 Count2
: Count_Type
'Base; -- count of items from Index to Old_Last
498 Off
: Count_Type
'Base; -- Index expressed as offset from IT'First
501 -- Delete removes items from the vector, the number of which is the
502 -- minimum of the specified Count and the items (if any) that exist from
503 -- Index to Container.Last. There are no constraints on the specified
504 -- value of Count (it can be larger than what's available at this
505 -- position in the vector, for example), but there are constraints on
506 -- the allowed values of the Index.
508 -- As a precondition on the generic actual Index_Type, the base type
509 -- must include Index_Type'Pred (Index_Type'First); this is the value
510 -- that Container.Last assumes when the vector is empty. However, we do
511 -- not allow that as the value for Index when specifying which items
512 -- should be deleted, so we must manually check. (That the user is
513 -- allowed to specify the value at all here is a consequence of the
514 -- declaration of the Extended_Index subtype, which includes the values
515 -- in the base range that immediately precede and immediately follow the
516 -- values in the Index_Type.)
518 if Index
< Index_Type
'First then
519 raise Constraint_Error
with "Index is out of range (too small)";
522 -- We do allow a value greater than Container.Last to be specified as
523 -- the Index, but only if it's immediately greater. This allows the
524 -- corner case of deleting no items from the back end of the vector to
525 -- be treated as a no-op. (It is assumed that specifying an index value
526 -- greater than Last + 1 indicates some deeper flaw in the caller's
527 -- algorithm, so that case is treated as a proper error.)
529 if Index
> Old_Last
then
530 if Index
> Old_Last
+ 1 then
531 raise Constraint_Error
with "Index is out of range (too large)";
537 -- Here and elsewhere we treat deleting 0 items from the container as a
538 -- no-op, even when the container is busy, so we simply return.
544 -- The tampering bits exist to prevent an item from being deleted (or
545 -- otherwise harmfully manipulated) while it is being visited. Query,
546 -- Update, and Iterate increment the busy count on entry, and decrement
547 -- the count on exit. Delete checks the count to determine whether it is
548 -- being called while the associated callback procedure is executing.
550 if Container
.Busy
> 0 then
551 raise Program_Error
with
552 "attempt to tamper with cursors (vector is busy)";
555 -- We first calculate what's available for deletion starting at
556 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
557 -- Count_Type'Base as the type for intermediate values. (See function
558 -- Length for more information.)
560 if Count_Type
'Base'Last >= Index_Type'Pos (Index_Type'Base'Last
) then
561 Count2
:= Count_Type
'Base (Old_Last
) - Count_Type
'Base (Index
) + 1;
563 Count2
:= Count_Type
'Base (Old_Last
- Index
+ 1);
566 -- If more elements are requested (Count) for deletion than are
567 -- available (Count2) for deletion beginning at Index, then everything
568 -- from Index is deleted. There are no elements to slide down, and so
569 -- all we need to do is set the value of Container.Last.
571 if Count
>= Count2
then
572 Container
.Last
:= Index
- 1;
576 -- There are some elements aren't being deleted (the requested count was
577 -- less than the available count), so we must slide them down to
578 -- Index. We first calculate the index values of the respective array
579 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
580 -- type for intermediate calculations.
582 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
583 Off := Count_Type'Base (Index - Index_Type'First);
584 New_Last := Old_Last - Index_Type'Base (Count);
586 Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
587 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
590 -- The array index values for each slice have already been determined,
591 -- so we just slide down to Index the elements that weren't deleted.
594 EA : Elements_Array renames Container.Elements;
595 Idx : constant Count_Type := EA'First + Off;
597 EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
598 Container.Last := New_Last;
603 (Container : in out Vector;
604 Position : in out Cursor;
605 Count : Count_Type := 1)
607 pragma Warnings (Off, Position);
610 if Position.Container = null then
611 raise Constraint_Error with "Position cursor has no element";
614 if Position.Container /= Container'Unrestricted_Access then
615 raise Program_Error with "Position cursor denotes wrong container";
618 if Position.Index > Container.Last then
619 raise Program_Error with "Position index is out of range";
622 Delete (Container, Position.Index, Count);
623 Position := No_Element;
630 procedure Delete_First
631 (Container : in out Vector;
632 Count : Count_Type := 1)
638 elsif Count >= Length (Container) then
643 Delete (Container, Index_Type'First, Count);
651 procedure Delete_Last
652 (Container : in out Vector;
653 Count : Count_Type := 1)
656 -- It is not permitted to delete items while the container is busy (for
657 -- example, we're in the middle of a passive iteration). However, we
658 -- always treat deleting 0 items as a no-op, even when we're busy, so we
659 -- simply return without checking.
665 -- The tampering bits exist to prevent an item from being deleted (or
666 -- otherwise harmfully manipulated) while it is being visited. Query,
667 -- Update, and Iterate increment the busy count on entry, and decrement
668 -- the count on exit. Delete_Last checks the count to determine whether
669 -- it is being called while the associated callback procedure is
672 if Container.Busy > 0 then
673 raise Program_Error with
674 "attempt to tamper with cursors (vector is busy)";
677 -- There is no restriction on how large Count can be when deleting
678 -- items. If it is equal or greater than the current length, then this
679 -- is equivalent to clearing the vector. (In particular, there's no need
680 -- for us to actually calculate the new value for Last.)
682 -- If the requested count is less than the current length, then we must
683 -- calculate the new value for Last. For the type we use the widest of
684 -- Index_Type'Base and Count_Type'Base for the intermediate values of
685 -- our calculation. (See the comments in Length for more information.)
687 if Count >= Container.Length then
688 Container.Last := No_Index;
690 elsif Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
691 Container
.Last
:= Container
.Last
- Index_Type
'Base (Count
);
695 Index_Type
'Base (Count_Type
'Base (Container
.Last
) - Count
);
705 Index
: Index_Type
) return Element_Type
708 if Index
> Container
.Last
then
709 raise Constraint_Error
with "Index is out of range";
711 return Container
.Elements
(To_Array_Index
(Index
));
715 function Element
(Position
: Cursor
) return Element_Type
is
717 if Position
.Container
= null then
718 raise Constraint_Error
with "Position cursor has no element";
720 return Position
.Container
.Element
(Position
.Index
);
728 procedure Finalize
(Object
: in out Iterator
) is
729 B
: Natural renames Object
.Container
.Busy
;
741 Position
: Cursor
:= No_Element
) return Cursor
744 if Position
.Container
/= null then
745 if Position
.Container
/= Container
'Unrestricted_Access then
746 raise Program_Error
with "Position cursor denotes wrong container";
749 if Position
.Index
> Container
.Last
then
750 raise Program_Error
with "Position index is out of range";
754 -- Per AI05-0022, the container implementation is required to detect
755 -- element tampering by a generic actual subprogram.
758 B
: Natural renames Container
'Unrestricted_Access.Busy
;
759 L
: Natural renames Container
'Unrestricted_Access.Lock
;
761 Result
: Index_Type
'Base;
768 for J
in Position
.Index
.. Container
.Last
loop
769 if Container
.Elements
(To_Array_Index
(J
)) = Item
then
778 if Result
= No_Index
then
781 return Cursor
'(Container'Unrestricted_Access, Result);
799 Index : Index_Type := Index_Type'First) return Extended_Index
801 B : Natural renames Container'Unrestricted_Access.Busy;
802 L : Natural renames Container'Unrestricted_Access.Lock;
804 Result : Index_Type'Base;
807 -- Per AI05-0022, the container implementation is required to detect
808 -- element tampering by a generic actual subprogram.
814 for Indx in Index .. Container.Last loop
815 if Container.Elements (To_Array_Index (Indx)) = Item then
837 function First (Container : Vector) return Cursor is
839 if Is_Empty (Container) then
842 return (Container'Unrestricted_Access, Index_Type'First);
846 function First (Object : Iterator) return Cursor is
848 -- The value of the iterator object's Index component influences the
849 -- behavior of the First (and Last) selector function.
851 -- When the Index component is No_Index, this means the iterator
852 -- object was constructed without a start expression, in which case the
853 -- (forward) iteration starts from the (logical) beginning of the entire
854 -- sequence of items (corresponding to Container.First, for a forward
857 -- Otherwise, this is iteration over a partial sequence of items.
858 -- When the Index component isn't No_Index, the iterator object was
859 -- constructed with a start expression, that specifies the position
860 -- from which the (forward) partial iteration begins.
862 if Object.Index = No_Index then
863 return First (Object.Container.all);
865 return Cursor'(Object
.Container
, Object
.Index
);
873 function First_Element
(Container
: Vector
) return Element_Type
is
875 if Container
.Last
= No_Index
then
876 raise Constraint_Error
with "Container is empty";
878 return Container
.Elements
(To_Array_Index
(Index_Type
'First));
886 function First_Index
(Container
: Vector
) return Index_Type
is
887 pragma Unreferenced
(Container
);
889 return Index_Type
'First;
892 ---------------------
893 -- Generic_Sorting --
894 ---------------------
896 package body Generic_Sorting
is
902 function Is_Sorted
(Container
: Vector
) return Boolean is
904 if Container
.Last
<= Index_Type
'First then
908 -- Per AI05-0022, the container implementation is required to detect
909 -- element tampering by a generic actual subprogram.
912 EA
: Elements_Array
renames Container
.Elements
;
914 B
: Natural renames Container
'Unrestricted_Access.Busy
;
915 L
: Natural renames Container
'Unrestricted_Access.Lock
;
924 for J
in 1 .. Container
.Length
- 1 loop
925 if EA
(J
+ 1) < EA
(J
) then
948 procedure Merge
(Target
, Source
: in out Vector
) is
952 -- The semantics of Merge changed slightly per AI05-0021. It was
953 -- originally the case that if Target and Source denoted the same
954 -- container object, then the GNAT implementation of Merge did
955 -- nothing. However, it was argued that RM05 did not precisely
956 -- specify the semantics for this corner case. The decision of the
957 -- ARG was that if Target and Source denote the same non-empty
958 -- container object, then Program_Error is raised.
960 if Source
.Is_Empty
then
964 if Target
'Address = Source
'Address then
965 raise Program_Error
with
966 "Target and Source denote same non-empty container";
969 if Target
.Is_Empty
then
970 Move
(Target
=> Target
, Source
=> Source
);
974 if Source
.Busy
> 0 then
975 raise Program_Error
with
976 "attempt to tamper with cursors (vector is busy)";
980 Target
.Set_Length
(I
+ Source
.Length
);
982 -- Per AI05-0022, the container implementation is required to detect
983 -- element tampering by a generic actual subprogram.
986 TA
: Elements_Array
renames Target
.Elements
;
987 SA
: Elements_Array
renames Source
.Elements
;
989 TB
: Natural renames Target
.Busy
;
990 TL
: Natural renames Target
.Lock
;
992 SB
: Natural renames Source
.Busy
;
993 SL
: Natural renames Source
.Lock
;
1003 while not Source
.Is_Empty
loop
1004 pragma Assert
(Source
.Length
<= 1
1005 or else not (SA
(Source
.Length
) < SA
(Source
.Length
- 1)));
1008 TA
(1 .. J
) := SA
(1 .. Source
.Length
);
1009 Source
.Last
:= No_Index
;
1013 pragma Assert
(I
<= 1
1014 or else not (TA
(I
) < TA
(I
- 1)));
1016 if SA
(Source
.Length
) < TA
(I
) then
1021 TA
(J
) := SA
(Source
.Length
);
1022 Source
.Last
:= Source
.Last
- 1;
1050 procedure Sort
(Container
: in out Vector
) is
1052 new Generic_Array_Sort
1053 (Index_Type
=> Count_Type
,
1054 Element_Type
=> Element_Type
,
1055 Array_Type
=> Elements_Array
,
1059 if Container
.Last
<= Index_Type
'First then
1063 -- The exception behavior for the vector container must match that
1064 -- for the list container, so we check for cursor tampering here
1065 -- (which will catch more things) instead of for element tampering
1066 -- (which will catch fewer things). It's true that the elements of
1067 -- this vector container could be safely moved around while (say) an
1068 -- iteration is taking place (iteration only increments the busy
1069 -- counter), and so technically all we would need here is a test for
1070 -- element tampering (indicated by the lock counter), that's simply
1071 -- an artifact of our array-based implementation. Logically Sort
1072 -- requires a check for cursor tampering.
1074 if Container
.Busy
> 0 then
1075 raise Program_Error
with
1076 "attempt to tamper with cursors (vector is busy)";
1079 -- Per AI05-0022, the container implementation is required to detect
1080 -- element tampering by a generic actual subprogram.
1083 B
: Natural renames Container
.Busy
;
1084 L
: Natural renames Container
.Lock
;
1090 Sort
(Container
.Elements
(1 .. Container
.Length
));
1103 end Generic_Sorting
;
1109 function Has_Element
(Position
: Cursor
) return Boolean is
1111 if Position
.Container
= null then
1115 return Position
.Index
<= Position
.Container
.Last
;
1123 (Container
: in out Vector
;
1124 Before
: Extended_Index
;
1125 New_Item
: Element_Type
;
1126 Count
: Count_Type
:= 1)
1128 EA
: Elements_Array
renames Container
.Elements
;
1129 Old_Length
: constant Count_Type
:= Container
.Length
;
1131 Max_Length
: Count_Type
'Base; -- determined from range of Index_Type
1132 New_Length
: Count_Type
'Base; -- sum of current length and Count
1134 Index
: Index_Type
'Base; -- scratch for intermediate values
1135 J
: Count_Type
'Base; -- scratch
1138 -- As a precondition on the generic actual Index_Type, the base type
1139 -- must include Index_Type'Pred (Index_Type'First); this is the value
1140 -- that Container.Last assumes when the vector is empty. However, we do
1141 -- not allow that as the value for Index when specifying where the new
1142 -- items should be inserted, so we must manually check. (That the user
1143 -- is allowed to specify the value at all here is a consequence of the
1144 -- declaration of the Extended_Index subtype, which includes the values
1145 -- in the base range that immediately precede and immediately follow the
1146 -- values in the Index_Type.)
1148 if Before
< Index_Type
'First then
1149 raise Constraint_Error
with
1150 "Before index is out of range (too small)";
1153 -- We do allow a value greater than Container.Last to be specified as
1154 -- the Index, but only if it's immediately greater. This allows for the
1155 -- case of appending items to the back end of the vector. (It is assumed
1156 -- that specifying an index value greater than Last + 1 indicates some
1157 -- deeper flaw in the caller's algorithm, so that case is treated as a
1160 if Before
> Container
.Last
1161 and then Before
> Container
.Last
+ 1
1163 raise Constraint_Error
with
1164 "Before index is out of range (too large)";
1167 -- We treat inserting 0 items into the container as a no-op, even when
1168 -- the container is busy, so we simply return.
1174 -- There are two constraints we need to satisfy. The first constraint is
1175 -- that a container cannot have more than Count_Type'Last elements, so
1176 -- we must check the sum of the current length and the insertion
1177 -- count. Note that we cannot simply add these values, because of the
1178 -- possibility of overflow.
1180 if Old_Length
> Count_Type
'Last - Count
then
1181 raise Constraint_Error
with "Count is out of range";
1184 -- It is now safe compute the length of the new vector, without fear of
1187 New_Length
:= Old_Length
+ Count
;
1189 -- The second constraint is that the new Last index value cannot exceed
1190 -- Index_Type'Last. In each branch below, we calculate the maximum
1191 -- length (computed from the range of values in Index_Type), and then
1192 -- compare the new length to the maximum length. If the new length is
1193 -- acceptable, then we compute the new last index from that.
1195 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1197 -- We have to handle the case when there might be more values in the
1198 -- range of Index_Type than in the range of Count_Type.
1200 if Index_Type'First <= 0 then
1202 -- We know that No_Index (the same as Index_Type'First - 1) is
1203 -- less than 0, so it is safe to compute the following sum without
1204 -- fear of overflow.
1206 Index := No_Index + Index_Type'Base (Count_Type'Last);
1208 if Index <= Index_Type'Last then
1210 -- We have determined that range of Index_Type has at least as
1211 -- many values as in Count_Type, so Count_Type'Last is the
1212 -- maximum number of items that are allowed.
1214 Max_Length := Count_Type'Last;
1217 -- The range of Index_Type has fewer values than in Count_Type,
1218 -- so the maximum number of items is computed from the range of
1221 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1225 -- No_Index is equal or greater than 0, so we can safely compute
1226 -- the difference without fear of overflow (which we would have to
1227 -- worry about if No_Index were less than 0, but that case is
1230 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1233 elsif Index_Type'First <= 0 then
1235 -- We know that No_Index (the same as Index_Type'First - 1) is less
1236 -- than 0, so it is safe to compute the following sum without fear of
1239 J := Count_Type'Base (No_Index) + Count_Type'Last;
1241 if J <= Count_Type'Base (Index_Type'Last) then
1243 -- We have determined that range of Index_Type has at least as
1244 -- many values as in Count_Type, so Count_Type'Last is the maximum
1245 -- number of items that are allowed.
1247 Max_Length := Count_Type'Last;
1250 -- The range of Index_Type has fewer values than Count_Type does,
1251 -- so the maximum number of items is computed from the range of
1255 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1259 -- No_Index is equal or greater than 0, so we can safely compute the
1260 -- difference without fear of overflow (which we would have to worry
1261 -- about if No_Index were less than 0, but that case is handled
1265 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1268 -- We have just computed the maximum length (number of items). We must
1269 -- now compare the requested length to the maximum length, as we do not
1270 -- allow a vector expand beyond the maximum (because that would create
1271 -- an internal array with a last index value greater than
1272 -- Index_Type'Last, with no way to index those elements).
1274 if New_Length > Max_Length then
1275 raise Constraint_Error with "Count is out of range";
1278 -- The tampering bits exist to prevent an item from being harmfully
1279 -- manipulated while it is being visited. Query, Update, and Iterate
1280 -- increment the busy count on entry, and decrement the count on
1281 -- exit. Insert checks the count to determine whether it is being called
1282 -- while the associated callback procedure is executing.
1284 if Container.Busy > 0 then
1285 raise Program_Error with
1286 "attempt to tamper with cursors (vector is busy)";
1289 if New_Length > Container.Capacity then
1290 raise Capacity_Error with "New length is larger than capacity";
1293 J := To_Array_Index (Before);
1295 if Before > Container.Last then
1297 -- The new items are being appended to the vector, so no
1298 -- sliding of existing elements is required.
1300 EA (J .. New_Length) := (others => New_Item);
1303 -- The new items are being inserted before some existing
1304 -- elements, so we must slide the existing elements up to their
1307 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1308 EA (J .. J + Count - 1) := (others => New_Item);
1311 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1312 Container
.Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1316 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1321 (Container
: in out Vector
;
1322 Before
: Extended_Index
;
1325 N
: constant Count_Type
:= Length
(New_Item
);
1326 B
: Count_Type
; -- index Before converted to Count_Type
1329 -- Use Insert_Space to create the "hole" (the destination slice) into
1330 -- which we copy the source items.
1332 Insert_Space
(Container
, Before
, Count
=> N
);
1335 -- There's nothing else to do here (vetting of parameters was
1336 -- performed already in Insert_Space), so we simply return.
1341 B
:= To_Array_Index
(Before
);
1343 if Container
'Address /= New_Item
'Address then
1344 -- This is the simple case. New_Item denotes an object different
1345 -- from Container, so there's nothing special we need to do to copy
1346 -- the source items to their destination, because all of the source
1347 -- items are contiguous.
1349 Container
.Elements
(B
.. B
+ N
- 1) := New_Item
.Elements
(1 .. N
);
1353 -- We refer to array index value Before + N - 1 as J. This is the last
1354 -- index value of the destination slice.
1356 -- New_Item denotes the same object as Container, so an insertion has
1357 -- potentially split the source items. The destination is always the
1358 -- range [Before, J], but the source is [Index_Type'First, Before) and
1359 -- (J, Container.Last]. We perform the copy in two steps, using each of
1360 -- the two slices of the source items.
1363 subtype Src_Index_Subtype
is Count_Type
'Base range 1 .. B
- 1;
1365 Src
: Elements_Array
renames Container
.Elements
(Src_Index_Subtype
);
1368 -- We first copy the source items that precede the space we
1369 -- inserted. (If Before equals Index_Type'First, then this first
1370 -- source slice will be empty, which is harmless.)
1372 Container
.Elements
(B
.. B
+ Src
'Length - 1) := Src
;
1376 subtype Src_Index_Subtype
is Count_Type
'Base range
1377 B
+ N
.. Container
.Length
;
1379 Src
: Elements_Array
renames Container
.Elements
(Src_Index_Subtype
);
1382 -- We next copy the source items that follow the space we inserted.
1384 Container
.Elements
(B
+ N
- Src
'Length .. B
+ N
- 1) := Src
;
1389 (Container
: in out Vector
;
1393 Index
: Index_Type
'Base;
1396 if Before
.Container
/= null
1397 and then Before
.Container
/= Container
'Unchecked_Access
1399 raise Program_Error
with "Before cursor denotes wrong container";
1402 if Is_Empty
(New_Item
) then
1406 if Before
.Container
= null
1407 or else Before
.Index
> Container
.Last
1409 if Container
.Last
= Index_Type
'Last then
1410 raise Constraint_Error
with
1411 "vector is already at its maximum length";
1414 Index
:= Container
.Last
+ 1;
1417 Index
:= Before
.Index
;
1420 Insert
(Container
, Index
, New_Item
);
1424 (Container
: in out Vector
;
1427 Position
: out Cursor
)
1429 Index
: Index_Type
'Base;
1432 if Before
.Container
/= null
1433 and then Before
.Container
/= Container
'Unchecked_Access
1435 raise Program_Error
with "Before cursor denotes wrong container";
1438 if Is_Empty
(New_Item
) then
1439 if Before
.Container
= null
1440 or else Before
.Index
> Container
.Last
1442 Position
:= No_Element
;
1444 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1450 if Before
.Container
= null
1451 or else Before
.Index
> Container
.Last
1453 if Container
.Last
= Index_Type
'Last then
1454 raise Constraint_Error
with
1455 "vector is already at its maximum length";
1458 Index
:= Container
.Last
+ 1;
1461 Index
:= Before
.Index
;
1464 Insert
(Container
, Index
, New_Item
);
1466 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1470 (Container : in out Vector;
1472 New_Item : Element_Type;
1473 Count : Count_Type := 1)
1475 Index : Index_Type'Base;
1478 if Before.Container /= null
1479 and then Before.Container /= Container'Unchecked_Access
1481 raise Program_Error with "Before cursor denotes wrong container";
1488 if Before.Container = null
1489 or else Before.Index > Container.Last
1491 if Container.Last = Index_Type'Last then
1492 raise Constraint_Error with
1493 "vector is already at its maximum length";
1496 Index := Container.Last + 1;
1499 Index := Before.Index;
1502 Insert (Container, Index, New_Item, Count);
1506 (Container : in out Vector;
1508 New_Item : Element_Type;
1509 Position : out Cursor;
1510 Count : Count_Type := 1)
1512 Index : Index_Type'Base;
1515 if Before.Container /= null
1516 and then Before.Container /= Container'Unchecked_Access
1518 raise Program_Error with "Before cursor denotes wrong container";
1522 if Before.Container = null
1523 or else Before.Index > Container.Last
1525 Position := No_Element;
1527 Position := (Container'Unchecked_Access, Before.Index);
1533 if Before.Container = null
1534 or else Before.Index > Container.Last
1536 if Container.Last = Index_Type'Last then
1537 raise Constraint_Error with
1538 "vector is already at its maximum length";
1541 Index := Container.Last + 1;
1544 Index := Before.Index;
1547 Insert (Container, Index, New_Item, Count);
1549 Position := Cursor'(Container
'Unchecked_Access, Index
);
1553 (Container
: in out Vector
;
1554 Before
: Extended_Index
;
1555 Count
: Count_Type
:= 1)
1557 New_Item
: Element_Type
; -- Default-initialized value
1558 pragma Warnings
(Off
, New_Item
);
1561 Insert
(Container
, Before
, New_Item
, Count
);
1565 (Container
: in out Vector
;
1567 Position
: out Cursor
;
1568 Count
: Count_Type
:= 1)
1570 New_Item
: Element_Type
; -- Default-initialized value
1571 pragma Warnings
(Off
, New_Item
);
1574 Insert
(Container
, Before
, New_Item
, Position
, Count
);
1581 procedure Insert_Space
1582 (Container
: in out Vector
;
1583 Before
: Extended_Index
;
1584 Count
: Count_Type
:= 1)
1586 EA
: Elements_Array
renames Container
.Elements
;
1587 Old_Length
: constant Count_Type
:= Container
.Length
;
1589 Max_Length
: Count_Type
'Base; -- determined from range of Index_Type
1590 New_Length
: Count_Type
'Base; -- sum of current length and Count
1592 Index
: Index_Type
'Base; -- scratch for intermediate values
1593 J
: Count_Type
'Base; -- scratch
1596 -- As a precondition on the generic actual Index_Type, the base type
1597 -- must include Index_Type'Pred (Index_Type'First); this is the value
1598 -- that Container.Last assumes when the vector is empty. However, we do
1599 -- not allow that as the value for Index when specifying where the new
1600 -- items should be inserted, so we must manually check. (That the user
1601 -- is allowed to specify the value at all here is a consequence of the
1602 -- declaration of the Extended_Index subtype, which includes the values
1603 -- in the base range that immediately precede and immediately follow the
1604 -- values in the Index_Type.)
1606 if Before
< Index_Type
'First then
1607 raise Constraint_Error
with
1608 "Before index is out of range (too small)";
1611 -- We do allow a value greater than Container.Last to be specified as
1612 -- the Index, but only if it's immediately greater. This allows for the
1613 -- case of appending items to the back end of the vector. (It is assumed
1614 -- that specifying an index value greater than Last + 1 indicates some
1615 -- deeper flaw in the caller's algorithm, so that case is treated as a
1618 if Before
> Container
.Last
1619 and then Before
> Container
.Last
+ 1
1621 raise Constraint_Error
with
1622 "Before index is out of range (too large)";
1625 -- We treat inserting 0 items into the container as a no-op, even when
1626 -- the container is busy, so we simply return.
1632 -- There are two constraints we need to satisfy. The first constraint is
1633 -- that a container cannot have more than Count_Type'Last elements, so
1634 -- we must check the sum of the current length and the insertion count.
1635 -- Note that we cannot simply add these values, because of the
1636 -- possibility of overflow.
1638 if Old_Length
> Count_Type
'Last - Count
then
1639 raise Constraint_Error
with "Count is out of range";
1642 -- It is now safe compute the length of the new vector, without fear of
1645 New_Length
:= Old_Length
+ Count
;
1647 -- The second constraint is that the new Last index value cannot exceed
1648 -- Index_Type'Last. In each branch below, we calculate the maximum
1649 -- length (computed from the range of values in Index_Type), and then
1650 -- compare the new length to the maximum length. If the new length is
1651 -- acceptable, then we compute the new last index from that.
1653 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1655 -- We have to handle the case when there might be more values in the
1656 -- range of Index_Type than in the range of Count_Type.
1658 if Index_Type'First <= 0 then
1660 -- We know that No_Index (the same as Index_Type'First - 1) is
1661 -- less than 0, so it is safe to compute the following sum without
1662 -- fear of overflow.
1664 Index := No_Index + Index_Type'Base (Count_Type'Last);
1666 if Index <= Index_Type'Last then
1668 -- We have determined that range of Index_Type has at least as
1669 -- many values as in Count_Type, so Count_Type'Last is the
1670 -- maximum number of items that are allowed.
1672 Max_Length := Count_Type'Last;
1675 -- The range of Index_Type has fewer values than in Count_Type,
1676 -- so the maximum number of items is computed from the range of
1679 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1683 -- No_Index is equal or greater than 0, so we can safely compute
1684 -- the difference without fear of overflow (which we would have to
1685 -- worry about if No_Index were less than 0, but that case is
1688 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1691 elsif Index_Type'First <= 0 then
1693 -- We know that No_Index (the same as Index_Type'First - 1) is less
1694 -- than 0, so it is safe to compute the following sum without fear of
1697 J := Count_Type'Base (No_Index) + Count_Type'Last;
1699 if J <= Count_Type'Base (Index_Type'Last) then
1701 -- We have determined that range of Index_Type has at least as
1702 -- many values as in Count_Type, so Count_Type'Last is the maximum
1703 -- number of items that are allowed.
1705 Max_Length := Count_Type'Last;
1708 -- The range of Index_Type has fewer values than Count_Type does,
1709 -- so the maximum number of items is computed from the range of
1713 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1717 -- No_Index is equal or greater than 0, so we can safely compute the
1718 -- difference without fear of overflow (which we would have to worry
1719 -- about if No_Index were less than 0, but that case is handled
1723 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1726 -- We have just computed the maximum length (number of items). We must
1727 -- now compare the requested length to the maximum length, as we do not
1728 -- allow a vector expand beyond the maximum (because that would create
1729 -- an internal array with a last index value greater than
1730 -- Index_Type'Last, with no way to index those elements).
1732 if New_Length > Max_Length then
1733 raise Constraint_Error with "Count is out of range";
1736 -- The tampering bits exist to prevent an item from being harmfully
1737 -- manipulated while it is being visited. Query, Update, and Iterate
1738 -- increment the busy count on entry, and decrement the count on
1739 -- exit. Insert checks the count to determine whether it is being called
1740 -- while the associated callback procedure is executing.
1742 if Container.Busy > 0 then
1743 raise Program_Error with
1744 "attempt to tamper with cursors (vector is busy)";
1747 -- An internal array has already been allocated, so we need to check
1748 -- whether there is enough unused storage for the new items.
1750 if New_Length > Container.Capacity then
1751 raise Capacity_Error with "New length is larger than capacity";
1754 -- In this case, we're inserting space into a vector that has already
1755 -- allocated an internal array, and the existing array has enough
1756 -- unused storage for the new items.
1758 if Before <= Container.Last then
1760 -- The space is being inserted before some existing elements,
1761 -- so we must slide the existing elements up to their new home.
1763 J := To_Array_Index (Before);
1764 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1767 -- New_Last is the last index value of the items in the container after
1768 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1769 -- compute its value from the New_Length.
1771 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1772 Container
.Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1776 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1780 procedure Insert_Space
1781 (Container
: in out Vector
;
1783 Position
: out Cursor
;
1784 Count
: Count_Type
:= 1)
1786 Index
: Index_Type
'Base;
1789 if Before
.Container
/= null
1790 and then Before
.Container
/= Container
'Unchecked_Access
1792 raise Program_Error
with "Before cursor denotes wrong container";
1796 if Before
.Container
= null
1797 or else Before
.Index
> Container
.Last
1799 Position
:= No_Element
;
1801 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1807 if Before
.Container
= null
1808 or else Before
.Index
> Container
.Last
1810 if Container
.Last
= Index_Type
'Last then
1811 raise Constraint_Error
with
1812 "vector is already at its maximum length";
1815 Index
:= Container
.Last
+ 1;
1818 Index
:= Before
.Index
;
1821 Insert_Space
(Container
, Index
, Count
=> Count
);
1823 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1830 function Is_Empty (Container : Vector) return Boolean is
1832 return Container.Last < Index_Type'First;
1840 (Container : Vector;
1841 Process : not null access procedure (Position : Cursor))
1843 B : Natural renames Container'Unrestricted_Access.all.Busy;
1849 for Indx in Index_Type'First .. Container.Last loop
1850 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
1862 (Container
: Vector
)
1863 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
1865 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
1866 B
: Natural renames V
.Busy
;
1869 -- The value of its Index component influences the behavior of the First
1870 -- and Last selector functions of the iterator object. When the Index
1871 -- component is No_Index (as is the case here), this means the iterator
1872 -- object was constructed without a start expression. This is a complete
1873 -- iterator, meaning that the iteration starts from the (logical)
1874 -- beginning of the sequence of items.
1876 -- Note: For a forward iterator, Container.First is the beginning, and
1877 -- for a reverse iterator, Container.Last is the beginning.
1879 return It
: constant Iterator
:=
1880 (Limited_Controlled
with
1889 (Container
: Vector
;
1891 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
1893 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
1894 B
: Natural renames V
.Busy
;
1897 -- It was formerly the case that when Start = No_Element, the partial
1898 -- iterator was defined to behave the same as for a complete iterator,
1899 -- and iterate over the entire sequence of items. However, those
1900 -- semantics were unintuitive and arguably error-prone (it is too easy
1901 -- to accidentally create an endless loop), and so they were changed,
1902 -- per the ARG meeting in Denver on 2011/11. However, there was no
1903 -- consensus about what positive meaning this corner case should have,
1904 -- and so it was decided to simply raise an exception. This does imply,
1905 -- however, that it is not possible to use a partial iterator to specify
1906 -- an empty sequence of items.
1908 if Start
.Container
= null then
1909 raise Constraint_Error
with
1910 "Start position for iterator equals No_Element";
1913 if Start
.Container
/= V
then
1914 raise Program_Error
with
1915 "Start cursor of Iterate designates wrong vector";
1918 if Start
.Index
> V
.Last
then
1919 raise Constraint_Error
with
1920 "Start position for iterator equals No_Element";
1923 -- The value of its Index component influences the behavior of the First
1924 -- and Last selector functions of the iterator object. When the Index
1925 -- component is not No_Index (as is the case here), it means that this
1926 -- is a partial iteration, over a subset of the complete sequence of
1927 -- items. The iterator object was constructed with a start expression,
1928 -- indicating the position from which the iteration begins. Note that
1929 -- the start position has the same value irrespective of whether this is
1930 -- a forward or reverse iteration.
1932 return It
: constant Iterator
:=
1933 (Limited_Controlled
with
1935 Index
=> Start
.Index
)
1945 function Last
(Container
: Vector
) return Cursor
is
1947 if Is_Empty
(Container
) then
1950 return (Container
'Unrestricted_Access, Container
.Last
);
1954 function Last
(Object
: Iterator
) return Cursor
is
1956 -- The value of the iterator object's Index component influences the
1957 -- behavior of the Last (and First) selector function.
1959 -- When the Index component is No_Index, this means the iterator object
1960 -- was constructed without a start expression, in which case the
1961 -- (reverse) iteration starts from the (logical) beginning of the entire
1962 -- sequence (corresponding to Container.Last, for a reverse iterator).
1964 -- Otherwise, this is iteration over a partial sequence of items. When
1965 -- the Index component is not No_Index, the iterator object was
1966 -- constructed with a start expression, that specifies the position from
1967 -- which the (reverse) partial iteration begins.
1969 if Object
.Index
= No_Index
then
1970 return Last
(Object
.Container
.all);
1972 return Cursor
'(Object.Container, Object.Index);
1980 function Last_Element (Container : Vector) return Element_Type is
1982 if Container.Last = No_Index then
1983 raise Constraint_Error with "Container is empty";
1985 return Container.Elements (Container.Length);
1993 function Last_Index (Container : Vector) return Extended_Index is
1995 return Container.Last;
2002 function Length (Container : Vector) return Count_Type is
2003 L : constant Index_Type'Base := Container.Last;
2004 F : constant Index_Type := Index_Type'First;
2007 -- The base range of the index type (Index_Type'Base) might not include
2008 -- all values for length (Count_Type). Contrariwise, the index type
2009 -- might include values outside the range of length. Hence we use
2010 -- whatever type is wider for intermediate values when calculating
2011 -- length. Note that no matter what the index type is, the maximum
2012 -- length to which a vector is allowed to grow is always the minimum
2013 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2015 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2016 -- to have a base range of -128 .. 127, but the corresponding vector
2017 -- would have lengths in the range 0 .. 255. In this case we would need
2018 -- to use Count_Type'Base for intermediate values.
2020 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2021 -- vector would have a maximum length of 10, but the index values lie
2022 -- outside the range of Count_Type (which is only 32 bits). In this
2023 -- case we would need to use Index_Type'Base for intermediate values.
2025 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
2026 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2028 return Count_Type (L - F + 1);
2037 (Target : in out Vector;
2038 Source : in out Vector)
2041 if Target'Address = Source'Address then
2045 if Target.Capacity < Source.Length then
2046 raise Capacity_Error -- ???
2047 with "Target capacity is less than Source length";
2050 if Target.Busy > 0 then
2051 raise Program_Error with
2052 "attempt to tamper with cursors (Target is busy)";
2055 if Source.Busy > 0 then
2056 raise Program_Error with
2057 "attempt to tamper with cursors (Source is busy)";
2060 -- Clear Target now, in case element assignment fails
2062 Target.Last := No_Index;
2064 Target.Elements (1 .. Source.Length) :=
2065 Source.Elements (1 .. Source.Length);
2067 Target.Last := Source.Last;
2068 Source.Last := No_Index;
2075 function Next (Position : Cursor) return Cursor is
2077 if Position.Container = null then
2079 elsif Position.Index < Position.Container.Last then
2080 return (Position.Container, Position.Index + 1);
2086 function Next (Object : Iterator; Position : Cursor) return Cursor is
2088 if Position.Container = null then
2090 elsif Position.Container /= Object.Container then
2091 raise Program_Error with
2092 "Position cursor of Next designates wrong vector";
2094 return Next (Position);
2098 procedure Next (Position : in out Cursor) is
2100 if Position.Container = null then
2102 elsif Position.Index < Position.Container.Last then
2103 Position.Index := Position.Index + 1;
2105 Position := No_Element;
2113 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2115 Insert (Container, Index_Type'First, New_Item);
2119 (Container : in out Vector;
2120 New_Item : Element_Type;
2121 Count : Count_Type := 1)
2134 procedure Previous (Position : in out Cursor) is
2136 if Position.Container = null then
2138 elsif Position.Index > Index_Type'First then
2139 Position.Index := Position.Index - 1;
2141 Position := No_Element;
2145 function Previous (Position : Cursor) return Cursor is
2147 if Position.Container = null then
2149 elsif Position.Index > Index_Type'First then
2150 return (Position.Container, Position.Index - 1);
2156 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2158 if Position.Container = null then
2160 elsif Position.Container /= Object.Container then
2161 raise Program_Error with
2162 "Position cursor of Previous designates wrong vector";
2164 return Previous (Position);
2172 procedure Query_Element
2173 (Container : Vector;
2175 Process : not null access procedure (Element : Element_Type))
2177 V : Vector renames Container'Unrestricted_Access.all;
2178 B : Natural renames V.Busy;
2179 L : Natural renames V.Lock;
2182 if Index > Container.Last then
2183 raise Constraint_Error with "Index is out of range";
2190 Process (V.Elements (To_Array_Index (Index)));
2202 procedure Query_Element
2204 Process : not null access procedure (Element : Element_Type))
2207 if Position.Container = null then
2208 raise Constraint_Error with "Position cursor has no element";
2210 Query_Element (Position.Container.all, Position.Index, Process);
2219 (Stream : not null access Root_Stream_Type'Class;
2220 Container : out Vector)
2222 Length : Count_Type'Base;
2223 Last : Index_Type'Base := No_Index;
2228 Count_Type'Base'Read
(Stream
, Length
);
2230 Reserve_Capacity
(Container
, Capacity
=> Length
);
2232 for Idx
in Count_Type
range 1 .. Length
loop
2234 Element_Type
'Read (Stream
, Container
.Elements
(Idx
));
2235 Container
.Last
:= Last
;
2240 (Stream
: not null access Root_Stream_Type
'Class;
2241 Position
: out Cursor
)
2244 raise Program_Error
with "attempt to stream vector cursor";
2248 (Stream
: not null access Root_Stream_Type
'Class;
2249 Item
: out Reference_Type
)
2252 raise Program_Error
with "attempt to stream reference";
2256 (Stream
: not null access Root_Stream_Type
'Class;
2257 Item
: out Constant_Reference_Type
)
2260 raise Program_Error
with "attempt to stream reference";
2268 (Container
: aliased in out Vector
;
2269 Position
: Cursor
) return Reference_Type
2272 if Position
.Container
= null then
2273 raise Constraint_Error
with "Position cursor has no element";
2276 if Position
.Container
/= Container
'Unrestricted_Access then
2277 raise Program_Error
with "Position cursor denotes wrong container";
2280 if Position
.Index
> Position
.Container
.Last
then
2281 raise Constraint_Error
with "Position cursor is out of range";
2285 A
: Elements_Array
renames Container
.Elements
;
2286 J
: constant Count_Type
:= To_Array_Index
(Position
.Index
);
2288 return (Element
=> A
(J
)'Access);
2293 (Container
: aliased in out Vector
;
2294 Index
: Index_Type
) return Reference_Type
2297 if Index
> Container
.Last
then
2298 raise Constraint_Error
with "Index is out of range";
2302 A
: Elements_Array
renames Container
.Elements
;
2303 J
: constant Count_Type
:= To_Array_Index
(Index
);
2305 return (Element
=> A
(J
)'Access);
2309 ---------------------
2310 -- Replace_Element --
2311 ---------------------
2313 procedure Replace_Element
2314 (Container
: in out Vector
;
2316 New_Item
: Element_Type
)
2319 if Index
> Container
.Last
then
2320 raise Constraint_Error
with "Index is out of range";
2321 elsif Container
.Lock
> 0 then
2322 raise Program_Error
with
2323 "attempt to tamper with elements (vector is locked)";
2325 Container
.Elements
(To_Array_Index
(Index
)) := New_Item
;
2327 end Replace_Element
;
2329 procedure Replace_Element
2330 (Container
: in out Vector
;
2332 New_Item
: Element_Type
)
2335 if Position
.Container
= null then
2336 raise Constraint_Error
with "Position cursor has no element";
2338 elsif Position
.Container
/= Container
'Unrestricted_Access then
2339 raise Program_Error
with "Position cursor denotes wrong container";
2341 elsif Position
.Index
> Container
.Last
then
2342 raise Constraint_Error
with "Position cursor is out of range";
2344 elsif Container
.Lock
> 0 then
2345 raise Program_Error
with
2346 "attempt to tamper with elements (vector is locked)";
2349 Container
.Elements
(To_Array_Index
(Position
.Index
)) := New_Item
;
2351 end Replace_Element
;
2353 ----------------------
2354 -- Reserve_Capacity --
2355 ----------------------
2357 procedure Reserve_Capacity
2358 (Container
: in out Vector
;
2359 Capacity
: Count_Type
)
2362 if Capacity
> Container
.Capacity
then
2363 raise Constraint_Error
with "Capacity is out of range";
2365 end Reserve_Capacity
;
2367 ----------------------
2368 -- Reverse_Elements --
2369 ----------------------
2371 procedure Reverse_Elements
(Container
: in out Vector
) is
2372 E
: Elements_Array
renames Container
.Elements
;
2377 if Container
.Length
<= 1 then
2381 -- The exception behavior for the vector container must match that for
2382 -- the list container, so we check for cursor tampering here (which will
2383 -- catch more things) instead of for element tampering (which will catch
2384 -- fewer things). It's true that the elements of this vector container
2385 -- could be safely moved around while (say) an iteration is taking place
2386 -- (iteration only increments the busy counter), and so technically
2387 -- all we would need here is a test for element tampering (indicated
2388 -- by the lock counter), that's simply an artifact of our array-based
2389 -- implementation. Logically Reverse_Elements requires a check for
2390 -- cursor tampering.
2392 if Container
.Busy
> 0 then
2393 raise Program_Error
with
2394 "attempt to tamper with cursors (vector is busy)";
2398 Jdx
:= Container
.Length
;
2399 while Idx
< Jdx
loop
2401 EI
: constant Element_Type
:= E
(Idx
);
2411 end Reverse_Elements
;
2417 function Reverse_Find
2418 (Container
: Vector
;
2419 Item
: Element_Type
;
2420 Position
: Cursor
:= No_Element
) return Cursor
2422 Last
: Index_Type
'Base;
2425 if Position
.Container
/= null
2426 and then Position
.Container
/= Container
'Unrestricted_Access
2428 raise Program_Error
with "Position cursor denotes wrong container";
2432 (if Position
.Container
= null or else Position
.Index
> Container
.Last
2434 else Position
.Index
);
2436 -- Per AI05-0022, the container implementation is required to detect
2437 -- element tampering by a generic actual subprogram.
2440 B
: Natural renames Container
'Unrestricted_Access.Busy
;
2441 L
: Natural renames Container
'Unrestricted_Access.Lock
;
2443 Result
: Index_Type
'Base;
2450 for Indx
in reverse Index_Type
'First .. Last
loop
2451 if Container
.Elements
(To_Array_Index
(Indx
)) = Item
then
2460 if Result
= No_Index
then
2463 return Cursor
'(Container'Unrestricted_Access, Result);
2473 ------------------------
2474 -- Reverse_Find_Index --
2475 ------------------------
2477 function Reverse_Find_Index
2478 (Container : Vector;
2479 Item : Element_Type;
2480 Index : Index_Type := Index_Type'Last) return Extended_Index
2482 B : Natural renames Container'Unrestricted_Access.Busy;
2483 L : Natural renames Container'Unrestricted_Access.Lock;
2485 Last : constant Index_Type'Base :=
2486 Index_Type'Min (Container.Last, Index);
2488 Result : Index_Type'Base;
2491 -- Per AI05-0022, the container implementation is required to detect
2492 -- element tampering by a generic actual subprogram.
2498 for Indx in reverse Index_Type'First .. Last loop
2499 if Container.Elements (To_Array_Index (Indx)) = Item then
2515 end Reverse_Find_Index;
2517 ---------------------
2518 -- Reverse_Iterate --
2519 ---------------------
2521 procedure Reverse_Iterate
2522 (Container : Vector;
2523 Process : not null access procedure (Position : Cursor))
2525 V : Vector renames Container'Unrestricted_Access.all;
2526 B : Natural renames V.Busy;
2532 for Indx in reverse Index_Type'First .. Container.Last loop
2533 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
2542 end Reverse_Iterate
;
2548 procedure Set_Length
(Container
: in out Vector
; Length
: Count_Type
) is
2549 Count
: constant Count_Type
'Base := Container
.Length
- Length
;
2552 -- Set_Length allows the user to set the length explicitly, instead of
2553 -- implicitly as a side-effect of deletion or insertion. If the
2554 -- requested length is less than the current length, this is equivalent
2555 -- to deleting items from the back end of the vector. If the requested
2556 -- length is greater than the current length, then this is equivalent to
2557 -- inserting "space" (nonce items) at the end.
2560 Container
.Delete_Last
(Count
);
2561 elsif Container
.Last
>= Index_Type
'Last then
2562 raise Constraint_Error
with "vector is already at its maximum length";
2564 Container
.Insert_Space
(Container
.Last
+ 1, -Count
);
2572 procedure Swap
(Container
: in out Vector
; I
, J
: Index_Type
) is
2573 E
: Elements_Array
renames Container
.Elements
;
2576 if I
> Container
.Last
then
2577 raise Constraint_Error
with "I index is out of range";
2580 if J
> Container
.Last
then
2581 raise Constraint_Error
with "J index is out of range";
2588 if Container
.Lock
> 0 then
2589 raise Program_Error
with
2590 "attempt to tamper with elements (vector is locked)";
2594 EI_Copy
: constant Element_Type
:= E
(To_Array_Index
(I
));
2596 E
(To_Array_Index
(I
)) := E
(To_Array_Index
(J
));
2597 E
(To_Array_Index
(J
)) := EI_Copy
;
2601 procedure Swap
(Container
: in out Vector
; I
, J
: Cursor
) is
2603 if I
.Container
= null then
2604 raise Constraint_Error
with "I cursor has no element";
2607 if J
.Container
= null then
2608 raise Constraint_Error
with "J cursor has no element";
2611 if I
.Container
/= Container
'Unrestricted_Access then
2612 raise Program_Error
with "I cursor denotes wrong container";
2615 if J
.Container
/= Container
'Unrestricted_Access then
2616 raise Program_Error
with "J cursor denotes wrong container";
2619 Swap
(Container
, I
.Index
, J
.Index
);
2622 --------------------
2623 -- To_Array_Index --
2624 --------------------
2626 function To_Array_Index
(Index
: Index_Type
'Base) return Count_Type
'Base is
2627 Offset
: Count_Type
'Base;
2631 -- Index >= Index_Type'First
2632 -- hence we also know that
2633 -- Index - Index_Type'First >= 0
2635 -- The issue is that even though 0 is guaranteed to be a value in
2636 -- the type Index_Type'Base, there's no guarantee that the difference
2637 -- is a value in that type. To prevent overflow we use the wider
2638 -- of Count_Type'Base and Index_Type'Base to perform intermediate
2641 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2642 Offset := Count_Type'Base (Index - Index_Type'First);
2645 Offset := Count_Type'Base (Index) -
2646 Count_Type'Base (Index_Type'First);
2649 -- The array index subtype for all container element arrays
2650 -- always starts with 1.
2660 (Container : Vector;
2661 Index : Extended_Index) return Cursor
2664 if Index not in Index_Type'First .. Container.Last then
2668 return Cursor'(Container
'Unrestricted_Access, Index
);
2675 function To_Index
(Position
: Cursor
) return Extended_Index
is
2677 if Position
.Container
= null then
2681 if Position
.Index
<= Position
.Container
.Last
then
2682 return Position
.Index
;
2692 function To_Vector
(Length
: Count_Type
) return Vector
is
2693 Index
: Count_Type
'Base;
2694 Last
: Index_Type
'Base;
2698 return Empty_Vector
;
2701 -- We create a vector object with a capacity that matches the specified
2702 -- Length, but we do not allow the vector capacity (the length of the
2703 -- internal array) to exceed the number of values in Index_Type'Range
2704 -- (otherwise, there would be no way to refer to those components via an
2705 -- index). We must therefore check whether the specified Length would
2706 -- create a Last index value greater than Index_Type'Last.
2708 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2709 -- We perform a two-part test. First we determine whether the
2710 -- computed Last value lies in the base range of the type, and then
2711 -- determine whether it lies in the range of the index (sub)type.
2713 -- Last must satisfy this relation:
2714 -- First + Length - 1 <= Last
2715 -- We regroup terms:
2716 -- First - 1 <= Last - Length
2717 -- Which can rewrite as:
2718 -- No_Index <= Last - Length
2720 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
2721 raise Constraint_Error
with "Length is out of range";
2724 -- We now know that the computed value of Last is within the base
2725 -- range of the type, so it is safe to compute its value:
2727 Last
:= No_Index
+ Index_Type
'Base (Length
);
2729 -- Finally we test whether the value is within the range of the
2730 -- generic actual index subtype:
2732 if Last
> Index_Type
'Last then
2733 raise Constraint_Error
with "Length is out of range";
2736 elsif Index_Type
'First <= 0 then
2738 -- Here we can compute Last directly, in the normal way. We know that
2739 -- No_Index is less than 0, so there is no danger of overflow when
2740 -- adding the (positive) value of Length.
2742 Index
:= Count_Type
'Base (No_Index
) + Length
; -- Last
2744 if Index
> Count_Type
'Base (Index_Type
'Last) then
2745 raise Constraint_Error
with "Length is out of range";
2748 -- We know that the computed value (having type Count_Type) of Last
2749 -- is within the range of the generic actual index subtype, so it is
2750 -- safe to convert to Index_Type:
2752 Last
:= Index_Type
'Base (Index
);
2755 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2756 -- must test the length indirectly (by working backwards from the
2757 -- largest possible value of Last), in order to prevent overflow.
2759 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
2761 if Index
< Count_Type
'Base (No_Index
) then
2762 raise Constraint_Error
with "Length is out of range";
2765 -- We have determined that the value of Length would not create a
2766 -- Last index value outside of the range of Index_Type, so we can now
2767 -- safely compute its value.
2769 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
2772 return V
: Vector
(Capacity
=> Length
) do
2778 (New_Item
: Element_Type
;
2779 Length
: Count_Type
) return Vector
2781 Index
: Count_Type
'Base;
2782 Last
: Index_Type
'Base;
2786 return Empty_Vector
;
2789 -- We create a vector object with a capacity that matches the specified
2790 -- Length, but we do not allow the vector capacity (the length of the
2791 -- internal array) to exceed the number of values in Index_Type'Range
2792 -- (otherwise, there would be no way to refer to those components via an
2793 -- index). We must therefore check whether the specified Length would
2794 -- create a Last index value greater than Index_Type'Last.
2796 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2798 -- We perform a two-part test. First we determine whether the
2799 -- computed Last value lies in the base range of the type, and then
2800 -- determine whether it lies in the range of the index (sub)type.
2802 -- Last must satisfy this relation:
2803 -- First + Length - 1 <= Last
2804 -- We regroup terms:
2805 -- First - 1 <= Last - Length
2806 -- Which can rewrite as:
2807 -- No_Index <= Last - Length
2809 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
2810 raise Constraint_Error
with "Length is out of range";
2813 -- We now know that the computed value of Last is within the base
2814 -- range of the type, so it is safe to compute its value:
2816 Last
:= No_Index
+ Index_Type
'Base (Length
);
2818 -- Finally we test whether the value is within the range of the
2819 -- generic actual index subtype:
2821 if Last
> Index_Type
'Last then
2822 raise Constraint_Error
with "Length is out of range";
2825 elsif Index_Type
'First <= 0 then
2827 -- Here we can compute Last directly, in the normal way. We know that
2828 -- No_Index is less than 0, so there is no danger of overflow when
2829 -- adding the (positive) value of Length.
2831 Index
:= Count_Type
'Base (No_Index
) + Length
; -- same value as V.Last
2833 if Index
> Count_Type
'Base (Index_Type
'Last) then
2834 raise Constraint_Error
with "Length is out of range";
2837 -- We know that the computed value (having type Count_Type) of Last
2838 -- is within the range of the generic actual index subtype, so it is
2839 -- safe to convert to Index_Type:
2841 Last
:= Index_Type
'Base (Index
);
2844 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2845 -- must test the length indirectly (by working backwards from the
2846 -- largest possible value of Last), in order to prevent overflow.
2848 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
2850 if Index
< Count_Type
'Base (No_Index
) then
2851 raise Constraint_Error
with "Length is out of range";
2854 -- We have determined that the value of Length would not create a
2855 -- Last index value outside of the range of Index_Type, so we can now
2856 -- safely compute its value.
2858 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
2861 return V
: Vector
(Capacity
=> Length
) do
2862 V
.Elements
:= (others => New_Item
);
2867 --------------------
2868 -- Update_Element --
2869 --------------------
2871 procedure Update_Element
2872 (Container
: in out Vector
;
2874 Process
: not null access procedure (Element
: in out Element_Type
))
2876 B
: Natural renames Container
.Busy
;
2877 L
: Natural renames Container
.Lock
;
2880 if Index
> Container
.Last
then
2881 raise Constraint_Error
with "Index is out of range";
2888 Process
(Container
.Elements
(To_Array_Index
(Index
)));
2900 procedure Update_Element
2901 (Container
: in out Vector
;
2903 Process
: not null access procedure (Element
: in out Element_Type
))
2906 if Position
.Container
= null then
2907 raise Constraint_Error
with "Position cursor has no element";
2910 if Position
.Container
/= Container
'Unrestricted_Access then
2911 raise Program_Error
with "Position cursor denotes wrong container";
2914 Update_Element
(Container
, Position
.Index
, Process
);
2922 (Stream
: not null access Root_Stream_Type
'Class;
2928 N
:= Container
.Length
;
2929 Count_Type
'Base'Write (Stream, N);
2931 for J in 1 .. N loop
2932 Element_Type'Write (Stream, Container.Elements (J));
2937 (Stream : not null access Root_Stream_Type'Class;
2941 raise Program_Error with "attempt to stream vector cursor";
2945 (Stream : not null access Root_Stream_Type'Class;
2946 Item : Reference_Type)
2949 raise Program_Error with "attempt to stream reference";
2953 (Stream : not null access Root_Stream_Type'Class;
2954 Item : Constant_Reference_Type)
2957 raise Program_Error with "attempt to stream reference";
2960 end Ada.Containers.Bounded_Vectors;