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