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