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