File : a-cobove.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
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 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 with Ada.Containers.Generic_Array_Sort;
31
32 with System; use type System.Address;
33
34 package body Ada.Containers.Bounded_Vectors is
35
36 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
37 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
38 -- See comment in Ada.Containers.Helpers
39
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
43
44 function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base;
45
46 ---------
47 -- "&" --
48 ---------
49
50 function "&" (Left, Right : Vector) return Vector is
51 LN : constant Count_Type := Length (Left);
52 RN : constant Count_Type := Length (Right);
53 N : Count_Type'Base; -- length of result
54 J : Count_Type'Base; -- for computing intermediate index values
55 Last : Index_Type'Base; -- Last index of result
56
57 begin
58 -- We decide that the capacity of the result is the sum of the lengths
59 -- of the vector parameters. We could decide to make it larger, but we
60 -- have no basis for knowing how much larger, so we just allocate the
61 -- minimum amount of storage.
62
63 -- Here we handle the easy cases first, when one of the vector
64 -- parameters is empty. (We say "easy" because there's nothing to
65 -- compute, that can potentially overflow.)
66
67 if LN = 0 then
68 if RN = 0 then
69 return Empty_Vector;
70 end if;
71
72 return Vector'(Capacity => RN,
73 Elements => Right.Elements (1 .. RN),
74 Last => Right.Last,
75 others => <>);
76 end if;
77
78 if RN = 0 then
79 return Vector'(Capacity => LN,
80 Elements => Left.Elements (1 .. LN),
81 Last => Left.Last,
82 others => <>);
83 end if;
84
85 -- Neither of the vector parameters is empty, so must compute the length
86 -- of the result vector and its last index. (This is the harder case,
87 -- because our computations must avoid overflow.)
88
89 -- There are two constraints we need to satisfy. The first constraint is
90 -- that a container cannot have more than Count_Type'Last elements, so
91 -- we must check the sum of the combined lengths. Note that we cannot
92 -- simply add the lengths, because of the possibility of overflow.
93
94 if Checks and then LN > Count_Type'Last - RN then
95 raise Constraint_Error with "new length is out of range";
96 end if;
97
98 -- It is now safe to compute the length of the new vector, without fear
99 -- of overflow.
100
101 N := LN + RN;
102
103 -- The second constraint is that the new Last index value cannot
104 -- exceed Index_Type'Last. We use the wider of Index_Type'Base and
105 -- Count_Type'Base as the type for intermediate values.
106
107 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
108
109 -- We perform a two-part test. First we determine whether the
110 -- computed Last value lies in the base range of the type, and then
111 -- determine whether it lies in the range of the index (sub)type.
112
113 -- Last must satisfy this relation:
114 -- First + Length - 1 <= Last
115 -- We regroup terms:
116 -- First - 1 <= Last - Length
117 -- Which can rewrite as:
118 -- No_Index <= Last - Length
119
120 if Checks and then
121 Index_Type'Base'Last - Index_Type'Base (N) < No_Index
122 then
123 raise Constraint_Error with "new length is out of range";
124 end if;
125
126 -- We now know that the computed value of Last is within the base
127 -- range of the type, so it is safe to compute its value:
128
129 Last := No_Index + Index_Type'Base (N);
130
131 -- Finally we test whether the value is within the range of the
132 -- generic actual index subtype:
133
134 if Checks and then Last > Index_Type'Last then
135 raise Constraint_Error with "new length is out of range";
136 end if;
137
138 elsif Index_Type'First <= 0 then
139
140 -- Here we can compute Last directly, in the normal way. We know that
141 -- No_Index is less than 0, so there is no danger of overflow when
142 -- adding the (positive) value of length.
143
144 J := Count_Type'Base (No_Index) + N; -- Last
145
146 if Checks and then J > Count_Type'Base (Index_Type'Last) then
147 raise Constraint_Error with "new length is out of range";
148 end if;
149
150 -- We know that the computed value (having type Count_Type) of Last
151 -- is within the range of the generic actual index subtype, so it is
152 -- safe to convert to Index_Type:
153
154 Last := Index_Type'Base (J);
155
156 else
157 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
158 -- must test the length indirectly (by working backwards from the
159 -- largest possible value of Last), in order to prevent overflow.
160
161 J := Count_Type'Base (Index_Type'Last) - N; -- No_Index
162
163 if Checks and then J < Count_Type'Base (No_Index) then
164 raise Constraint_Error with "new length is out of range";
165 end if;
166
167 -- We have determined that the result length would not create a Last
168 -- index value outside of the range of Index_Type, so we can now
169 -- safely compute its value.
170
171 Last := Index_Type'Base (Count_Type'Base (No_Index) + N);
172 end if;
173
174 declare
175 LE : Elements_Array renames Left.Elements (1 .. LN);
176 RE : Elements_Array renames Right.Elements (1 .. RN);
177
178 begin
179 return Vector'(Capacity => N,
180 Elements => LE & RE,
181 Last => Last,
182 others => <>);
183 end;
184 end "&";
185
186 function "&" (Left : Vector; Right : Element_Type) return Vector is
187 LN : constant Count_Type := Length (Left);
188
189 begin
190 -- We decide that the capacity of the result is the sum of the lengths
191 -- of the parameters. We could decide to make it larger, but we have no
192 -- basis for knowing how much larger, so we just allocate the minimum
193 -- amount of storage.
194
195 -- We must compute the length of the result vector and its last index,
196 -- but in such a way that overflow is avoided. We must satisfy two
197 -- constraints: the new length cannot exceed Count_Type'Last, and the
198 -- new Last index cannot exceed Index_Type'Last.
199
200 if Checks and then LN = Count_Type'Last then
201 raise Constraint_Error with "new length is out of range";
202 end if;
203
204 if Checks and then Left.Last >= Index_Type'Last then
205 raise Constraint_Error with "new length is out of range";
206 end if;
207
208 return Vector'(Capacity => LN + 1,
209 Elements => Left.Elements (1 .. LN) & Right,
210 Last => Left.Last + 1,
211 others => <>);
212 end "&";
213
214 function "&" (Left : Element_Type; Right : Vector) return Vector is
215 RN : constant Count_Type := Length (Right);
216
217 begin
218 -- We decide that the capacity of the result is the sum of the lengths
219 -- of the parameters. We could decide to make it larger, but we have no
220 -- basis for knowing how much larger, so we just allocate the minimum
221 -- amount of storage.
222
223 -- We compute the length of the result vector and its last index, but in
224 -- such a way that overflow is avoided. We must satisfy two constraints:
225 -- the new length cannot exceed Count_Type'Last, and the new Last index
226 -- cannot exceed Index_Type'Last.
227
228 if Checks and then RN = Count_Type'Last then
229 raise Constraint_Error with "new length is out of range";
230 end if;
231
232 if Checks and then Right.Last >= Index_Type'Last then
233 raise Constraint_Error with "new length is out of range";
234 end if;
235
236 return Vector'(Capacity => 1 + RN,
237 Elements => Left & Right.Elements (1 .. RN),
238 Last => Right.Last + 1,
239 others => <>);
240 end "&";
241
242 function "&" (Left, Right : Element_Type) return Vector is
243 begin
244 -- We decide that the capacity of the result is the sum of the lengths
245 -- of the parameters. We could decide to make it larger, but we have no
246 -- basis for knowing how much larger, so we just allocate the minimum
247 -- amount of storage.
248
249 -- We must compute the length of the result vector and its last index,
250 -- but in such a way that overflow is avoided. We must satisfy two
251 -- constraints: the new length cannot exceed Count_Type'Last (here, we
252 -- know that that condition is satisfied), and the new Last index cannot
253 -- exceed Index_Type'Last.
254
255 if Checks and then Index_Type'First >= Index_Type'Last then
256 raise Constraint_Error with "new length is out of range";
257 end if;
258
259 return Vector'(Capacity => 2,
260 Elements => (Left, Right),
261 Last => Index_Type'First + 1,
262 others => <>);
263 end "&";
264
265 ---------
266 -- "=" --
267 ---------
268
269 overriding function "=" (Left, Right : Vector) return Boolean is
270 begin
271 if Left.Last /= Right.Last then
272 return False;
273 end if;
274
275 if Left.Length = 0 then
276 return True;
277 end if;
278
279 declare
280 -- Per AI05-0022, the container implementation is required to detect
281 -- element tampering by a generic actual subprogram.
282
283 Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
284 Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
285 begin
286 for J in Count_Type range 1 .. Left.Length loop
287 if Left.Elements (J) /= Right.Elements (J) then
288 return False;
289 end if;
290 end loop;
291 end;
292
293 return True;
294 end "=";
295
296 ------------
297 -- Assign --
298 ------------
299
300 procedure Assign (Target : in out Vector; Source : Vector) is
301 begin
302 if Target'Address = Source'Address then
303 return;
304 end if;
305
306 if Checks and then Target.Capacity < Source.Length then
307 raise Capacity_Error -- ???
308 with "Target capacity is less than Source length";
309 end if;
310
311 Target.Clear;
312
313 Target.Elements (1 .. Source.Length) :=
314 Source.Elements (1 .. Source.Length);
315
316 Target.Last := Source.Last;
317 end Assign;
318
319 ------------
320 -- Append --
321 ------------
322
323 procedure Append (Container : in out Vector; New_Item : Vector) is
324 begin
325 if New_Item.Is_Empty then
326 return;
327 end if;
328
329 if Checks and then Container.Last >= Index_Type'Last then
330 raise Constraint_Error with "vector is already at its maximum length";
331 end if;
332
333 Container.Insert (Container.Last + 1, New_Item);
334 end Append;
335
336 procedure Append
337 (Container : in out Vector;
338 New_Item : Element_Type;
339 Count : Count_Type := 1)
340 is
341 begin
342 if Count = 0 then
343 return;
344 end if;
345
346 if Checks and then Container.Last >= Index_Type'Last then
347 raise Constraint_Error with "vector is already at its maximum length";
348 end if;
349
350 Container.Insert (Container.Last + 1, New_Item, Count);
351 end Append;
352
353 --------------
354 -- Capacity --
355 --------------
356
357 function Capacity (Container : Vector) return Count_Type is
358 begin
359 return Container.Elements'Length;
360 end Capacity;
361
362 -----------
363 -- Clear --
364 -----------
365
366 procedure Clear (Container : in out Vector) is
367 begin
368 TC_Check (Container.TC);
369
370 Container.Last := No_Index;
371 end Clear;
372
373 ------------------------
374 -- Constant_Reference --
375 ------------------------
376
377 function Constant_Reference
378 (Container : aliased Vector;
379 Position : Cursor) return Constant_Reference_Type
380 is
381 begin
382 if Checks and then Position.Container = null then
383 raise Constraint_Error with "Position cursor has no element";
384 end if;
385
386 if Checks and then Position.Container /= Container'Unrestricted_Access
387 then
388 raise Program_Error with "Position cursor denotes wrong container";
389 end if;
390
391 if Checks and then Position.Index > Position.Container.Last then
392 raise Constraint_Error with "Position cursor is out of range";
393 end if;
394
395 declare
396 A : Elements_Array renames Container.Elements;
397 J : constant Count_Type := To_Array_Index (Position.Index);
398 TC : constant Tamper_Counts_Access :=
399 Container.TC'Unrestricted_Access;
400 begin
401 return R : constant Constant_Reference_Type :=
402 (Element => A (J)'Access,
403 Control => (Controlled with TC))
404 do
405 Lock (TC.all);
406 end return;
407 end;
408 end Constant_Reference;
409
410 function Constant_Reference
411 (Container : aliased Vector;
412 Index : Index_Type) return Constant_Reference_Type
413 is
414 begin
415 if Checks and then Index > Container.Last then
416 raise Constraint_Error with "Index is out of range";
417 end if;
418
419 declare
420 A : Elements_Array renames Container.Elements;
421 J : constant Count_Type := To_Array_Index (Index);
422 TC : constant Tamper_Counts_Access :=
423 Container.TC'Unrestricted_Access;
424 begin
425 return R : constant Constant_Reference_Type :=
426 (Element => A (J)'Access,
427 Control => (Controlled with TC))
428 do
429 Lock (TC.all);
430 end return;
431 end;
432 end Constant_Reference;
433
434 --------------
435 -- Contains --
436 --------------
437
438 function Contains
439 (Container : Vector;
440 Item : Element_Type) return Boolean
441 is
442 begin
443 return Find_Index (Container, Item) /= No_Index;
444 end Contains;
445
446 ----------
447 -- Copy --
448 ----------
449
450 function Copy
451 (Source : Vector;
452 Capacity : Count_Type := 0) return Vector
453 is
454 C : Count_Type;
455
456 begin
457 if Capacity = 0 then
458 C := Source.Length;
459
460 elsif Capacity >= Source.Length then
461 C := Capacity;
462
463 elsif Checks then
464 raise Capacity_Error
465 with "Requested capacity is less than Source length";
466 end if;
467
468 return Target : Vector (C) do
469 Target.Elements (1 .. Source.Length) :=
470 Source.Elements (1 .. Source.Length);
471
472 Target.Last := Source.Last;
473 end return;
474 end Copy;
475
476 ------------
477 -- Delete --
478 ------------
479
480 procedure Delete
481 (Container : in out Vector;
482 Index : Extended_Index;
483 Count : Count_Type := 1)
484 is
485 Old_Last : constant Index_Type'Base := Container.Last;
486 Old_Len : constant Count_Type := Container.Length;
487 New_Last : Index_Type'Base;
488 Count2 : Count_Type'Base; -- count of items from Index to Old_Last
489 Off : Count_Type'Base; -- Index expressed as offset from IT'First
490
491 begin
492 -- Delete removes items from the vector, the number of which is the
493 -- minimum of the specified Count and the items (if any) that exist from
494 -- Index to Container.Last. There are no constraints on the specified
495 -- value of Count (it can be larger than what's available at this
496 -- position in the vector, for example), but there are constraints on
497 -- the allowed values of the Index.
498
499 -- As a precondition on the generic actual Index_Type, the base type
500 -- must include Index_Type'Pred (Index_Type'First); this is the value
501 -- that Container.Last assumes when the vector is empty. However, we do
502 -- not allow that as the value for Index when specifying which items
503 -- should be deleted, so we must manually check. (That the user is
504 -- allowed to specify the value at all here is a consequence of the
505 -- declaration of the Extended_Index subtype, which includes the values
506 -- in the base range that immediately precede and immediately follow the
507 -- values in the Index_Type.)
508
509 if Checks and then Index < Index_Type'First then
510 raise Constraint_Error with "Index is out of range (too small)";
511 end if;
512
513 -- We do allow a value greater than Container.Last to be specified as
514 -- the Index, but only if it's immediately greater. This allows the
515 -- corner case of deleting no items from the back end of the vector to
516 -- be treated as a no-op. (It is assumed that specifying an index value
517 -- greater than Last + 1 indicates some deeper flaw in the caller's
518 -- algorithm, so that case is treated as a proper error.)
519
520 if Index > Old_Last then
521 if Checks and then Index > Old_Last + 1 then
522 raise Constraint_Error with "Index is out of range (too large)";
523 end if;
524
525 return;
526 end if;
527
528 -- Here and elsewhere we treat deleting 0 items from the container as a
529 -- no-op, even when the container is busy, so we simply return.
530
531 if Count = 0 then
532 return;
533 end if;
534
535 -- The tampering bits exist to prevent an item from being deleted (or
536 -- otherwise harmfully manipulated) while it is being visited. Query,
537 -- Update, and Iterate increment the busy count on entry, and decrement
538 -- the count on exit. Delete checks the count to determine whether it is
539 -- being called while the associated callback procedure is executing.
540
541 TC_Check (Container.TC);
542
543 -- We first calculate what's available for deletion starting at
544 -- Index. Here and elsewhere we use the wider of Index_Type'Base and
545 -- Count_Type'Base as the type for intermediate values. (See function
546 -- Length for more information.)
547
548 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
549 Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1;
550 else
551 Count2 := Count_Type'Base (Old_Last - Index + 1);
552 end if;
553
554 -- If more elements are requested (Count) for deletion than are
555 -- available (Count2) for deletion beginning at Index, then everything
556 -- from Index is deleted. There are no elements to slide down, and so
557 -- all we need to do is set the value of Container.Last.
558
559 if Count >= Count2 then
560 Container.Last := Index - 1;
561 return;
562 end if;
563
564 -- There are some elements aren't being deleted (the requested count was
565 -- less than the available count), so we must slide them down to
566 -- Index. We first calculate the index values of the respective array
567 -- slices, using the wider of Index_Type'Base and Count_Type'Base as the
568 -- type for intermediate calculations.
569
570 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
571 Off := Count_Type'Base (Index - Index_Type'First);
572 New_Last := Old_Last - Index_Type'Base (Count);
573 else
574 Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First);
575 New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count);
576 end if;
577
578 -- The array index values for each slice have already been determined,
579 -- so we just slide down to Index the elements that weren't deleted.
580
581 declare
582 EA : Elements_Array renames Container.Elements;
583 Idx : constant Count_Type := EA'First + Off;
584 begin
585 EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len);
586 Container.Last := New_Last;
587 end;
588 end Delete;
589
590 procedure Delete
591 (Container : in out Vector;
592 Position : in out Cursor;
593 Count : Count_Type := 1)
594 is
595 pragma Warnings (Off, Position);
596
597 begin
598 if Checks and then Position.Container = null then
599 raise Constraint_Error with "Position cursor has no element";
600 end if;
601
602 if Checks and then Position.Container /= Container'Unrestricted_Access
603 then
604 raise Program_Error with "Position cursor denotes wrong container";
605 end if;
606
607 if Checks and then Position.Index > Container.Last then
608 raise Program_Error with "Position index is out of range";
609 end if;
610
611 Delete (Container, Position.Index, Count);
612 Position := No_Element;
613 end Delete;
614
615 ------------------
616 -- Delete_First --
617 ------------------
618
619 procedure Delete_First
620 (Container : in out Vector;
621 Count : Count_Type := 1)
622 is
623 begin
624 if Count = 0 then
625 return;
626
627 elsif Count >= Length (Container) then
628 Clear (Container);
629 return;
630
631 else
632 Delete (Container, Index_Type'First, Count);
633 end if;
634 end Delete_First;
635
636 -----------------
637 -- Delete_Last --
638 -----------------
639
640 procedure Delete_Last
641 (Container : in out Vector;
642 Count : Count_Type := 1)
643 is
644 begin
645 -- It is not permitted to delete items while the container is busy (for
646 -- example, we're in the middle of a passive iteration). However, we
647 -- always treat deleting 0 items as a no-op, even when we're busy, so we
648 -- simply return without checking.
649
650 if Count = 0 then
651 return;
652 end if;
653
654 -- The tampering bits exist to prevent an item from being deleted (or
655 -- otherwise harmfully manipulated) while it is being visited. Query,
656 -- Update, and Iterate increment the busy count on entry, and decrement
657 -- the count on exit. Delete_Last checks the count to determine whether
658 -- it is being called while the associated callback procedure is
659 -- executing.
660
661 TC_Check (Container.TC);
662
663 -- There is no restriction on how large Count can be when deleting
664 -- items. If it is equal or greater than the current length, then this
665 -- is equivalent to clearing the vector. (In particular, there's no need
666 -- for us to actually calculate the new value for Last.)
667
668 -- If the requested count is less than the current length, then we must
669 -- calculate the new value for Last. For the type we use the widest of
670 -- Index_Type'Base and Count_Type'Base for the intermediate values of
671 -- our calculation. (See the comments in Length for more information.)
672
673 if Count >= Container.Length then
674 Container.Last := No_Index;
675
676 elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
677 Container.Last := Container.Last - Index_Type'Base (Count);
678
679 else
680 Container.Last :=
681 Index_Type'Base (Count_Type'Base (Container.Last) - Count);
682 end if;
683 end Delete_Last;
684
685 -------------
686 -- Element --
687 -------------
688
689 function Element
690 (Container : Vector;
691 Index : Index_Type) return Element_Type
692 is
693 begin
694 if Checks and then Index > Container.Last then
695 raise Constraint_Error with "Index is out of range";
696 else
697 return Container.Elements (To_Array_Index (Index));
698 end if;
699 end Element;
700
701 function Element (Position : Cursor) return Element_Type is
702 begin
703 if Checks and then Position.Container = null then
704 raise Constraint_Error with "Position cursor has no element";
705 else
706 return Position.Container.Element (Position.Index);
707 end if;
708 end Element;
709
710 --------------
711 -- Finalize --
712 --------------
713
714 procedure Finalize (Object : in out Iterator) is
715 begin
716 Unbusy (Object.Container.TC);
717 end Finalize;
718
719 ----------
720 -- Find --
721 ----------
722
723 function Find
724 (Container : Vector;
725 Item : Element_Type;
726 Position : Cursor := No_Element) return Cursor
727 is
728 begin
729 if Position.Container /= null then
730 if Checks and then Position.Container /= Container'Unrestricted_Access
731 then
732 raise Program_Error with "Position cursor denotes wrong container";
733 end if;
734
735 if Checks and then Position.Index > Container.Last then
736 raise Program_Error with "Position index is out of range";
737 end if;
738 end if;
739
740 -- Per AI05-0022, the container implementation is required to detect
741 -- element tampering by a generic actual subprogram.
742
743 declare
744 Lock : With_Lock (Container.TC'Unrestricted_Access);
745 begin
746 for J in Position.Index .. Container.Last loop
747 if Container.Elements (To_Array_Index (J)) = Item then
748 return Cursor'(Container'Unrestricted_Access, J);
749 end if;
750 end loop;
751
752 return No_Element;
753 end;
754 end Find;
755
756 ----------------
757 -- Find_Index --
758 ----------------
759
760 function Find_Index
761 (Container : Vector;
762 Item : Element_Type;
763 Index : Index_Type := Index_Type'First) return Extended_Index
764 is
765 -- Per AI05-0022, the container implementation is required to detect
766 -- element tampering by a generic actual subprogram.
767
768 Lock : With_Lock (Container.TC'Unrestricted_Access);
769 begin
770 for Indx in Index .. Container.Last loop
771 if Container.Elements (To_Array_Index (Indx)) = Item then
772 return Indx;
773 end if;
774 end loop;
775
776 return No_Index;
777 end Find_Index;
778
779 -----------
780 -- First --
781 -----------
782
783 function First (Container : Vector) return Cursor is
784 begin
785 if Is_Empty (Container) then
786 return No_Element;
787 else
788 return (Container'Unrestricted_Access, Index_Type'First);
789 end if;
790 end First;
791
792 function First (Object : Iterator) return Cursor is
793 begin
794 -- The value of the iterator object's Index component influences the
795 -- behavior of the First (and Last) selector function.
796
797 -- When the Index component is No_Index, this means the iterator
798 -- object was constructed without a start expression, in which case the
799 -- (forward) iteration starts from the (logical) beginning of the entire
800 -- sequence of items (corresponding to Container.First, for a forward
801 -- iterator).
802
803 -- Otherwise, this is iteration over a partial sequence of items.
804 -- When the Index component isn't No_Index, the iterator object was
805 -- constructed with a start expression, that specifies the position
806 -- from which the (forward) partial iteration begins.
807
808 if Object.Index = No_Index then
809 return First (Object.Container.all);
810 else
811 return Cursor'(Object.Container, Object.Index);
812 end if;
813 end First;
814
815 -------------------
816 -- First_Element --
817 -------------------
818
819 function First_Element (Container : Vector) return Element_Type is
820 begin
821 if Checks and then Container.Last = No_Index then
822 raise Constraint_Error with "Container is empty";
823 end if;
824
825 return Container.Elements (To_Array_Index (Index_Type'First));
826 end First_Element;
827
828 -----------------
829 -- First_Index --
830 -----------------
831
832 function First_Index (Container : Vector) return Index_Type is
833 pragma Unreferenced (Container);
834 begin
835 return Index_Type'First;
836 end First_Index;
837
838 ---------------------
839 -- Generic_Sorting --
840 ---------------------
841
842 package body Generic_Sorting is
843
844 ---------------
845 -- Is_Sorted --
846 ---------------
847
848 function Is_Sorted (Container : Vector) return Boolean is
849 begin
850 if Container.Last <= Index_Type'First then
851 return True;
852 end if;
853
854 -- Per AI05-0022, the container implementation is required to detect
855 -- element tampering by a generic actual subprogram.
856
857 declare
858 Lock : With_Lock (Container.TC'Unrestricted_Access);
859 EA : Elements_Array renames Container.Elements;
860 begin
861 for J in 1 .. Container.Length - 1 loop
862 if EA (J + 1) < EA (J) then
863 return False;
864 end if;
865 end loop;
866
867 return True;
868 end;
869 end Is_Sorted;
870
871 -----------
872 -- Merge --
873 -----------
874
875 procedure Merge (Target, Source : in out Vector) is
876 I, J : Count_Type;
877
878 begin
879 -- The semantics of Merge changed slightly per AI05-0021. It was
880 -- originally the case that if Target and Source denoted the same
881 -- container object, then the GNAT implementation of Merge did
882 -- nothing. However, it was argued that RM05 did not precisely
883 -- specify the semantics for this corner case. The decision of the
884 -- ARG was that if Target and Source denote the same non-empty
885 -- container object, then Program_Error is raised.
886
887 if Source.Is_Empty then
888 return;
889 end if;
890
891 if Checks and then Target'Address = Source'Address then
892 raise Program_Error with
893 "Target and Source denote same non-empty container";
894 end if;
895
896 if Target.Is_Empty then
897 Move (Target => Target, Source => Source);
898 return;
899 end if;
900
901 TC_Check (Source.TC);
902
903 I := Target.Length;
904 Target.Set_Length (I + Source.Length);
905
906 -- Per AI05-0022, the container implementation is required to detect
907 -- element tampering by a generic actual subprogram.
908
909 declare
910 TA : Elements_Array renames Target.Elements;
911 SA : Elements_Array renames Source.Elements;
912
913 Lock_Target : With_Lock (Target.TC'Unchecked_Access);
914 Lock_Source : With_Lock (Source.TC'Unchecked_Access);
915 begin
916 J := Target.Length;
917 while not Source.Is_Empty loop
918 pragma Assert (Source.Length <= 1
919 or else not (SA (Source.Length) < SA (Source.Length - 1)));
920
921 if I = 0 then
922 TA (1 .. J) := SA (1 .. Source.Length);
923 Source.Last := No_Index;
924 exit;
925 end if;
926
927 pragma Assert (I <= 1
928 or else not (TA (I) < TA (I - 1)));
929
930 if SA (Source.Length) < TA (I) then
931 TA (J) := TA (I);
932 I := I - 1;
933
934 else
935 TA (J) := SA (Source.Length);
936 Source.Last := Source.Last - 1;
937 end if;
938
939 J := J - 1;
940 end loop;
941 end;
942 end Merge;
943
944 ----------
945 -- Sort --
946 ----------
947
948 procedure Sort (Container : in out Vector) is
949 procedure Sort is
950 new Generic_Array_Sort
951 (Index_Type => Count_Type,
952 Element_Type => Element_Type,
953 Array_Type => Elements_Array,
954 "<" => "<");
955
956 begin
957 if Container.Last <= Index_Type'First then
958 return;
959 end if;
960
961 -- The exception behavior for the vector container must match that
962 -- for the list container, so we check for cursor tampering here
963 -- (which will catch more things) instead of for element tampering
964 -- (which will catch fewer things). It's true that the elements of
965 -- this vector container could be safely moved around while (say) an
966 -- iteration is taking place (iteration only increments the busy
967 -- counter), and so technically all we would need here is a test for
968 -- element tampering (indicated by the lock counter), that's simply
969 -- an artifact of our array-based implementation. Logically Sort
970 -- requires a check for cursor tampering.
971
972 TC_Check (Container.TC);
973
974 -- Per AI05-0022, the container implementation is required to detect
975 -- element tampering by a generic actual subprogram.
976
977 declare
978 Lock : With_Lock (Container.TC'Unchecked_Access);
979 begin
980 Sort (Container.Elements (1 .. Container.Length));
981 end;
982 end Sort;
983
984 end Generic_Sorting;
985
986 ------------------------
987 -- Get_Element_Access --
988 ------------------------
989
990 function Get_Element_Access
991 (Position : Cursor) return not null Element_Access is
992 begin
993 return Position.Container.Elements
994 (To_Array_Index (Position.Index))'Access;
995 end Get_Element_Access;
996
997 -----------------
998 -- Has_Element --
999 -----------------
1000
1001 function Has_Element (Position : Cursor) return Boolean is
1002 begin
1003 if Position.Container = null then
1004 return False;
1005 end if;
1006
1007 return Position.Index <= Position.Container.Last;
1008 end Has_Element;
1009
1010 ------------
1011 -- Insert --
1012 ------------
1013
1014 procedure Insert
1015 (Container : in out Vector;
1016 Before : Extended_Index;
1017 New_Item : Element_Type;
1018 Count : Count_Type := 1)
1019 is
1020 EA : Elements_Array renames Container.Elements;
1021 Old_Length : constant Count_Type := Container.Length;
1022
1023 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1024 New_Length : Count_Type'Base; -- sum of current length and Count
1025
1026 Index : Index_Type'Base; -- scratch for intermediate values
1027 J : Count_Type'Base; -- scratch
1028
1029 begin
1030 -- As a precondition on the generic actual Index_Type, the base type
1031 -- must include Index_Type'Pred (Index_Type'First); this is the value
1032 -- that Container.Last assumes when the vector is empty. However, we do
1033 -- not allow that as the value for Index when specifying where the new
1034 -- items should be inserted, so we must manually check. (That the user
1035 -- is allowed to specify the value at all here is a consequence of the
1036 -- declaration of the Extended_Index subtype, which includes the values
1037 -- in the base range that immediately precede and immediately follow the
1038 -- values in the Index_Type.)
1039
1040 if Checks and then Before < Index_Type'First then
1041 raise Constraint_Error with
1042 "Before index is out of range (too small)";
1043 end if;
1044
1045 -- We do allow a value greater than Container.Last to be specified as
1046 -- the Index, but only if it's immediately greater. This allows for the
1047 -- case of appending items to the back end of the vector. (It is assumed
1048 -- that specifying an index value greater than Last + 1 indicates some
1049 -- deeper flaw in the caller's algorithm, so that case is treated as a
1050 -- proper error.)
1051
1052 if Checks and then Before > Container.Last
1053 and then Before > Container.Last + 1
1054 then
1055 raise Constraint_Error with
1056 "Before index is out of range (too large)";
1057 end if;
1058
1059 -- We treat inserting 0 items into the container as a no-op, even when
1060 -- the container is busy, so we simply return.
1061
1062 if Count = 0 then
1063 return;
1064 end if;
1065
1066 -- There are two constraints we need to satisfy. The first constraint is
1067 -- that a container cannot have more than Count_Type'Last elements, so
1068 -- we must check the sum of the current length and the insertion
1069 -- count. Note that we cannot simply add these values, because of the
1070 -- possibility of overflow.
1071
1072 if Checks and then Old_Length > Count_Type'Last - Count then
1073 raise Constraint_Error with "Count is out of range";
1074 end if;
1075
1076 -- It is now safe compute the length of the new vector, without fear of
1077 -- overflow.
1078
1079 New_Length := Old_Length + Count;
1080
1081 -- The second constraint is that the new Last index value cannot exceed
1082 -- Index_Type'Last. In each branch below, we calculate the maximum
1083 -- length (computed from the range of values in Index_Type), and then
1084 -- compare the new length to the maximum length. If the new length is
1085 -- acceptable, then we compute the new last index from that.
1086
1087 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1088
1089 -- We have to handle the case when there might be more values in the
1090 -- range of Index_Type than in the range of Count_Type.
1091
1092 if Index_Type'First <= 0 then
1093
1094 -- We know that No_Index (the same as Index_Type'First - 1) is
1095 -- less than 0, so it is safe to compute the following sum without
1096 -- fear of overflow.
1097
1098 Index := No_Index + Index_Type'Base (Count_Type'Last);
1099
1100 if Index <= Index_Type'Last then
1101
1102 -- We have determined that range of Index_Type has at least as
1103 -- many values as in Count_Type, so Count_Type'Last is the
1104 -- maximum number of items that are allowed.
1105
1106 Max_Length := Count_Type'Last;
1107
1108 else
1109 -- The range of Index_Type has fewer values than in Count_Type,
1110 -- so the maximum number of items is computed from the range of
1111 -- the Index_Type.
1112
1113 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1114 end if;
1115
1116 else
1117 -- No_Index is equal or greater than 0, so we can safely compute
1118 -- the difference without fear of overflow (which we would have to
1119 -- worry about if No_Index were less than 0, but that case is
1120 -- handled above).
1121
1122 if Index_Type'Last - No_Index >=
1123 Count_Type'Pos (Count_Type'Last)
1124 then
1125 -- We have determined that range of Index_Type has at least as
1126 -- many values as in Count_Type, so Count_Type'Last is the
1127 -- maximum number of items that are allowed.
1128
1129 Max_Length := Count_Type'Last;
1130
1131 else
1132 -- The range of Index_Type has fewer values than in Count_Type,
1133 -- so the maximum number of items is computed from the range of
1134 -- the Index_Type.
1135
1136 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1137 end if;
1138 end if;
1139
1140 elsif Index_Type'First <= 0 then
1141
1142 -- We know that No_Index (the same as Index_Type'First - 1) is less
1143 -- than 0, so it is safe to compute the following sum without fear of
1144 -- overflow.
1145
1146 J := Count_Type'Base (No_Index) + Count_Type'Last;
1147
1148 if J <= Count_Type'Base (Index_Type'Last) then
1149
1150 -- We have determined that range of Index_Type has at least as
1151 -- many values as in Count_Type, so Count_Type'Last is the maximum
1152 -- number of items that are allowed.
1153
1154 Max_Length := Count_Type'Last;
1155
1156 else
1157 -- The range of Index_Type has fewer values than Count_Type does,
1158 -- so the maximum number of items is computed from the range of
1159 -- the Index_Type.
1160
1161 Max_Length :=
1162 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1163 end if;
1164
1165 else
1166 -- No_Index is equal or greater than 0, so we can safely compute the
1167 -- difference without fear of overflow (which we would have to worry
1168 -- about if No_Index were less than 0, but that case is handled
1169 -- above).
1170
1171 Max_Length :=
1172 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1173 end if;
1174
1175 -- We have just computed the maximum length (number of items). We must
1176 -- now compare the requested length to the maximum length, as we do not
1177 -- allow a vector expand beyond the maximum (because that would create
1178 -- an internal array with a last index value greater than
1179 -- Index_Type'Last, with no way to index those elements).
1180
1181 if Checks and then New_Length > Max_Length then
1182 raise Constraint_Error with "Count is out of range";
1183 end if;
1184
1185 -- The tampering bits exist to prevent an item from being harmfully
1186 -- manipulated while it is being visited. Query, Update, and Iterate
1187 -- increment the busy count on entry, and decrement the count on
1188 -- exit. Insert checks the count to determine whether it is being called
1189 -- while the associated callback procedure is executing.
1190
1191 TC_Check (Container.TC);
1192
1193 if Checks and then New_Length > Container.Capacity then
1194 raise Capacity_Error with "New length is larger than capacity";
1195 end if;
1196
1197 J := To_Array_Index (Before);
1198
1199 if Before > Container.Last then
1200
1201 -- The new items are being appended to the vector, so no
1202 -- sliding of existing elements is required.
1203
1204 EA (J .. New_Length) := (others => New_Item);
1205
1206 else
1207 -- The new items are being inserted before some existing
1208 -- elements, so we must slide the existing elements up to their
1209 -- new home.
1210
1211 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1212 EA (J .. J + Count - 1) := (others => New_Item);
1213 end if;
1214
1215 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1216 Container.Last := No_Index + Index_Type'Base (New_Length);
1217
1218 else
1219 Container.Last :=
1220 Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1221 end if;
1222 end Insert;
1223
1224 procedure Insert
1225 (Container : in out Vector;
1226 Before : Extended_Index;
1227 New_Item : Vector)
1228 is
1229 N : constant Count_Type := Length (New_Item);
1230 B : Count_Type; -- index Before converted to Count_Type
1231
1232 begin
1233 -- Use Insert_Space to create the "hole" (the destination slice) into
1234 -- which we copy the source items.
1235
1236 Insert_Space (Container, Before, Count => N);
1237
1238 if N = 0 then
1239 -- There's nothing else to do here (vetting of parameters was
1240 -- performed already in Insert_Space), so we simply return.
1241
1242 return;
1243 end if;
1244
1245 B := To_Array_Index (Before);
1246
1247 if Container'Address /= New_Item'Address then
1248 -- This is the simple case. New_Item denotes an object different
1249 -- from Container, so there's nothing special we need to do to copy
1250 -- the source items to their destination, because all of the source
1251 -- items are contiguous.
1252
1253 Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N);
1254 return;
1255 end if;
1256
1257 -- We refer to array index value Before + N - 1 as J. This is the last
1258 -- index value of the destination slice.
1259
1260 -- New_Item denotes the same object as Container, so an insertion has
1261 -- potentially split the source items. The destination is always the
1262 -- range [Before, J], but the source is [Index_Type'First, Before) and
1263 -- (J, Container.Last]. We perform the copy in two steps, using each of
1264 -- the two slices of the source items.
1265
1266 declare
1267 subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1;
1268
1269 Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
1270
1271 begin
1272 -- We first copy the source items that precede the space we
1273 -- inserted. (If Before equals Index_Type'First, then this first
1274 -- source slice will be empty, which is harmless.)
1275
1276 Container.Elements (B .. B + Src'Length - 1) := Src;
1277 end;
1278
1279 declare
1280 subtype Src_Index_Subtype is Count_Type'Base range
1281 B + N .. Container.Length;
1282
1283 Src : Elements_Array renames Container.Elements (Src_Index_Subtype);
1284
1285 begin
1286 -- We next copy the source items that follow the space we inserted.
1287
1288 Container.Elements (B + N - Src'Length .. B + N - 1) := Src;
1289 end;
1290 end Insert;
1291
1292 procedure Insert
1293 (Container : in out Vector;
1294 Before : Cursor;
1295 New_Item : Vector)
1296 is
1297 Index : Index_Type'Base;
1298
1299 begin
1300 if Checks and then Before.Container /= null
1301 and then Before.Container /= Container'Unchecked_Access
1302 then
1303 raise Program_Error with "Before cursor denotes wrong container";
1304 end if;
1305
1306 if Is_Empty (New_Item) then
1307 return;
1308 end if;
1309
1310 if Before.Container = null
1311 or else Before.Index > Container.Last
1312 then
1313 if Checks and then Container.Last = Index_Type'Last then
1314 raise Constraint_Error with
1315 "vector is already at its maximum length";
1316 end if;
1317
1318 Index := Container.Last + 1;
1319
1320 else
1321 Index := Before.Index;
1322 end if;
1323
1324 Insert (Container, Index, New_Item);
1325 end Insert;
1326
1327 procedure Insert
1328 (Container : in out Vector;
1329 Before : Cursor;
1330 New_Item : Vector;
1331 Position : out Cursor)
1332 is
1333 Index : Index_Type'Base;
1334
1335 begin
1336 if Checks and then Before.Container /= null
1337 and then Before.Container /= Container'Unchecked_Access
1338 then
1339 raise Program_Error with "Before cursor denotes wrong container";
1340 end if;
1341
1342 if Is_Empty (New_Item) then
1343 if Before.Container = null
1344 or else Before.Index > Container.Last
1345 then
1346 Position := No_Element;
1347 else
1348 Position := (Container'Unchecked_Access, Before.Index);
1349 end if;
1350
1351 return;
1352 end if;
1353
1354 if Before.Container = null
1355 or else Before.Index > Container.Last
1356 then
1357 if Checks and then Container.Last = Index_Type'Last then
1358 raise Constraint_Error with
1359 "vector is already at its maximum length";
1360 end if;
1361
1362 Index := Container.Last + 1;
1363
1364 else
1365 Index := Before.Index;
1366 end if;
1367
1368 Insert (Container, Index, New_Item);
1369
1370 Position := Cursor'(Container'Unchecked_Access, Index);
1371 end Insert;
1372
1373 procedure Insert
1374 (Container : in out Vector;
1375 Before : Cursor;
1376 New_Item : Element_Type;
1377 Count : Count_Type := 1)
1378 is
1379 Index : Index_Type'Base;
1380
1381 begin
1382 if Checks and then Before.Container /= null
1383 and then Before.Container /= Container'Unchecked_Access
1384 then
1385 raise Program_Error with "Before cursor denotes wrong container";
1386 end if;
1387
1388 if Count = 0 then
1389 return;
1390 end if;
1391
1392 if Before.Container = null
1393 or else Before.Index > Container.Last
1394 then
1395 if Checks and then Container.Last = Index_Type'Last then
1396 raise Constraint_Error with
1397 "vector is already at its maximum length";
1398 end if;
1399
1400 Index := Container.Last + 1;
1401
1402 else
1403 Index := Before.Index;
1404 end if;
1405
1406 Insert (Container, Index, New_Item, Count);
1407 end Insert;
1408
1409 procedure Insert
1410 (Container : in out Vector;
1411 Before : Cursor;
1412 New_Item : Element_Type;
1413 Position : out Cursor;
1414 Count : Count_Type := 1)
1415 is
1416 Index : Index_Type'Base;
1417
1418 begin
1419 if Checks and then Before.Container /= null
1420 and then Before.Container /= Container'Unchecked_Access
1421 then
1422 raise Program_Error with "Before cursor denotes wrong container";
1423 end if;
1424
1425 if Count = 0 then
1426 if Before.Container = null
1427 or else Before.Index > Container.Last
1428 then
1429 Position := No_Element;
1430 else
1431 Position := (Container'Unchecked_Access, Before.Index);
1432 end if;
1433
1434 return;
1435 end if;
1436
1437 if Before.Container = null
1438 or else Before.Index > Container.Last
1439 then
1440 if Checks and then Container.Last = Index_Type'Last then
1441 raise Constraint_Error with
1442 "vector is already at its maximum length";
1443 end if;
1444
1445 Index := Container.Last + 1;
1446
1447 else
1448 Index := Before.Index;
1449 end if;
1450
1451 Insert (Container, Index, New_Item, Count);
1452
1453 Position := Cursor'(Container'Unchecked_Access, Index);
1454 end Insert;
1455
1456 procedure Insert
1457 (Container : in out Vector;
1458 Before : Extended_Index;
1459 Count : Count_Type := 1)
1460 is
1461 New_Item : Element_Type; -- Default-initialized value
1462 pragma Warnings (Off, New_Item);
1463
1464 begin
1465 Insert (Container, Before, New_Item, Count);
1466 end Insert;
1467
1468 procedure Insert
1469 (Container : in out Vector;
1470 Before : Cursor;
1471 Position : out Cursor;
1472 Count : Count_Type := 1)
1473 is
1474 New_Item : Element_Type; -- Default-initialized value
1475 pragma Warnings (Off, New_Item);
1476
1477 begin
1478 Insert (Container, Before, New_Item, Position, Count);
1479 end Insert;
1480
1481 ------------------
1482 -- Insert_Space --
1483 ------------------
1484
1485 procedure Insert_Space
1486 (Container : in out Vector;
1487 Before : Extended_Index;
1488 Count : Count_Type := 1)
1489 is
1490 EA : Elements_Array renames Container.Elements;
1491 Old_Length : constant Count_Type := Container.Length;
1492
1493 Max_Length : Count_Type'Base; -- determined from range of Index_Type
1494 New_Length : Count_Type'Base; -- sum of current length and Count
1495
1496 Index : Index_Type'Base; -- scratch for intermediate values
1497 J : Count_Type'Base; -- scratch
1498
1499 begin
1500 -- As a precondition on the generic actual Index_Type, the base type
1501 -- must include Index_Type'Pred (Index_Type'First); this is the value
1502 -- that Container.Last assumes when the vector is empty. However, we do
1503 -- not allow that as the value for Index when specifying where the new
1504 -- items should be inserted, so we must manually check. (That the user
1505 -- is allowed to specify the value at all here is a consequence of the
1506 -- declaration of the Extended_Index subtype, which includes the values
1507 -- in the base range that immediately precede and immediately follow the
1508 -- values in the Index_Type.)
1509
1510 if Checks and then Before < Index_Type'First then
1511 raise Constraint_Error with
1512 "Before index is out of range (too small)";
1513 end if;
1514
1515 -- We do allow a value greater than Container.Last to be specified as
1516 -- the Index, but only if it's immediately greater. This allows for the
1517 -- case of appending items to the back end of the vector. (It is assumed
1518 -- that specifying an index value greater than Last + 1 indicates some
1519 -- deeper flaw in the caller's algorithm, so that case is treated as a
1520 -- proper error.)
1521
1522 if Checks and then Before > Container.Last
1523 and then Before > Container.Last + 1
1524 then
1525 raise Constraint_Error with
1526 "Before index is out of range (too large)";
1527 end if;
1528
1529 -- We treat inserting 0 items into the container as a no-op, even when
1530 -- the container is busy, so we simply return.
1531
1532 if Count = 0 then
1533 return;
1534 end if;
1535
1536 -- There are two constraints we need to satisfy. The first constraint is
1537 -- that a container cannot have more than Count_Type'Last elements, so
1538 -- we must check the sum of the current length and the insertion count.
1539 -- Note that we cannot simply add these values, because of the
1540 -- possibility of overflow.
1541
1542 if Checks and then Old_Length > Count_Type'Last - Count then
1543 raise Constraint_Error with "Count is out of range";
1544 end if;
1545
1546 -- It is now safe compute the length of the new vector, without fear of
1547 -- overflow.
1548
1549 New_Length := Old_Length + Count;
1550
1551 -- The second constraint is that the new Last index value cannot exceed
1552 -- Index_Type'Last. In each branch below, we calculate the maximum
1553 -- length (computed from the range of values in Index_Type), and then
1554 -- compare the new length to the maximum length. If the new length is
1555 -- acceptable, then we compute the new last index from that.
1556
1557 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1558
1559 -- We have to handle the case when there might be more values in the
1560 -- range of Index_Type than in the range of Count_Type.
1561
1562 if Index_Type'First <= 0 then
1563
1564 -- We know that No_Index (the same as Index_Type'First - 1) is
1565 -- less than 0, so it is safe to compute the following sum without
1566 -- fear of overflow.
1567
1568 Index := No_Index + Index_Type'Base (Count_Type'Last);
1569
1570 if Index <= Index_Type'Last then
1571
1572 -- We have determined that range of Index_Type has at least as
1573 -- many values as in Count_Type, so Count_Type'Last is the
1574 -- maximum number of items that are allowed.
1575
1576 Max_Length := Count_Type'Last;
1577
1578 else
1579 -- The range of Index_Type has fewer values than in Count_Type,
1580 -- so the maximum number of items is computed from the range of
1581 -- the Index_Type.
1582
1583 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1584 end if;
1585
1586 else
1587 -- No_Index is equal or greater than 0, so we can safely compute
1588 -- the difference without fear of overflow (which we would have to
1589 -- worry about if No_Index were less than 0, but that case is
1590 -- handled above).
1591
1592 if Index_Type'Last - No_Index >=
1593 Count_Type'Pos (Count_Type'Last)
1594 then
1595 -- We have determined that range of Index_Type has at least as
1596 -- many values as in Count_Type, so Count_Type'Last is the
1597 -- maximum number of items that are allowed.
1598
1599 Max_Length := Count_Type'Last;
1600
1601 else
1602 -- The range of Index_Type has fewer values than in Count_Type,
1603 -- so the maximum number of items is computed from the range of
1604 -- the Index_Type.
1605
1606 Max_Length := Count_Type'Base (Index_Type'Last - No_Index);
1607 end if;
1608 end if;
1609
1610 elsif Index_Type'First <= 0 then
1611
1612 -- We know that No_Index (the same as Index_Type'First - 1) is less
1613 -- than 0, so it is safe to compute the following sum without fear of
1614 -- overflow.
1615
1616 J := Count_Type'Base (No_Index) + Count_Type'Last;
1617
1618 if J <= Count_Type'Base (Index_Type'Last) then
1619
1620 -- We have determined that range of Index_Type has at least as
1621 -- many values as in Count_Type, so Count_Type'Last is the maximum
1622 -- number of items that are allowed.
1623
1624 Max_Length := Count_Type'Last;
1625
1626 else
1627 -- The range of Index_Type has fewer values than Count_Type does,
1628 -- so the maximum number of items is computed from the range of
1629 -- the Index_Type.
1630
1631 Max_Length :=
1632 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1633 end if;
1634
1635 else
1636 -- No_Index is equal or greater than 0, so we can safely compute the
1637 -- difference without fear of overflow (which we would have to worry
1638 -- about if No_Index were less than 0, but that case is handled
1639 -- above).
1640
1641 Max_Length :=
1642 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index);
1643 end if;
1644
1645 -- We have just computed the maximum length (number of items). We must
1646 -- now compare the requested length to the maximum length, as we do not
1647 -- allow a vector expand beyond the maximum (because that would create
1648 -- an internal array with a last index value greater than
1649 -- Index_Type'Last, with no way to index those elements).
1650
1651 if Checks and then New_Length > Max_Length then
1652 raise Constraint_Error with "Count is out of range";
1653 end if;
1654
1655 -- The tampering bits exist to prevent an item from being harmfully
1656 -- manipulated while it is being visited. Query, Update, and Iterate
1657 -- increment the busy count on entry, and decrement the count on
1658 -- exit. Insert checks the count to determine whether it is being called
1659 -- while the associated callback procedure is executing.
1660
1661 TC_Check (Container.TC);
1662
1663 -- An internal array has already been allocated, so we need to check
1664 -- whether there is enough unused storage for the new items.
1665
1666 if Checks and then New_Length > Container.Capacity then
1667 raise Capacity_Error with "New length is larger than capacity";
1668 end if;
1669
1670 -- In this case, we're inserting space into a vector that has already
1671 -- allocated an internal array, and the existing array has enough
1672 -- unused storage for the new items.
1673
1674 if Before <= Container.Last then
1675
1676 -- The space is being inserted before some existing elements,
1677 -- so we must slide the existing elements up to their new home.
1678
1679 J := To_Array_Index (Before);
1680 EA (J + Count .. New_Length) := EA (J .. Old_Length);
1681 end if;
1682
1683 -- New_Last is the last index value of the items in the container after
1684 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to
1685 -- compute its value from the New_Length.
1686
1687 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
1688 Container.Last := No_Index + Index_Type'Base (New_Length);
1689
1690 else
1691 Container.Last :=
1692 Index_Type'Base (Count_Type'Base (No_Index) + New_Length);
1693 end if;
1694 end Insert_Space;
1695
1696 procedure Insert_Space
1697 (Container : in out Vector;
1698 Before : Cursor;
1699 Position : out Cursor;
1700 Count : Count_Type := 1)
1701 is
1702 Index : Index_Type'Base;
1703
1704 begin
1705 if Checks and then Before.Container /= null
1706 and then Before.Container /= Container'Unchecked_Access
1707 then
1708 raise Program_Error with "Before cursor denotes wrong container";
1709 end if;
1710
1711 if Count = 0 then
1712 if Before.Container = null
1713 or else Before.Index > Container.Last
1714 then
1715 Position := No_Element;
1716 else
1717 Position := (Container'Unchecked_Access, Before.Index);
1718 end if;
1719
1720 return;
1721 end if;
1722
1723 if Before.Container = null
1724 or else Before.Index > Container.Last
1725 then
1726 if Checks and then Container.Last = Index_Type'Last then
1727 raise Constraint_Error with
1728 "vector is already at its maximum length";
1729 end if;
1730
1731 Index := Container.Last + 1;
1732
1733 else
1734 Index := Before.Index;
1735 end if;
1736
1737 Insert_Space (Container, Index, Count => Count);
1738
1739 Position := Cursor'(Container'Unchecked_Access, Index);
1740 end Insert_Space;
1741
1742 --------------
1743 -- Is_Empty --
1744 --------------
1745
1746 function Is_Empty (Container : Vector) return Boolean is
1747 begin
1748 return Container.Last < Index_Type'First;
1749 end Is_Empty;
1750
1751 -------------
1752 -- Iterate --
1753 -------------
1754
1755 procedure Iterate
1756 (Container : Vector;
1757 Process : not null access procedure (Position : Cursor))
1758 is
1759 Busy : With_Busy (Container.TC'Unrestricted_Access);
1760 begin
1761 for Indx in Index_Type'First .. Container.Last loop
1762 Process (Cursor'(Container'Unrestricted_Access, Indx));
1763 end loop;
1764 end Iterate;
1765
1766 function Iterate
1767 (Container : Vector)
1768 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
1769 is
1770 V : constant Vector_Access := Container'Unrestricted_Access;
1771 begin
1772 -- The value of its Index component influences the behavior of the First
1773 -- and Last selector functions of the iterator object. When the Index
1774 -- component is No_Index (as is the case here), this means the iterator
1775 -- object was constructed without a start expression. This is a complete
1776 -- iterator, meaning that the iteration starts from the (logical)
1777 -- beginning of the sequence of items.
1778
1779 -- Note: For a forward iterator, Container.First is the beginning, and
1780 -- for a reverse iterator, Container.Last is the beginning.
1781
1782 return It : constant Iterator :=
1783 (Limited_Controlled with
1784 Container => V,
1785 Index => No_Index)
1786 do
1787 Busy (Container.TC'Unrestricted_Access.all);
1788 end return;
1789 end Iterate;
1790
1791 function Iterate
1792 (Container : Vector;
1793 Start : Cursor)
1794 return Vector_Iterator_Interfaces.Reversible_Iterator'Class
1795 is
1796 V : constant Vector_Access := Container'Unrestricted_Access;
1797 begin
1798 -- It was formerly the case that when Start = No_Element, the partial
1799 -- iterator was defined to behave the same as for a complete iterator,
1800 -- and iterate over the entire sequence of items. However, those
1801 -- semantics were unintuitive and arguably error-prone (it is too easy
1802 -- to accidentally create an endless loop), and so they were changed,
1803 -- per the ARG meeting in Denver on 2011/11. However, there was no
1804 -- consensus about what positive meaning this corner case should have,
1805 -- and so it was decided to simply raise an exception. This does imply,
1806 -- however, that it is not possible to use a partial iterator to specify
1807 -- an empty sequence of items.
1808
1809 if Checks and then Start.Container = null then
1810 raise Constraint_Error with
1811 "Start position for iterator equals No_Element";
1812 end if;
1813
1814 if Checks and then Start.Container /= V then
1815 raise Program_Error with
1816 "Start cursor of Iterate designates wrong vector";
1817 end if;
1818
1819 if Checks and then Start.Index > V.Last then
1820 raise Constraint_Error with
1821 "Start position for iterator equals No_Element";
1822 end if;
1823
1824 -- The value of its Index component influences the behavior of the First
1825 -- and Last selector functions of the iterator object. When the Index
1826 -- component is not No_Index (as is the case here), it means that this
1827 -- is a partial iteration, over a subset of the complete sequence of
1828 -- items. The iterator object was constructed with a start expression,
1829 -- indicating the position from which the iteration begins. Note that
1830 -- the start position has the same value irrespective of whether this is
1831 -- a forward or reverse iteration.
1832
1833 return It : constant Iterator :=
1834 (Limited_Controlled with
1835 Container => V,
1836 Index => Start.Index)
1837 do
1838 Busy (Container.TC'Unrestricted_Access.all);
1839 end return;
1840 end Iterate;
1841
1842 ----------
1843 -- Last --
1844 ----------
1845
1846 function Last (Container : Vector) return Cursor is
1847 begin
1848 if Is_Empty (Container) then
1849 return No_Element;
1850 else
1851 return (Container'Unrestricted_Access, Container.Last);
1852 end if;
1853 end Last;
1854
1855 function Last (Object : Iterator) return Cursor is
1856 begin
1857 -- The value of the iterator object's Index component influences the
1858 -- behavior of the Last (and First) selector function.
1859
1860 -- When the Index component is No_Index, this means the iterator object
1861 -- was constructed without a start expression, in which case the
1862 -- (reverse) iteration starts from the (logical) beginning of the entire
1863 -- sequence (corresponding to Container.Last, for a reverse iterator).
1864
1865 -- Otherwise, this is iteration over a partial sequence of items. When
1866 -- the Index component is not No_Index, the iterator object was
1867 -- constructed with a start expression, that specifies the position from
1868 -- which the (reverse) partial iteration begins.
1869
1870 if Object.Index = No_Index then
1871 return Last (Object.Container.all);
1872 else
1873 return Cursor'(Object.Container, Object.Index);
1874 end if;
1875 end Last;
1876
1877 ------------------
1878 -- Last_Element --
1879 ------------------
1880
1881 function Last_Element (Container : Vector) return Element_Type is
1882 begin
1883 if Checks and then Container.Last = No_Index then
1884 raise Constraint_Error with "Container is empty";
1885 end if;
1886
1887 return Container.Elements (Container.Length);
1888 end Last_Element;
1889
1890 ----------------
1891 -- Last_Index --
1892 ----------------
1893
1894 function Last_Index (Container : Vector) return Extended_Index is
1895 begin
1896 return Container.Last;
1897 end Last_Index;
1898
1899 ------------
1900 -- Length --
1901 ------------
1902
1903 function Length (Container : Vector) return Count_Type is
1904 L : constant Index_Type'Base := Container.Last;
1905 F : constant Index_Type := Index_Type'First;
1906
1907 begin
1908 -- The base range of the index type (Index_Type'Base) might not include
1909 -- all values for length (Count_Type). Contrariwise, the index type
1910 -- might include values outside the range of length. Hence we use
1911 -- whatever type is wider for intermediate values when calculating
1912 -- length. Note that no matter what the index type is, the maximum
1913 -- length to which a vector is allowed to grow is always the minimum
1914 -- of Count_Type'Last and (IT'Last - IT'First + 1).
1915
1916 -- For example, an Index_Type with range -127 .. 127 is only guaranteed
1917 -- to have a base range of -128 .. 127, but the corresponding vector
1918 -- would have lengths in the range 0 .. 255. In this case we would need
1919 -- to use Count_Type'Base for intermediate values.
1920
1921 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The
1922 -- vector would have a maximum length of 10, but the index values lie
1923 -- outside the range of Count_Type (which is only 32 bits). In this
1924 -- case we would need to use Index_Type'Base for intermediate values.
1925
1926 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then
1927 return Count_Type'Base (L) - Count_Type'Base (F) + 1;
1928 else
1929 return Count_Type (L - F + 1);
1930 end if;
1931 end Length;
1932
1933 ----------
1934 -- Move --
1935 ----------
1936
1937 procedure Move
1938 (Target : in out Vector;
1939 Source : in out Vector)
1940 is
1941 begin
1942 if Target'Address = Source'Address then
1943 return;
1944 end if;
1945
1946 if Checks and then Target.Capacity < Source.Length then
1947 raise Capacity_Error -- ???
1948 with "Target capacity is less than Source length";
1949 end if;
1950
1951 TC_Check (Target.TC);
1952 TC_Check (Source.TC);
1953
1954 -- Clear Target now, in case element assignment fails
1955
1956 Target.Last := No_Index;
1957
1958 Target.Elements (1 .. Source.Length) :=
1959 Source.Elements (1 .. Source.Length);
1960
1961 Target.Last := Source.Last;
1962 Source.Last := No_Index;
1963 end Move;
1964
1965 ----------
1966 -- Next --
1967 ----------
1968
1969 function Next (Position : Cursor) return Cursor is
1970 begin
1971 if Position.Container = null then
1972 return No_Element;
1973 elsif Position.Index < Position.Container.Last then
1974 return (Position.Container, Position.Index + 1);
1975 else
1976 return No_Element;
1977 end if;
1978 end Next;
1979
1980 function Next (Object : Iterator; Position : Cursor) return Cursor is
1981 begin
1982 if Position.Container = null then
1983 return No_Element;
1984 end if;
1985
1986 if Checks and then Position.Container /= Object.Container then
1987 raise Program_Error with
1988 "Position cursor of Next designates wrong vector";
1989 end if;
1990
1991 return Next (Position);
1992 end Next;
1993
1994 procedure Next (Position : in out Cursor) is
1995 begin
1996 if Position.Container = null then
1997 return;
1998 elsif Position.Index < Position.Container.Last then
1999 Position.Index := Position.Index + 1;
2000 else
2001 Position := No_Element;
2002 end if;
2003 end Next;
2004
2005 -------------
2006 -- Prepend --
2007 -------------
2008
2009 procedure Prepend (Container : in out Vector; New_Item : Vector) is
2010 begin
2011 Insert (Container, Index_Type'First, New_Item);
2012 end Prepend;
2013
2014 procedure Prepend
2015 (Container : in out Vector;
2016 New_Item : Element_Type;
2017 Count : Count_Type := 1)
2018 is
2019 begin
2020 Insert (Container,
2021 Index_Type'First,
2022 New_Item,
2023 Count);
2024 end Prepend;
2025
2026 --------------
2027 -- Previous --
2028 --------------
2029
2030 procedure Previous (Position : in out Cursor) is
2031 begin
2032 if Position.Container = null then
2033 return;
2034 elsif Position.Index > Index_Type'First then
2035 Position.Index := Position.Index - 1;
2036 else
2037 Position := No_Element;
2038 end if;
2039 end Previous;
2040
2041 function Previous (Position : Cursor) return Cursor is
2042 begin
2043 if Position.Container = null then
2044 return No_Element;
2045 elsif Position.Index > Index_Type'First then
2046 return (Position.Container, Position.Index - 1);
2047 else
2048 return No_Element;
2049 end if;
2050 end Previous;
2051
2052 function Previous (Object : Iterator; Position : Cursor) return Cursor is
2053 begin
2054 if Position.Container = null then
2055 return No_Element;
2056 end if;
2057
2058 if Checks and then Position.Container /= Object.Container then
2059 raise Program_Error with
2060 "Position cursor of Previous designates wrong vector";
2061 end if;
2062
2063 return Previous (Position);
2064 end Previous;
2065
2066 ----------------------
2067 -- Pseudo_Reference --
2068 ----------------------
2069
2070 function Pseudo_Reference
2071 (Container : aliased Vector'Class) return Reference_Control_Type
2072 is
2073 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access;
2074 begin
2075 return R : constant Reference_Control_Type := (Controlled with TC) do
2076 Lock (TC.all);
2077 end return;
2078 end Pseudo_Reference;
2079
2080 -------------------
2081 -- Query_Element --
2082 -------------------
2083
2084 procedure Query_Element
2085 (Container : Vector;
2086 Index : Index_Type;
2087 Process : not null access procedure (Element : Element_Type))
2088 is
2089 Lock : With_Lock (Container.TC'Unrestricted_Access);
2090 V : Vector renames Container'Unrestricted_Access.all;
2091 begin
2092 if Checks and then Index > Container.Last then
2093 raise Constraint_Error with "Index is out of range";
2094 end if;
2095
2096 Process (V.Elements (To_Array_Index (Index)));
2097 end Query_Element;
2098
2099 procedure Query_Element
2100 (Position : Cursor;
2101 Process : not null access procedure (Element : Element_Type))
2102 is
2103 begin
2104 if Checks and then Position.Container = null then
2105 raise Constraint_Error with "Position cursor has no element";
2106 end if;
2107
2108 Query_Element (Position.Container.all, Position.Index, Process);
2109 end Query_Element;
2110
2111 ----------
2112 -- Read --
2113 ----------
2114
2115 procedure Read
2116 (Stream : not null access Root_Stream_Type'Class;
2117 Container : out Vector)
2118 is
2119 Length : Count_Type'Base;
2120 Last : Index_Type'Base := No_Index;
2121
2122 begin
2123 Clear (Container);
2124
2125 Count_Type'Base'Read (Stream, Length);
2126
2127 Reserve_Capacity (Container, Capacity => Length);
2128
2129 for Idx in Count_Type range 1 .. Length loop
2130 Last := Last + 1;
2131 Element_Type'Read (Stream, Container.Elements (Idx));
2132 Container.Last := Last;
2133 end loop;
2134 end Read;
2135
2136 procedure Read
2137 (Stream : not null access Root_Stream_Type'Class;
2138 Position : out Cursor)
2139 is
2140 begin
2141 raise Program_Error with "attempt to stream vector cursor";
2142 end Read;
2143
2144 procedure Read
2145 (Stream : not null access Root_Stream_Type'Class;
2146 Item : out Reference_Type)
2147 is
2148 begin
2149 raise Program_Error with "attempt to stream reference";
2150 end Read;
2151
2152 procedure Read
2153 (Stream : not null access Root_Stream_Type'Class;
2154 Item : out Constant_Reference_Type)
2155 is
2156 begin
2157 raise Program_Error with "attempt to stream reference";
2158 end Read;
2159
2160 ---------------
2161 -- Reference --
2162 ---------------
2163
2164 function Reference
2165 (Container : aliased in out Vector;
2166 Position : Cursor) return Reference_Type
2167 is
2168 begin
2169 if Checks and then Position.Container = null then
2170 raise Constraint_Error with "Position cursor has no element";
2171 end if;
2172
2173 if Checks and then Position.Container /= Container'Unrestricted_Access
2174 then
2175 raise Program_Error with "Position cursor denotes wrong container";
2176 end if;
2177
2178 if Checks and then Position.Index > Position.Container.Last then
2179 raise Constraint_Error with "Position cursor is out of range";
2180 end if;
2181
2182 declare
2183 A : Elements_Array renames Container.Elements;
2184 J : constant Count_Type := To_Array_Index (Position.Index);
2185 TC : constant Tamper_Counts_Access :=
2186 Container.TC'Unrestricted_Access;
2187 begin
2188 return R : constant Reference_Type :=
2189 (Element => A (J)'Access,
2190 Control => (Controlled with TC))
2191 do
2192 Lock (TC.all);
2193 end return;
2194 end;
2195 end Reference;
2196
2197 function Reference
2198 (Container : aliased in out Vector;
2199 Index : Index_Type) return Reference_Type
2200 is
2201 begin
2202 if Checks and then Index > Container.Last then
2203 raise Constraint_Error with "Index is out of range";
2204 end if;
2205
2206 declare
2207 A : Elements_Array renames Container.Elements;
2208 J : constant Count_Type := To_Array_Index (Index);
2209 TC : constant Tamper_Counts_Access :=
2210 Container.TC'Unrestricted_Access;
2211 begin
2212 return R : constant Reference_Type :=
2213 (Element => A (J)'Access,
2214 Control => (Controlled with TC))
2215 do
2216 Lock (TC.all);
2217 end return;
2218 end;
2219 end Reference;
2220
2221 ---------------------
2222 -- Replace_Element --
2223 ---------------------
2224
2225 procedure Replace_Element
2226 (Container : in out Vector;
2227 Index : Index_Type;
2228 New_Item : Element_Type)
2229 is
2230 begin
2231 if Checks and then Index > Container.Last then
2232 raise Constraint_Error with "Index is out of range";
2233 end if;
2234
2235 TE_Check (Container.TC);
2236
2237 Container.Elements (To_Array_Index (Index)) := New_Item;
2238 end Replace_Element;
2239
2240 procedure Replace_Element
2241 (Container : in out Vector;
2242 Position : Cursor;
2243 New_Item : Element_Type)
2244 is
2245 begin
2246 if Checks and then Position.Container = null then
2247 raise Constraint_Error with "Position cursor has no element";
2248 end if;
2249
2250 if Checks and then Position.Container /= Container'Unrestricted_Access
2251 then
2252 raise Program_Error with "Position cursor denotes wrong container";
2253 end if;
2254
2255 if Checks and then Position.Index > Container.Last then
2256 raise Constraint_Error with "Position cursor is out of range";
2257 end if;
2258
2259 TE_Check (Container.TC);
2260
2261 Container.Elements (To_Array_Index (Position.Index)) := New_Item;
2262 end Replace_Element;
2263
2264 ----------------------
2265 -- Reserve_Capacity --
2266 ----------------------
2267
2268 procedure Reserve_Capacity
2269 (Container : in out Vector;
2270 Capacity : Count_Type)
2271 is
2272 begin
2273 if Checks and then Capacity > Container.Capacity then
2274 raise Capacity_Error with "Capacity is out of range";
2275 end if;
2276 end Reserve_Capacity;
2277
2278 ----------------------
2279 -- Reverse_Elements --
2280 ----------------------
2281
2282 procedure Reverse_Elements (Container : in out Vector) is
2283 E : Elements_Array renames Container.Elements;
2284 Idx : Count_Type;
2285 Jdx : Count_Type;
2286
2287 begin
2288 if Container.Length <= 1 then
2289 return;
2290 end if;
2291
2292 -- The exception behavior for the vector container must match that for
2293 -- the list container, so we check for cursor tampering here (which will
2294 -- catch more things) instead of for element tampering (which will catch
2295 -- fewer things). It's true that the elements of this vector container
2296 -- could be safely moved around while (say) an iteration is taking place
2297 -- (iteration only increments the busy counter), and so technically
2298 -- all we would need here is a test for element tampering (indicated
2299 -- by the lock counter), that's simply an artifact of our array-based
2300 -- implementation. Logically Reverse_Elements requires a check for
2301 -- cursor tampering.
2302
2303 TC_Check (Container.TC);
2304
2305 Idx := 1;
2306 Jdx := Container.Length;
2307 while Idx < Jdx loop
2308 declare
2309 EI : constant Element_Type := E (Idx);
2310
2311 begin
2312 E (Idx) := E (Jdx);
2313 E (Jdx) := EI;
2314 end;
2315
2316 Idx := Idx + 1;
2317 Jdx := Jdx - 1;
2318 end loop;
2319 end Reverse_Elements;
2320
2321 ------------------
2322 -- Reverse_Find --
2323 ------------------
2324
2325 function Reverse_Find
2326 (Container : Vector;
2327 Item : Element_Type;
2328 Position : Cursor := No_Element) return Cursor
2329 is
2330 Last : Index_Type'Base;
2331
2332 begin
2333 if Checks and then Position.Container /= null
2334 and then Position.Container /= Container'Unrestricted_Access
2335 then
2336 raise Program_Error with "Position cursor denotes wrong container";
2337 end if;
2338
2339 Last :=
2340 (if Position.Container = null or else Position.Index > Container.Last
2341 then Container.Last
2342 else Position.Index);
2343
2344 -- Per AI05-0022, the container implementation is required to detect
2345 -- element tampering by a generic actual subprogram.
2346
2347 declare
2348 Lock : With_Lock (Container.TC'Unrestricted_Access);
2349 begin
2350 for Indx in reverse Index_Type'First .. Last loop
2351 if Container.Elements (To_Array_Index (Indx)) = Item then
2352 return Cursor'(Container'Unrestricted_Access, Indx);
2353 end if;
2354 end loop;
2355
2356 return No_Element;
2357 end;
2358 end Reverse_Find;
2359
2360 ------------------------
2361 -- Reverse_Find_Index --
2362 ------------------------
2363
2364 function Reverse_Find_Index
2365 (Container : Vector;
2366 Item : Element_Type;
2367 Index : Index_Type := Index_Type'Last) return Extended_Index
2368 is
2369 -- Per AI05-0022, the container implementation is required to detect
2370 -- element tampering by a generic actual subprogram.
2371
2372 Lock : With_Lock (Container.TC'Unrestricted_Access);
2373
2374 Last : constant Index_Type'Base :=
2375 Index_Type'Min (Container.Last, Index);
2376
2377 begin
2378 for Indx in reverse Index_Type'First .. Last loop
2379 if Container.Elements (To_Array_Index (Indx)) = Item then
2380 return Indx;
2381 end if;
2382 end loop;
2383
2384 return No_Index;
2385 end Reverse_Find_Index;
2386
2387 ---------------------
2388 -- Reverse_Iterate --
2389 ---------------------
2390
2391 procedure Reverse_Iterate
2392 (Container : Vector;
2393 Process : not null access procedure (Position : Cursor))
2394 is
2395 Busy : With_Busy (Container.TC'Unrestricted_Access);
2396 begin
2397 for Indx in reverse Index_Type'First .. Container.Last loop
2398 Process (Cursor'(Container'Unrestricted_Access, Indx));
2399 end loop;
2400 end Reverse_Iterate;
2401
2402 ----------------
2403 -- Set_Length --
2404 ----------------
2405
2406 procedure Set_Length (Container : in out Vector; Length : Count_Type) is
2407 Count : constant Count_Type'Base := Container.Length - Length;
2408
2409 begin
2410 -- Set_Length allows the user to set the length explicitly, instead of
2411 -- implicitly as a side-effect of deletion or insertion. If the
2412 -- requested length is less than the current length, this is equivalent
2413 -- to deleting items from the back end of the vector. If the requested
2414 -- length is greater than the current length, then this is equivalent to
2415 -- inserting "space" (nonce items) at the end.
2416
2417 if Count >= 0 then
2418 Container.Delete_Last (Count);
2419 elsif Checks and then Container.Last >= Index_Type'Last then
2420 raise Constraint_Error with "vector is already at its maximum length";
2421 else
2422 Container.Insert_Space (Container.Last + 1, -Count);
2423 end if;
2424 end Set_Length;
2425
2426 ----------
2427 -- Swap --
2428 ----------
2429
2430 procedure Swap (Container : in out Vector; I, J : Index_Type) is
2431 E : Elements_Array renames Container.Elements;
2432
2433 begin
2434 if Checks and then I > Container.Last then
2435 raise Constraint_Error with "I index is out of range";
2436 end if;
2437
2438 if Checks and then J > Container.Last then
2439 raise Constraint_Error with "J index is out of range";
2440 end if;
2441
2442 if I = J then
2443 return;
2444 end if;
2445
2446 TE_Check (Container.TC);
2447
2448 declare
2449 EI_Copy : constant Element_Type := E (To_Array_Index (I));
2450 begin
2451 E (To_Array_Index (I)) := E (To_Array_Index (J));
2452 E (To_Array_Index (J)) := EI_Copy;
2453 end;
2454 end Swap;
2455
2456 procedure Swap (Container : in out Vector; I, J : Cursor) is
2457 begin
2458 if Checks and then I.Container = null then
2459 raise Constraint_Error with "I cursor has no element";
2460 end if;
2461
2462 if Checks and then J.Container = null then
2463 raise Constraint_Error with "J cursor has no element";
2464 end if;
2465
2466 if Checks and then I.Container /= Container'Unrestricted_Access then
2467 raise Program_Error with "I cursor denotes wrong container";
2468 end if;
2469
2470 if Checks and then J.Container /= Container'Unrestricted_Access then
2471 raise Program_Error with "J cursor denotes wrong container";
2472 end if;
2473
2474 Swap (Container, I.Index, J.Index);
2475 end Swap;
2476
2477 --------------------
2478 -- To_Array_Index --
2479 --------------------
2480
2481 function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is
2482 Offset : Count_Type'Base;
2483
2484 begin
2485 -- We know that
2486 -- Index >= Index_Type'First
2487 -- hence we also know that
2488 -- Index - Index_Type'First >= 0
2489
2490 -- The issue is that even though 0 is guaranteed to be a value in
2491 -- the type Index_Type'Base, there's no guarantee that the difference
2492 -- is a value in that type. To prevent overflow we use the wider
2493 -- of Count_Type'Base and Index_Type'Base to perform intermediate
2494 -- calculations.
2495
2496 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2497 Offset := Count_Type'Base (Index - Index_Type'First);
2498
2499 else
2500 Offset := Count_Type'Base (Index) -
2501 Count_Type'Base (Index_Type'First);
2502 end if;
2503
2504 -- The array index subtype for all container element arrays
2505 -- always starts with 1.
2506
2507 return 1 + Offset;
2508 end To_Array_Index;
2509
2510 ---------------
2511 -- To_Cursor --
2512 ---------------
2513
2514 function To_Cursor
2515 (Container : Vector;
2516 Index : Extended_Index) return Cursor
2517 is
2518 begin
2519 if Index not in Index_Type'First .. Container.Last then
2520 return No_Element;
2521 end if;
2522
2523 return Cursor'(Container'Unrestricted_Access, Index);
2524 end To_Cursor;
2525
2526 --------------
2527 -- To_Index --
2528 --------------
2529
2530 function To_Index (Position : Cursor) return Extended_Index is
2531 begin
2532 if Position.Container = null then
2533 return No_Index;
2534 end if;
2535
2536 if Position.Index <= Position.Container.Last then
2537 return Position.Index;
2538 end if;
2539
2540 return No_Index;
2541 end To_Index;
2542
2543 ---------------
2544 -- To_Vector --
2545 ---------------
2546
2547 function To_Vector (Length : Count_Type) return Vector is
2548 Index : Count_Type'Base;
2549 Last : Index_Type'Base;
2550
2551 begin
2552 if Length = 0 then
2553 return Empty_Vector;
2554 end if;
2555
2556 -- We create a vector object with a capacity that matches the specified
2557 -- Length, but we do not allow the vector capacity (the length of the
2558 -- internal array) to exceed the number of values in Index_Type'Range
2559 -- (otherwise, there would be no way to refer to those components via an
2560 -- index). We must therefore check whether the specified Length would
2561 -- create a Last index value greater than Index_Type'Last.
2562
2563 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2564 -- We perform a two-part test. First we determine whether the
2565 -- computed Last value lies in the base range of the type, and then
2566 -- determine whether it lies in the range of the index (sub)type.
2567
2568 -- Last must satisfy this relation:
2569 -- First + Length - 1 <= Last
2570 -- We regroup terms:
2571 -- First - 1 <= Last - Length
2572 -- Which can rewrite as:
2573 -- No_Index <= Last - Length
2574
2575 if Checks and then
2576 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
2577 then
2578 raise Constraint_Error with "Length is out of range";
2579 end if;
2580
2581 -- We now know that the computed value of Last is within the base
2582 -- range of the type, so it is safe to compute its value:
2583
2584 Last := No_Index + Index_Type'Base (Length);
2585
2586 -- Finally we test whether the value is within the range of the
2587 -- generic actual index subtype:
2588
2589 if Checks and then Last > Index_Type'Last then
2590 raise Constraint_Error with "Length is out of range";
2591 end if;
2592
2593 elsif Index_Type'First <= 0 then
2594
2595 -- Here we can compute Last directly, in the normal way. We know that
2596 -- No_Index is less than 0, so there is no danger of overflow when
2597 -- adding the (positive) value of Length.
2598
2599 Index := Count_Type'Base (No_Index) + Length; -- Last
2600
2601 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
2602 raise Constraint_Error with "Length is out of range";
2603 end if;
2604
2605 -- We know that the computed value (having type Count_Type) of Last
2606 -- is within the range of the generic actual index subtype, so it is
2607 -- safe to convert to Index_Type:
2608
2609 Last := Index_Type'Base (Index);
2610
2611 else
2612 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2613 -- must test the length indirectly (by working backwards from the
2614 -- largest possible value of Last), in order to prevent overflow.
2615
2616 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
2617
2618 if Checks and then Index < Count_Type'Base (No_Index) then
2619 raise Constraint_Error with "Length is out of range";
2620 end if;
2621
2622 -- We have determined that the value of Length would not create a
2623 -- Last index value outside of the range of Index_Type, so we can now
2624 -- safely compute its value.
2625
2626 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
2627 end if;
2628
2629 return V : Vector (Capacity => Length) do
2630 V.Last := Last;
2631 end return;
2632 end To_Vector;
2633
2634 function To_Vector
2635 (New_Item : Element_Type;
2636 Length : Count_Type) return Vector
2637 is
2638 Index : Count_Type'Base;
2639 Last : Index_Type'Base;
2640
2641 begin
2642 if Length = 0 then
2643 return Empty_Vector;
2644 end if;
2645
2646 -- We create a vector object with a capacity that matches the specified
2647 -- Length, but we do not allow the vector capacity (the length of the
2648 -- internal array) to exceed the number of values in Index_Type'Range
2649 -- (otherwise, there would be no way to refer to those components via an
2650 -- index). We must therefore check whether the specified Length would
2651 -- create a Last index value greater than Index_Type'Last.
2652
2653 if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then
2654
2655 -- We perform a two-part test. First we determine whether the
2656 -- computed Last value lies in the base range of the type, and then
2657 -- determine whether it lies in the range of the index (sub)type.
2658
2659 -- Last must satisfy this relation:
2660 -- First + Length - 1 <= Last
2661 -- We regroup terms:
2662 -- First - 1 <= Last - Length
2663 -- Which can rewrite as:
2664 -- No_Index <= Last - Length
2665
2666 if Checks and then
2667 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index
2668 then
2669 raise Constraint_Error with "Length is out of range";
2670 end if;
2671
2672 -- We now know that the computed value of Last is within the base
2673 -- range of the type, so it is safe to compute its value:
2674
2675 Last := No_Index + Index_Type'Base (Length);
2676
2677 -- Finally we test whether the value is within the range of the
2678 -- generic actual index subtype:
2679
2680 if Checks and then Last > Index_Type'Last then
2681 raise Constraint_Error with "Length is out of range";
2682 end if;
2683
2684 elsif Index_Type'First <= 0 then
2685
2686 -- Here we can compute Last directly, in the normal way. We know that
2687 -- No_Index is less than 0, so there is no danger of overflow when
2688 -- adding the (positive) value of Length.
2689
2690 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last
2691
2692 if Checks and then Index > Count_Type'Base (Index_Type'Last) then
2693 raise Constraint_Error with "Length is out of range";
2694 end if;
2695
2696 -- We know that the computed value (having type Count_Type) of Last
2697 -- is within the range of the generic actual index subtype, so it is
2698 -- safe to convert to Index_Type:
2699
2700 Last := Index_Type'Base (Index);
2701
2702 else
2703 -- Here Index_Type'First (and Index_Type'Last) is positive, so we
2704 -- must test the length indirectly (by working backwards from the
2705 -- largest possible value of Last), in order to prevent overflow.
2706
2707 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index
2708
2709 if Checks and then Index < Count_Type'Base (No_Index) then
2710 raise Constraint_Error with "Length is out of range";
2711 end if;
2712
2713 -- We have determined that the value of Length would not create a
2714 -- Last index value outside of the range of Index_Type, so we can now
2715 -- safely compute its value.
2716
2717 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length);
2718 end if;
2719
2720 return V : Vector (Capacity => Length) do
2721 V.Elements := (others => New_Item);
2722 V.Last := Last;
2723 end return;
2724 end To_Vector;
2725
2726 --------------------
2727 -- Update_Element --
2728 --------------------
2729
2730 procedure Update_Element
2731 (Container : in out Vector;
2732 Index : Index_Type;
2733 Process : not null access procedure (Element : in out Element_Type))
2734 is
2735 Lock : With_Lock (Container.TC'Unchecked_Access);
2736 begin
2737 if Checks and then Index > Container.Last then
2738 raise Constraint_Error with "Index is out of range";
2739 end if;
2740
2741 Process (Container.Elements (To_Array_Index (Index)));
2742 end Update_Element;
2743
2744 procedure Update_Element
2745 (Container : in out Vector;
2746 Position : Cursor;
2747 Process : not null access procedure (Element : in out Element_Type))
2748 is
2749 begin
2750 if Checks and then Position.Container = null then
2751 raise Constraint_Error with "Position cursor has no element";
2752 end if;
2753
2754 if Checks and then Position.Container /= Container'Unrestricted_Access
2755 then
2756 raise Program_Error with "Position cursor denotes wrong container";
2757 end if;
2758
2759 Update_Element (Container, Position.Index, Process);
2760 end Update_Element;
2761
2762 -----------
2763 -- Write --
2764 -----------
2765
2766 procedure Write
2767 (Stream : not null access Root_Stream_Type'Class;
2768 Container : Vector)
2769 is
2770 N : Count_Type;
2771
2772 begin
2773 N := Container.Length;
2774 Count_Type'Base'Write (Stream, N);
2775
2776 for J in 1 .. N loop
2777 Element_Type'Write (Stream, Container.Elements (J));
2778 end loop;
2779 end Write;
2780
2781 procedure Write
2782 (Stream : not null access Root_Stream_Type'Class;
2783 Position : Cursor)
2784 is
2785 begin
2786 raise Program_Error with "attempt to stream vector cursor";
2787 end Write;
2788
2789 procedure Write
2790 (Stream : not null access Root_Stream_Type'Class;
2791 Item : Reference_Type)
2792 is
2793 begin
2794 raise Program_Error with "attempt to stream reference";
2795 end Write;
2796
2797 procedure Write
2798 (Stream : not null access Root_Stream_Type'Class;
2799 Item : Constant_Reference_Type)
2800 is
2801 begin
2802 raise Program_Error with "attempt to stream reference";
2803 end Write;
2804
2805 end Ada.Containers.Bounded_Vectors;