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