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 if Index_Type'Last - No_Index >=
1231 Count_Type'Pos (Count_Type'Last)
1233 -- We have determined that range of Index_Type has at least as
1234 -- many values as in Count_Type, so Count_Type'Last is the
1235 -- maximum number of items that are allowed.
1237 Max_Length := Count_Type'Last;
1240 -- The range of Index_Type has fewer values than in Count_Type,
1241 -- so the maximum number of items is computed from the range of
1244 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1248 elsif Index_Type'First <= 0 then
1250 -- We know that No_Index (the same as Index_Type'First - 1) is less
1251 -- than 0, so it is safe to compute the following sum without fear of
1254 J := Count_Type'Base (No_Index) + Count_Type'Last;
1256 if J <= Count_Type'Base (Index_Type'Last) then
1258 -- We have determined that range of Index_Type has at least as
1259 -- many values as in Count_Type, so Count_Type'Last is the maximum
1260 -- number of items that are allowed.
1262 Max_Length := Count_Type'Last;
1265 -- The range of Index_Type has fewer values than Count_Type does,
1266 -- so the maximum number of items is computed from the range of
1270 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1274 -- No_Index is equal or greater than 0, so we can safely compute the
1275 -- difference without fear of overflow (which we would have to worry
1276 -- about if No_Index were less than 0, but that case is handled
1280 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1283 -- We have just computed the maximum length (number of items). We must
1284 -- now compare the requested length to the maximum length, as we do not
1285 -- allow a vector expand beyond the maximum (because that would create
1286 -- an internal array with a last index value greater than
1287 -- Index_Type'Last, with no way to index those elements).
1289 if New_Length > Max_Length then
1290 raise Constraint_Error with "Count is out of range";
1293 -- The tampering bits exist to prevent an item from being harmfully
1294 -- manipulated while it is being visited. Query, Update, and Iterate
1295 -- increment the busy count on entry, and decrement the count on
1296 -- exit. Insert checks the count to determine whether it is being called
1297 -- while the associated callback procedure is executing.
1299 if Container.Busy > 0 then
1300 raise Program_Error with
1301 "attempt to tamper with cursors (vector is busy)";
1304 if New_Length > Container.Capacity then
1305 raise Capacity_Error with "New length is larger than capacity";
1308 J := To_Array_Index (Before);
1310 if Before > Container.Last then
1312 -- The new items are being appended to the vector, so no
1313 -- sliding of existing elements is required.
1315 EA (J .. New_Length) := (others => New_Item);
1318 -- The new items are being inserted before some existing
1319 -- elements, so we must slide the existing elements up to their
1322 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1323 EA (J .. J + Count - 1) := (others => New_Item);
1326 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1327 Container
.Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1331 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1336 (Container
: in out Vector
;
1337 Before
: Extended_Index
;
1340 N
: constant Count_Type
:= Length
(New_Item
);
1341 B
: Count_Type
; -- index Before converted to Count_Type
1344 -- Use Insert_Space to create the "hole" (the destination slice) into
1345 -- which we copy the source items.
1347 Insert_Space
(Container
, Before
, Count
=> N
);
1350 -- There's nothing else to do here (vetting of parameters was
1351 -- performed already in Insert_Space), so we simply return.
1356 B
:= To_Array_Index
(Before
);
1358 if Container
'Address /= New_Item
'Address then
1359 -- This is the simple case. New_Item denotes an object different
1360 -- from Container, so there's nothing special we need to do to copy
1361 -- the source items to their destination, because all of the source
1362 -- items are contiguous.
1364 Container
.Elements
(B
.. B
+ N
- 1) := New_Item
.Elements
(1 .. N
);
1368 -- We refer to array index value Before + N - 1 as J. This is the last
1369 -- index value of the destination slice.
1371 -- New_Item denotes the same object as Container, so an insertion has
1372 -- potentially split the source items. The destination is always the
1373 -- range [Before, J], but the source is [Index_Type'First, Before) and
1374 -- (J, Container.Last]. We perform the copy in two steps, using each of
1375 -- the two slices of the source items.
1378 subtype Src_Index_Subtype
is Count_Type
'Base range 1 .. B
- 1;
1380 Src
: Elements_Array
renames Container
.Elements
(Src_Index_Subtype
);
1383 -- We first copy the source items that precede the space we
1384 -- inserted. (If Before equals Index_Type'First, then this first
1385 -- source slice will be empty, which is harmless.)
1387 Container
.Elements
(B
.. B
+ Src
'Length - 1) := Src
;
1391 subtype Src_Index_Subtype
is Count_Type
'Base range
1392 B
+ N
.. Container
.Length
;
1394 Src
: Elements_Array
renames Container
.Elements
(Src_Index_Subtype
);
1397 -- We next copy the source items that follow the space we inserted.
1399 Container
.Elements
(B
+ N
- Src
'Length .. B
+ N
- 1) := Src
;
1404 (Container
: in out Vector
;
1408 Index
: Index_Type
'Base;
1411 if Before
.Container
/= null
1412 and then Before
.Container
/= Container
'Unchecked_Access
1414 raise Program_Error
with "Before cursor denotes wrong container";
1417 if Is_Empty
(New_Item
) then
1421 if Before
.Container
= null
1422 or else Before
.Index
> Container
.Last
1424 if Container
.Last
= Index_Type
'Last then
1425 raise Constraint_Error
with
1426 "vector is already at its maximum length";
1429 Index
:= Container
.Last
+ 1;
1432 Index
:= Before
.Index
;
1435 Insert
(Container
, Index
, New_Item
);
1439 (Container
: in out Vector
;
1442 Position
: out Cursor
)
1444 Index
: Index_Type
'Base;
1447 if Before
.Container
/= null
1448 and then Before
.Container
/= Container
'Unchecked_Access
1450 raise Program_Error
with "Before cursor denotes wrong container";
1453 if Is_Empty
(New_Item
) then
1454 if Before
.Container
= null
1455 or else Before
.Index
> Container
.Last
1457 Position
:= No_Element
;
1459 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1465 if Before
.Container
= null
1466 or else Before
.Index
> Container
.Last
1468 if Container
.Last
= Index_Type
'Last then
1469 raise Constraint_Error
with
1470 "vector is already at its maximum length";
1473 Index
:= Container
.Last
+ 1;
1476 Index
:= Before
.Index
;
1479 Insert
(Container
, Index
, New_Item
);
1481 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1485 (Container : in out Vector;
1487 New_Item : Element_Type;
1488 Count : Count_Type := 1)
1490 Index : Index_Type'Base;
1493 if Before.Container /= null
1494 and then Before.Container /= Container'Unchecked_Access
1496 raise Program_Error with "Before cursor denotes wrong container";
1503 if Before.Container = null
1504 or else Before.Index > Container.Last
1506 if Container.Last = Index_Type'Last then
1507 raise Constraint_Error with
1508 "vector is already at its maximum length";
1511 Index := Container.Last + 1;
1514 Index := Before.Index;
1517 Insert (Container, Index, New_Item, Count);
1521 (Container : in out Vector;
1523 New_Item : Element_Type;
1524 Position : out Cursor;
1525 Count : Count_Type := 1)
1527 Index : Index_Type'Base;
1530 if Before.Container /= null
1531 and then Before.Container /= Container'Unchecked_Access
1533 raise Program_Error with "Before cursor denotes wrong container";
1537 if Before.Container = null
1538 or else Before.Index > Container.Last
1540 Position := No_Element;
1542 Position := (Container'Unchecked_Access, Before.Index);
1548 if Before.Container = null
1549 or else Before.Index > Container.Last
1551 if Container.Last = Index_Type'Last then
1552 raise Constraint_Error with
1553 "vector is already at its maximum length";
1556 Index := Container.Last + 1;
1559 Index := Before.Index;
1562 Insert (Container, Index, New_Item, Count);
1564 Position := Cursor'(Container
'Unchecked_Access, Index
);
1568 (Container
: in out Vector
;
1569 Before
: Extended_Index
;
1570 Count
: Count_Type
:= 1)
1572 New_Item
: Element_Type
; -- Default-initialized value
1573 pragma Warnings
(Off
, New_Item
);
1576 Insert
(Container
, Before
, New_Item
, Count
);
1580 (Container
: in out Vector
;
1582 Position
: out Cursor
;
1583 Count
: Count_Type
:= 1)
1585 New_Item
: Element_Type
; -- Default-initialized value
1586 pragma Warnings
(Off
, New_Item
);
1589 Insert
(Container
, Before
, New_Item
, Position
, Count
);
1596 procedure Insert_Space
1597 (Container
: in out Vector
;
1598 Before
: Extended_Index
;
1599 Count
: Count_Type
:= 1)
1601 EA
: Elements_Array
renames Container
.Elements
;
1602 Old_Length
: constant Count_Type
:= Container
.Length
;
1604 Max_Length
: Count_Type
'Base; -- determined from range of Index_Type
1605 New_Length
: Count_Type
'Base; -- sum of current length and Count
1607 Index
: Index_Type
'Base; -- scratch for intermediate values
1608 J
: Count_Type
'Base; -- scratch
1611 -- As a precondition on the generic actual Index_Type, the base type
1612 -- must include Index_Type'Pred (Index_Type'First); this is the value
1613 -- that Container.Last assumes when the vector is empty. However, we do
1614 -- not allow that as the value for Index when specifying where the new
1615 -- items should be inserted, so we must manually check. (That the user
1616 -- is allowed to specify the value at all here is a consequence of the
1617 -- declaration of the Extended_Index subtype, which includes the values
1618 -- in the base range that immediately precede and immediately follow the
1619 -- values in the Index_Type.)
1621 if Before
< Index_Type
'First then
1622 raise Constraint_Error
with
1623 "Before index is out of range (too small)";
1626 -- We do allow a value greater than Container.Last to be specified as
1627 -- the Index, but only if it's immediately greater. This allows for the
1628 -- case of appending items to the back end of the vector. (It is assumed
1629 -- that specifying an index value greater than Last + 1 indicates some
1630 -- deeper flaw in the caller's algorithm, so that case is treated as a
1633 if Before
> Container
.Last
1634 and then Before
> Container
.Last
+ 1
1636 raise Constraint_Error
with
1637 "Before index is out of range (too large)";
1640 -- We treat inserting 0 items into the container as a no-op, even when
1641 -- the container is busy, so we simply return.
1647 -- There are two constraints we need to satisfy. The first constraint is
1648 -- that a container cannot have more than Count_Type'Last elements, so
1649 -- we must check the sum of the current length and the insertion count.
1650 -- Note that we cannot simply add these values, because of the
1651 -- possibility of overflow.
1653 if Old_Length
> Count_Type
'Last - Count
then
1654 raise Constraint_Error
with "Count is out of range";
1657 -- It is now safe compute the length of the new vector, without fear of
1660 New_Length
:= Old_Length
+ Count
;
1662 -- The second constraint is that the new Last index value cannot exceed
1663 -- Index_Type'Last. In each branch below, we calculate the maximum
1664 -- length (computed from the range of values in Index_Type), and then
1665 -- compare the new length to the maximum length. If the new length is
1666 -- acceptable, then we compute the new last index from that.
1668 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1670 -- We have to handle the case when there might be more values in the
1671 -- range of Index_Type than in the range of Count_Type.
1673 if Index_Type'First <= 0 then
1675 -- We know that No_Index (the same as Index_Type'First - 1) is
1676 -- less than 0, so it is safe to compute the following sum without
1677 -- fear of overflow.
1679 Index := No_Index + Index_Type'Base (Count_Type'Last);
1681 if Index <= Index_Type'Last then
1683 -- We have determined that range of Index_Type has at least as
1684 -- many values as in Count_Type, so Count_Type'Last is the
1685 -- maximum number of items that are allowed.
1687 Max_Length := Count_Type'Last;
1690 -- The range of Index_Type has fewer values than in Count_Type,
1691 -- so the maximum number of items is computed from the range of
1694 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1698 -- No_Index is equal or greater than 0, so we can safely compute
1699 -- the difference without fear of overflow (which we would have to
1700 -- worry about if No_Index were less than 0, but that case is
1703 if Index_Type'Last - No_Index >=
1704 Count_Type'Pos (Count_Type'Last)
1706 -- We have determined that range of Index_Type has at least as
1707 -- many values as in Count_Type, so Count_Type'Last is the
1708 -- maximum number of items that are allowed.
1710 Max_Length := Count_Type'Last;
1713 -- The range of Index_Type has fewer values than in Count_Type,
1714 -- so the maximum number of items is computed from the range of
1717 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1721 elsif Index_Type'First <= 0 then
1723 -- We know that No_Index (the same as Index_Type'First - 1) is less
1724 -- than 0, so it is safe to compute the following sum without fear of
1727 J := Count_Type'Base (No_Index) + Count_Type'Last;
1729 if J <= Count_Type'Base (Index_Type'Last) then
1731 -- We have determined that range of Index_Type has at least as
1732 -- many values as in Count_Type, so Count_Type'Last is the maximum
1733 -- number of items that are allowed.
1735 Max_Length := Count_Type'Last;
1738 -- The range of Index_Type has fewer values than Count_Type does,
1739 -- so the maximum number of items is computed from the range of
1743 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1747 -- No_Index is equal or greater than 0, so we can safely compute the
1748 -- difference without fear of overflow (which we would have to worry
1749 -- about if No_Index were less than 0, but that case is handled
1753 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1756 -- We have just computed the maximum length (number of items). We must
1757 -- now compare the requested length to the maximum length, as we do not
1758 -- allow a vector expand beyond the maximum (because that would create
1759 -- an internal array with a last index value greater than
1760 -- Index_Type'Last, with no way to index those elements).
1762 if New_Length > Max_Length then
1763 raise Constraint_Error with "Count is out of range";
1766 -- The tampering bits exist to prevent an item from being harmfully
1767 -- manipulated while it is being visited. Query, Update, and Iterate
1768 -- increment the busy count on entry, and decrement the count on
1769 -- exit. Insert checks the count to determine whether it is being called
1770 -- while the associated callback procedure is executing.
1772 if Container.Busy > 0 then
1773 raise Program_Error with
1774 "attempt to tamper with cursors (vector is busy)";
1777 -- An internal array has already been allocated, so we need to check
1778 -- whether there is enough unused storage for the new items.
1780 if New_Length > Container.Capacity then
1781 raise Capacity_Error with "New length is larger than capacity";
1784 -- In this case, we're inserting space into a vector that has already
1785 -- allocated an internal array, and the existing array has enough
1786 -- unused storage for the new items.
1788 if Before <= Container.Last then
1790 -- The space is being inserted before some existing elements,
1791 -- so we must slide the existing elements up to their new home.
1793 J := To_Array_Index (Before);
1794 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1797 -- New_Last is the last index value of the items in the container after
1798 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1799 -- compute its value from the New_Length.
1801 if Index_Type'Base'Last
>= Count_Type
'Pos (Count_Type
'Last) then
1802 Container
.Last
:= No_Index
+ Index_Type
'Base (New_Length
);
1806 Index_Type
'Base (Count_Type
'Base (No_Index
) + New_Length
);
1810 procedure Insert_Space
1811 (Container
: in out Vector
;
1813 Position
: out Cursor
;
1814 Count
: Count_Type
:= 1)
1816 Index
: Index_Type
'Base;
1819 if Before
.Container
/= null
1820 and then Before
.Container
/= Container
'Unchecked_Access
1822 raise Program_Error
with "Before cursor denotes wrong container";
1826 if Before
.Container
= null
1827 or else Before
.Index
> Container
.Last
1829 Position
:= No_Element
;
1831 Position
:= (Container
'Unchecked_Access, Before
.Index
);
1837 if Before
.Container
= null
1838 or else Before
.Index
> Container
.Last
1840 if Container
.Last
= Index_Type
'Last then
1841 raise Constraint_Error
with
1842 "vector is already at its maximum length";
1845 Index
:= Container
.Last
+ 1;
1848 Index
:= Before
.Index
;
1851 Insert_Space
(Container
, Index
, Count
=> Count
);
1853 Position
:= Cursor
'(Container'Unchecked_Access, Index);
1860 function Is_Empty (Container : Vector) return Boolean is
1862 return Container.Last < Index_Type'First;
1870 (Container : Vector;
1871 Process : not null access procedure (Position : Cursor))
1873 B : Natural renames Container'Unrestricted_Access.all.Busy;
1879 for Indx in Index_Type'First .. Container.Last loop
1880 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
1892 (Container
: Vector
)
1893 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
1895 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
1896 B
: Natural renames V
.Busy
;
1899 -- The value of its Index component influences the behavior of the First
1900 -- and Last selector functions of the iterator object. When the Index
1901 -- component is No_Index (as is the case here), this means the iterator
1902 -- object was constructed without a start expression. This is a complete
1903 -- iterator, meaning that the iteration starts from the (logical)
1904 -- beginning of the sequence of items.
1906 -- Note: For a forward iterator, Container.First is the beginning, and
1907 -- for a reverse iterator, Container.Last is the beginning.
1909 return It
: constant Iterator
:=
1910 (Limited_Controlled
with
1919 (Container
: Vector
;
1921 return Vector_Iterator_Interfaces
.Reversible_Iterator
'Class
1923 V
: constant Vector_Access
:= Container
'Unrestricted_Access;
1924 B
: Natural renames V
.Busy
;
1927 -- It was formerly the case that when Start = No_Element, the partial
1928 -- iterator was defined to behave the same as for a complete iterator,
1929 -- and iterate over the entire sequence of items. However, those
1930 -- semantics were unintuitive and arguably error-prone (it is too easy
1931 -- to accidentally create an endless loop), and so they were changed,
1932 -- per the ARG meeting in Denver on 2011/11. However, there was no
1933 -- consensus about what positive meaning this corner case should have,
1934 -- and so it was decided to simply raise an exception. This does imply,
1935 -- however, that it is not possible to use a partial iterator to specify
1936 -- an empty sequence of items.
1938 if Start
.Container
= null then
1939 raise Constraint_Error
with
1940 "Start position for iterator equals No_Element";
1943 if Start
.Container
/= V
then
1944 raise Program_Error
with
1945 "Start cursor of Iterate designates wrong vector";
1948 if Start
.Index
> V
.Last
then
1949 raise Constraint_Error
with
1950 "Start position for iterator equals No_Element";
1953 -- The value of its Index component influences the behavior of the First
1954 -- and Last selector functions of the iterator object. When the Index
1955 -- component is not No_Index (as is the case here), it means that this
1956 -- is a partial iteration, over a subset of the complete sequence of
1957 -- items. The iterator object was constructed with a start expression,
1958 -- indicating the position from which the iteration begins. Note that
1959 -- the start position has the same value irrespective of whether this is
1960 -- a forward or reverse iteration.
1962 return It
: constant Iterator
:=
1963 (Limited_Controlled
with
1965 Index
=> Start
.Index
)
1975 function Last
(Container
: Vector
) return Cursor
is
1977 if Is_Empty
(Container
) then
1980 return (Container
'Unrestricted_Access, Container
.Last
);
1984 function Last
(Object
: Iterator
) return Cursor
is
1986 -- The value of the iterator object's Index component influences the
1987 -- behavior of the Last (and First) selector function.
1989 -- When the Index component is No_Index, this means the iterator object
1990 -- was constructed without a start expression, in which case the
1991 -- (reverse) iteration starts from the (logical) beginning of the entire
1992 -- sequence (corresponding to Container.Last, for a reverse iterator).
1994 -- Otherwise, this is iteration over a partial sequence of items. When
1995 -- the Index component is not No_Index, the iterator object was
1996 -- constructed with a start expression, that specifies the position from
1997 -- which the (reverse) partial iteration begins.
1999 if Object
.Index
= No_Index
then
2000 return Last
(Object
.Container
.all);
2002 return Cursor
'(Object.Container, Object.Index);
2010 function Last_Element (Container : Vector) return Element_Type is
2012 if Container.Last = No_Index then
2013 raise Constraint_Error with "Container is empty";
2015 return Container.Elements (Container.Length);
2023 function Last_Index (Container : Vector) return Extended_Index is
2025 return Container.Last;
2032 function Length (Container : Vector) return Count_Type is
2033 L : constant Index_Type'Base := Container.Last;
2034 F : constant Index_Type := Index_Type'First;
2037 -- The base range of the index type (Index_Type'Base) might not include
2038 -- all values for length (Count_Type). Contrariwise, the index type
2039 -- might include values outside the range of length. Hence we use
2040 -- whatever type is wider for intermediate values when calculating
2041 -- length. Note that no matter what the index type is, the maximum
2042 -- length to which a vector is allowed to grow is always the minimum
2043 -- of Count_Type'Last and (IT'Last - IT'First + 1).
2045 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
2046 -- to have a base range of -128 .. 127, but the corresponding vector
2047 -- would have lengths in the range 0 .. 255. In this case we would need
2048 -- to use Count_Type'Base for intermediate values.
2050 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
2051 -- vector would have a maximum length of 10, but the index values lie
2052 -- outside the range of Count_Type (which is only 32 bits). In this
2053 -- case we would need to use Index_Type'Base for intermediate values.
2055 if Count_Type'Base'Last
>= Index_Type
'Pos (Index_Type
'Base'Last) then
2056 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
2058 return Count_Type (L - F + 1);
2067 (Target : in out Vector;
2068 Source : in out Vector)
2071 if Target'Address = Source'Address then
2075 if Target.Capacity < Source.Length then
2076 raise Capacity_Error -- ???
2077 with "Target capacity is less than Source length";
2080 if Target.Busy > 0 then
2081 raise Program_Error with
2082 "attempt to tamper with cursors (Target is busy)";
2085 if Source.Busy > 0 then
2086 raise Program_Error with
2087 "attempt to tamper with cursors (Source is busy)";
2090 -- Clear Target now, in case element assignment fails
2092 Target.Last := No_Index;
2094 Target.Elements (1 .. Source.Length) :=
2095 Source.Elements (1 .. Source.Length);
2097 Target.Last := Source.Last;
2098 Source.Last := No_Index;
2105 function Next (Position : Cursor) return Cursor is
2107 if Position.Container = null then
2109 elsif Position.Index < Position.Container.Last then
2110 return (Position.Container, Position.Index + 1);
2116 function Next (Object : Iterator; Position : Cursor) return Cursor is
2118 if Position.Container = null then
2120 elsif Position.Container /= Object.Container then
2121 raise Program_Error with
2122 "Position cursor of Next designates wrong vector";
2124 return Next (Position);
2128 procedure Next (Position : in out Cursor) is
2130 if Position.Container = null then
2132 elsif Position.Index < Position.Container.Last then
2133 Position.Index := Position.Index + 1;
2135 Position := No_Element;
2143 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2145 Insert (Container, Index_Type'First, New_Item);
2149 (Container : in out Vector;
2150 New_Item : Element_Type;
2151 Count : Count_Type := 1)
2164 procedure Previous (Position : in out Cursor) is
2166 if Position.Container = null then
2168 elsif Position.Index > Index_Type'First then
2169 Position.Index := Position.Index - 1;
2171 Position := No_Element;
2175 function Previous (Position : Cursor) return Cursor is
2177 if Position.Container = null then
2179 elsif Position.Index > Index_Type'First then
2180 return (Position.Container, Position.Index - 1);
2186 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2188 if Position.Container = null then
2190 elsif Position.Container /= Object.Container then
2191 raise Program_Error with
2192 "Position cursor of Previous designates wrong vector";
2194 return Previous (Position);
2202 procedure Query_Element
2203 (Container : Vector;
2205 Process : not null access procedure (Element : Element_Type))
2207 V : Vector renames Container'Unrestricted_Access.all;
2208 B : Natural renames V.Busy;
2209 L : Natural renames V.Lock;
2212 if Index > Container.Last then
2213 raise Constraint_Error with "Index is out of range";
2220 Process (V.Elements (To_Array_Index (Index)));
2232 procedure Query_Element
2234 Process : not null access procedure (Element : Element_Type))
2237 if Position.Container = null then
2238 raise Constraint_Error with "Position cursor has no element";
2240 Query_Element (Position.Container.all, Position.Index, Process);
2249 (Stream : not null access Root_Stream_Type'Class;
2250 Container : out Vector)
2252 Length : Count_Type'Base;
2253 Last : Index_Type'Base := No_Index;
2258 Count_Type'Base'Read
(Stream
, Length
);
2260 Reserve_Capacity
(Container
, Capacity
=> Length
);
2262 for Idx
in Count_Type
range 1 .. Length
loop
2264 Element_Type
'Read (Stream
, Container
.Elements
(Idx
));
2265 Container
.Last
:= Last
;
2270 (Stream
: not null access Root_Stream_Type
'Class;
2271 Position
: out Cursor
)
2274 raise Program_Error
with "attempt to stream vector cursor";
2278 (Stream
: not null access Root_Stream_Type
'Class;
2279 Item
: out Reference_Type
)
2282 raise Program_Error
with "attempt to stream reference";
2286 (Stream
: not null access Root_Stream_Type
'Class;
2287 Item
: out Constant_Reference_Type
)
2290 raise Program_Error
with "attempt to stream reference";
2298 (Container
: aliased in out Vector
;
2299 Position
: Cursor
) return Reference_Type
2302 if Position
.Container
= null then
2303 raise Constraint_Error
with "Position cursor has no element";
2306 if Position
.Container
/= Container
'Unrestricted_Access then
2307 raise Program_Error
with "Position cursor denotes wrong container";
2310 if Position
.Index
> Position
.Container
.Last
then
2311 raise Constraint_Error
with "Position cursor is out of range";
2315 A
: Elements_Array
renames Container
.Elements
;
2316 J
: constant Count_Type
:= To_Array_Index
(Position
.Index
);
2318 return (Element
=> A
(J
)'Access);
2323 (Container
: aliased in out Vector
;
2324 Index
: Index_Type
) return Reference_Type
2327 if Index
> Container
.Last
then
2328 raise Constraint_Error
with "Index is out of range";
2332 A
: Elements_Array
renames Container
.Elements
;
2333 J
: constant Count_Type
:= To_Array_Index
(Index
);
2335 return (Element
=> A
(J
)'Access);
2339 ---------------------
2340 -- Replace_Element --
2341 ---------------------
2343 procedure Replace_Element
2344 (Container
: in out Vector
;
2346 New_Item
: Element_Type
)
2349 if Index
> Container
.Last
then
2350 raise Constraint_Error
with "Index is out of range";
2351 elsif Container
.Lock
> 0 then
2352 raise Program_Error
with
2353 "attempt to tamper with elements (vector is locked)";
2355 Container
.Elements
(To_Array_Index
(Index
)) := New_Item
;
2357 end Replace_Element
;
2359 procedure Replace_Element
2360 (Container
: in out Vector
;
2362 New_Item
: Element_Type
)
2365 if Position
.Container
= null then
2366 raise Constraint_Error
with "Position cursor has no element";
2368 elsif Position
.Container
/= Container
'Unrestricted_Access then
2369 raise Program_Error
with "Position cursor denotes wrong container";
2371 elsif Position
.Index
> Container
.Last
then
2372 raise Constraint_Error
with "Position cursor is out of range";
2374 elsif Container
.Lock
> 0 then
2375 raise Program_Error
with
2376 "attempt to tamper with elements (vector is locked)";
2379 Container
.Elements
(To_Array_Index
(Position
.Index
)) := New_Item
;
2381 end Replace_Element
;
2383 ----------------------
2384 -- Reserve_Capacity --
2385 ----------------------
2387 procedure Reserve_Capacity
2388 (Container
: in out Vector
;
2389 Capacity
: Count_Type
)
2392 if Capacity
> Container
.Capacity
then
2393 raise Constraint_Error
with "Capacity is out of range";
2395 end Reserve_Capacity
;
2397 ----------------------
2398 -- Reverse_Elements --
2399 ----------------------
2401 procedure Reverse_Elements
(Container
: in out Vector
) is
2402 E
: Elements_Array
renames Container
.Elements
;
2407 if Container
.Length
<= 1 then
2411 -- The exception behavior for the vector container must match that for
2412 -- the list container, so we check for cursor tampering here (which will
2413 -- catch more things) instead of for element tampering (which will catch
2414 -- fewer things). It's true that the elements of this vector container
2415 -- could be safely moved around while (say) an iteration is taking place
2416 -- (iteration only increments the busy counter), and so technically
2417 -- all we would need here is a test for element tampering (indicated
2418 -- by the lock counter), that's simply an artifact of our array-based
2419 -- implementation. Logically Reverse_Elements requires a check for
2420 -- cursor tampering.
2422 if Container
.Busy
> 0 then
2423 raise Program_Error
with
2424 "attempt to tamper with cursors (vector is busy)";
2428 Jdx
:= Container
.Length
;
2429 while Idx
< Jdx
loop
2431 EI
: constant Element_Type
:= E
(Idx
);
2441 end Reverse_Elements
;
2447 function Reverse_Find
2448 (Container
: Vector
;
2449 Item
: Element_Type
;
2450 Position
: Cursor
:= No_Element
) return Cursor
2452 Last
: Index_Type
'Base;
2455 if Position
.Container
/= null
2456 and then Position
.Container
/= Container
'Unrestricted_Access
2458 raise Program_Error
with "Position cursor denotes wrong container";
2462 (if Position
.Container
= null or else Position
.Index
> Container
.Last
2464 else Position
.Index
);
2466 -- Per AI05-0022, the container implementation is required to detect
2467 -- element tampering by a generic actual subprogram.
2470 B
: Natural renames Container
'Unrestricted_Access.Busy
;
2471 L
: Natural renames Container
'Unrestricted_Access.Lock
;
2473 Result
: Index_Type
'Base;
2480 for Indx
in reverse Index_Type
'First .. Last
loop
2481 if Container
.Elements
(To_Array_Index
(Indx
)) = Item
then
2490 if Result
= No_Index
then
2493 return Cursor
'(Container'Unrestricted_Access, Result);
2503 ------------------------
2504 -- Reverse_Find_Index --
2505 ------------------------
2507 function Reverse_Find_Index
2508 (Container : Vector;
2509 Item : Element_Type;
2510 Index : Index_Type := Index_Type'Last) return Extended_Index
2512 B : Natural renames Container'Unrestricted_Access.Busy;
2513 L : Natural renames Container'Unrestricted_Access.Lock;
2515 Last : constant Index_Type'Base :=
2516 Index_Type'Min (Container.Last, Index);
2518 Result : Index_Type'Base;
2521 -- Per AI05-0022, the container implementation is required to detect
2522 -- element tampering by a generic actual subprogram.
2528 for Indx in reverse Index_Type'First .. Last loop
2529 if Container.Elements (To_Array_Index (Indx)) = Item then
2545 end Reverse_Find_Index;
2547 ---------------------
2548 -- Reverse_Iterate --
2549 ---------------------
2551 procedure Reverse_Iterate
2552 (Container : Vector;
2553 Process : not null access procedure (Position : Cursor))
2555 V : Vector renames Container'Unrestricted_Access.all;
2556 B : Natural renames V.Busy;
2562 for Indx in reverse Index_Type'First .. Container.Last loop
2563 Process (Cursor'(Container
'Unrestricted_Access, Indx
));
2572 end Reverse_Iterate
;
2578 procedure Set_Length
(Container
: in out Vector
; Length
: Count_Type
) is
2579 Count
: constant Count_Type
'Base := Container
.Length
- Length
;
2582 -- Set_Length allows the user to set the length explicitly, instead of
2583 -- implicitly as a side-effect of deletion or insertion. If the
2584 -- requested length is less than the current length, this is equivalent
2585 -- to deleting items from the back end of the vector. If the requested
2586 -- length is greater than the current length, then this is equivalent to
2587 -- inserting "space" (nonce items) at the end.
2590 Container
.Delete_Last
(Count
);
2591 elsif Container
.Last
>= Index_Type
'Last then
2592 raise Constraint_Error
with "vector is already at its maximum length";
2594 Container
.Insert_Space
(Container
.Last
+ 1, -Count
);
2602 procedure Swap
(Container
: in out Vector
; I
, J
: Index_Type
) is
2603 E
: Elements_Array
renames Container
.Elements
;
2606 if I
> Container
.Last
then
2607 raise Constraint_Error
with "I index is out of range";
2610 if J
> Container
.Last
then
2611 raise Constraint_Error
with "J index is out of range";
2618 if Container
.Lock
> 0 then
2619 raise Program_Error
with
2620 "attempt to tamper with elements (vector is locked)";
2624 EI_Copy
: constant Element_Type
:= E
(To_Array_Index
(I
));
2626 E
(To_Array_Index
(I
)) := E
(To_Array_Index
(J
));
2627 E
(To_Array_Index
(J
)) := EI_Copy
;
2631 procedure Swap
(Container
: in out Vector
; I
, J
: Cursor
) is
2633 if I
.Container
= null then
2634 raise Constraint_Error
with "I cursor has no element";
2637 if J
.Container
= null then
2638 raise Constraint_Error
with "J cursor has no element";
2641 if I
.Container
/= Container
'Unrestricted_Access then
2642 raise Program_Error
with "I cursor denotes wrong container";
2645 if J
.Container
/= Container
'Unrestricted_Access then
2646 raise Program_Error
with "J cursor denotes wrong container";
2649 Swap
(Container
, I
.Index
, J
.Index
);
2652 --------------------
2653 -- To_Array_Index --
2654 --------------------
2656 function To_Array_Index
(Index
: Index_Type
'Base) return Count_Type
'Base is
2657 Offset
: Count_Type
'Base;
2661 -- Index >= Index_Type'First
2662 -- hence we also know that
2663 -- Index - Index_Type'First >= 0
2665 -- The issue is that even though 0 is guaranteed to be a value in
2666 -- the type Index_Type'Base, there's no guarantee that the difference
2667 -- is a value in that type. To prevent overflow we use the wider
2668 -- of Count_Type'Base and Index_Type'Base to perform intermediate
2671 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2672 Offset := Count_Type'Base (Index - Index_Type'First);
2675 Offset := Count_Type'Base (Index) -
2676 Count_Type'Base (Index_Type'First);
2679 -- The array index subtype for all container element arrays
2680 -- always starts with 1.
2690 (Container : Vector;
2691 Index : Extended_Index) return Cursor
2694 if Index not in Index_Type'First .. Container.Last then
2698 return Cursor'(Container
'Unrestricted_Access, Index
);
2705 function To_Index
(Position
: Cursor
) return Extended_Index
is
2707 if Position
.Container
= null then
2711 if Position
.Index
<= Position
.Container
.Last
then
2712 return Position
.Index
;
2722 function To_Vector
(Length
: Count_Type
) return Vector
is
2723 Index
: Count_Type
'Base;
2724 Last
: Index_Type
'Base;
2728 return Empty_Vector
;
2731 -- We create a vector object with a capacity that matches the specified
2732 -- Length, but we do not allow the vector capacity (the length of the
2733 -- internal array) to exceed the number of values in Index_Type'Range
2734 -- (otherwise, there would be no way to refer to those components via an
2735 -- index). We must therefore check whether the specified Length would
2736 -- create a Last index value greater than Index_Type'Last.
2738 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2739 -- We perform a two-part test. First we determine whether the
2740 -- computed Last value lies in the base range of the type, and then
2741 -- determine whether it lies in the range of the index (sub)type.
2743 -- Last must satisfy this relation:
2744 -- First + Length - 1 <= Last
2745 -- We regroup terms:
2746 -- First - 1 <= Last - Length
2747 -- Which can rewrite as:
2748 -- No_Index <= Last - Length
2750 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
2751 raise Constraint_Error
with "Length is out of range";
2754 -- We now know that the computed value of Last is within the base
2755 -- range of the type, so it is safe to compute its value:
2757 Last
:= No_Index
+ Index_Type
'Base (Length
);
2759 -- Finally we test whether the value is within the range of the
2760 -- generic actual index subtype:
2762 if Last
> Index_Type
'Last then
2763 raise Constraint_Error
with "Length is out of range";
2766 elsif Index_Type
'First <= 0 then
2768 -- Here we can compute Last directly, in the normal way. We know that
2769 -- No_Index is less than 0, so there is no danger of overflow when
2770 -- adding the (positive) value of Length.
2772 Index
:= Count_Type
'Base (No_Index
) + Length
; -- Last
2774 if Index
> Count_Type
'Base (Index_Type
'Last) then
2775 raise Constraint_Error
with "Length is out of range";
2778 -- We know that the computed value (having type Count_Type) of Last
2779 -- is within the range of the generic actual index subtype, so it is
2780 -- safe to convert to Index_Type:
2782 Last
:= Index_Type
'Base (Index
);
2785 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2786 -- must test the length indirectly (by working backwards from the
2787 -- largest possible value of Last), in order to prevent overflow.
2789 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
2791 if Index
< Count_Type
'Base (No_Index
) then
2792 raise Constraint_Error
with "Length is out of range";
2795 -- We have determined that the value of Length would not create a
2796 -- Last index value outside of the range of Index_Type, so we can now
2797 -- safely compute its value.
2799 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
2802 return V
: Vector
(Capacity
=> Length
) do
2808 (New_Item
: Element_Type
;
2809 Length
: Count_Type
) return Vector
2811 Index
: Count_Type
'Base;
2812 Last
: Index_Type
'Base;
2816 return Empty_Vector
;
2819 -- We create a vector object with a capacity that matches the specified
2820 -- Length, but we do not allow the vector capacity (the length of the
2821 -- internal array) to exceed the number of values in Index_Type'Range
2822 -- (otherwise, there would be no way to refer to those components via an
2823 -- index). We must therefore check whether the specified Length would
2824 -- create a Last index value greater than Index_Type'Last.
2826 if Index_Type
'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2828 -- We perform a two-part test. First we determine whether the
2829 -- computed Last value lies in the base range of the type, and then
2830 -- determine whether it lies in the range of the index (sub)type.
2832 -- Last must satisfy this relation:
2833 -- First + Length - 1 <= Last
2834 -- We regroup terms:
2835 -- First - 1 <= Last - Length
2836 -- Which can rewrite as:
2837 -- No_Index <= Last - Length
2839 if Index_Type'Base'Last
- Index_Type
'Base (Length
) < No_Index
then
2840 raise Constraint_Error
with "Length is out of range";
2843 -- We now know that the computed value of Last is within the base
2844 -- range of the type, so it is safe to compute its value:
2846 Last
:= No_Index
+ Index_Type
'Base (Length
);
2848 -- Finally we test whether the value is within the range of the
2849 -- generic actual index subtype:
2851 if Last
> Index_Type
'Last then
2852 raise Constraint_Error
with "Length is out of range";
2855 elsif Index_Type
'First <= 0 then
2857 -- Here we can compute Last directly, in the normal way. We know that
2858 -- No_Index is less than 0, so there is no danger of overflow when
2859 -- adding the (positive) value of Length.
2861 Index
:= Count_Type
'Base (No_Index
) + Length
; -- same value as V.Last
2863 if Index
> Count_Type
'Base (Index_Type
'Last) then
2864 raise Constraint_Error
with "Length is out of range";
2867 -- We know that the computed value (having type Count_Type) of Last
2868 -- is within the range of the generic actual index subtype, so it is
2869 -- safe to convert to Index_Type:
2871 Last
:= Index_Type
'Base (Index
);
2874 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2875 -- must test the length indirectly (by working backwards from the
2876 -- largest possible value of Last), in order to prevent overflow.
2878 Index
:= Count_Type
'Base (Index_Type
'Last) - Length
; -- No_Index
2880 if Index
< Count_Type
'Base (No_Index
) then
2881 raise Constraint_Error
with "Length is out of range";
2884 -- We have determined that the value of Length would not create a
2885 -- Last index value outside of the range of Index_Type, so we can now
2886 -- safely compute its value.
2888 Last
:= Index_Type
'Base (Count_Type
'Base (No_Index
) + Length
);
2891 return V
: Vector
(Capacity
=> Length
) do
2892 V
.Elements
:= (others => New_Item
);
2897 --------------------
2898 -- Update_Element --
2899 --------------------
2901 procedure Update_Element
2902 (Container
: in out Vector
;
2904 Process
: not null access procedure (Element
: in out Element_Type
))
2906 B
: Natural renames Container
.Busy
;
2907 L
: Natural renames Container
.Lock
;
2910 if Index
> Container
.Last
then
2911 raise Constraint_Error
with "Index is out of range";
2918 Process
(Container
.Elements
(To_Array_Index
(Index
)));
2930 procedure Update_Element
2931 (Container
: in out Vector
;
2933 Process
: not null access procedure (Element
: in out Element_Type
))
2936 if Position
.Container
= null then
2937 raise Constraint_Error
with "Position cursor has no element";
2940 if Position
.Container
/= Container
'Unrestricted_Access then
2941 raise Program_Error
with "Position cursor denotes wrong container";
2944 Update_Element
(Container
, Position
.Index
, Process
);
2952 (Stream
: not null access Root_Stream_Type
'Class;
2958 N
:= Container
.Length
;
2959 Count_Type
'Base'Write (Stream, N);
2961 for J in 1 .. N loop
2962 Element_Type'Write (Stream, Container.Elements (J));
2967 (Stream : not null access Root_Stream_Type'Class;
2971 raise Program_Error with "attempt to stream vector cursor";
2975 (Stream : not null access Root_Stream_Type'Class;
2976 Item : Reference_Type)
2979 raise Program_Error with "attempt to stream reference";
2983 (Stream : not null access Root_Stream_Type'Class;
2984 Item : Constant_Reference_Type)
2987 raise Program_Error with "attempt to stream reference";
2990 end Ada.Containers.Bounded_Vectors;