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