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-2019, 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. We need to suppress warnings, because 1003 -- otherwise we get an error in -gnatwE mode. 1004 1005 pragma Warnings (Off); 1006 Index := No_Index + Index_Type'Base (Count_Type'Last); 1007 pragma Warnings (On); 1008 1009 if Index <= Index_Type'Last then 1010 1011 -- We have determined that range of Index_Type has at least as 1012 -- many values as in Count_Type, so Count_Type'Last is the 1013 -- maximum number of items that are allowed. 1014 1015 Max_Length := Count_Type'Last; 1016 1017 else 1018 -- The range of Index_Type has fewer values than in Count_Type, 1019 -- so the maximum number of items is computed from the range of 1020 -- the Index_Type. 1021 1022 Max_Length := Count_Type'Base (Index_Type'Last - No_Index); 1023 end if; 1024 1025 else 1026 -- No_Index is equal or greater than 0, so we can safely compute 1027 -- the difference without fear of overflow (which we would have to 1028 -- worry about if No_Index were less than 0, but that case is 1029 -- handled above). 1030 1031 if Index_Type'Last - No_Index >= Count_Type_Last then 1032 -- We have determined that range of Index_Type has at least as 1033 -- many values as in Count_Type, so Count_Type'Last is the 1034 -- maximum number of items that are allowed. 1035 1036 Max_Length := Count_Type'Last; 1037 1038 else 1039 -- The range of Index_Type has fewer values than in Count_Type, 1040 -- so the maximum number of items is computed from the range of 1041 -- the Index_Type. 1042 1043 Max_Length := Count_Type'Base (Index_Type'Last - No_Index); 1044 end if; 1045 end if; 1046 1047 elsif Index_Type'First <= 0 then 1048 1049 -- We know that No_Index (the same as Index_Type'First - 1) is less 1050 -- than 0, so it is safe to compute the following sum without fear of 1051 -- overflow. 1052 1053 J := Count_Type'Base (No_Index) + Count_Type'Last; 1054 1055 if J <= Count_Type'Base (Index_Type'Last) then 1056 1057 -- We have determined that range of Index_Type has at least as 1058 -- many values as in Count_Type, so Count_Type'Last is the maximum 1059 -- number of items that are allowed. 1060 1061 Max_Length := Count_Type'Last; 1062 1063 else 1064 -- The range of Index_Type has fewer values than Count_Type does, 1065 -- so the maximum number of items is computed from the range of 1066 -- the Index_Type. 1067 1068 Max_Length := 1069 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); 1070 end if; 1071 1072 else 1073 -- No_Index is equal or greater than 0, so we can safely compute the 1074 -- difference without fear of overflow (which we would have to worry 1075 -- about if No_Index were less than 0, but that case is handled 1076 -- above). 1077 1078 Max_Length := 1079 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); 1080 end if; 1081 1082 -- We have just computed the maximum length (number of items). We must 1083 -- now compare the requested length to the maximum length, as we do not 1084 -- allow a vector expand beyond the maximum (because that would create 1085 -- an internal array with a last index value greater than 1086 -- Index_Type'Last, with no way to index those elements). 1087 1088 if Checks and then New_Length > Max_Length then 1089 raise Constraint_Error with "Count is out of range"; 1090 end if; 1091 1092 -- New_Last is the last index value of the items in the container after 1093 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to 1094 -- compute its value from the New_Length. 1095 1096 if Index_Type'Base'Last >= Count_Type_Last then 1097 New_Last := No_Index + Index_Type'Base (New_Length); 1098 else 1099 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); 1100 end if; 1101 1102 if Container.Elements = null then 1103 pragma Assert (Container.Last = No_Index); 1104 1105 -- This is the simplest case, with which we must always begin: we're 1106 -- inserting items into an empty vector that hasn't allocated an 1107 -- internal array yet. Note that we don't need to check the busy bit 1108 -- here, because an empty container cannot be busy. 1109 1110 -- In order to preserve container invariants, we allocate the new 1111 -- internal array first, before setting the Last index value, in case 1112 -- the allocation fails (which can happen either because there is no 1113 -- storage available, or because element initialization fails). 1114 1115 Container.Elements := new Elements_Type' 1116 (Last => New_Last, 1117 EA => (others => New_Item)); 1118 1119 -- The allocation of the new, internal array succeeded, so it is now 1120 -- safe to update the Last index, restoring container invariants. 1121 1122 Container.Last := New_Last; 1123 1124 return; 1125 end if; 1126 1127 -- The tampering bits exist to prevent an item from being harmfully 1128 -- manipulated while it is being visited. Query, Update, and Iterate 1129 -- increment the busy count on entry, and decrement the count on 1130 -- exit. Insert checks the count to determine whether it is being called 1131 -- while the associated callback procedure is executing. 1132 1133 TC_Check (Container.TC); 1134 1135 -- An internal array has already been allocated, so we must determine 1136 -- whether there is enough unused storage for the new items. 1137 1138 if New_Length <= Container.Elements.EA'Length then 1139 1140 -- In this case, we're inserting elements into a vector that has 1141 -- already allocated an internal array, and the existing array has 1142 -- enough unused storage for the new items. 1143 1144 declare 1145 EA : Elements_Array renames Container.Elements.EA; 1146 1147 begin 1148 if Before > Container.Last then 1149 1150 -- The new items are being appended to the vector, so no 1151 -- sliding of existing elements is required. 1152 1153 EA (Before .. New_Last) := (others => New_Item); 1154 1155 else 1156 -- The new items are being inserted before some existing 1157 -- elements, so we must slide the existing elements up to their 1158 -- new home. We use the wider of Index_Type'Base and 1159 -- Count_Type'Base as the type for intermediate index values. 1160 1161 if Index_Type'Base'Last >= Count_Type_Last then 1162 Index := Before + Index_Type'Base (Count); 1163 else 1164 Index := Index_Type'Base (Count_Type'Base (Before) + Count); 1165 end if; 1166 1167 EA (Index .. New_Last) := EA (Before .. Container.Last); 1168 EA (Before .. Index - 1) := (others => New_Item); 1169 end if; 1170 end; 1171 1172 Container.Last := New_Last; 1173 return; 1174 end if; 1175 1176 -- In this case, we're inserting elements into a vector that has already 1177 -- allocated an internal array, but the existing array does not have 1178 -- enough storage, so we must allocate a new, longer array. In order to 1179 -- guarantee that the amortized insertion cost is O(1), we always 1180 -- allocate an array whose length is some power-of-two factor of the 1181 -- current array length. (The new array cannot have a length less than 1182 -- the New_Length of the container, but its last index value cannot be 1183 -- greater than Index_Type'Last.) 1184 1185 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); 1186 while New_Capacity < New_Length loop 1187 if New_Capacity > Count_Type'Last / 2 then 1188 New_Capacity := Count_Type'Last; 1189 exit; 1190 else 1191 New_Capacity := 2 * New_Capacity; 1192 end if; 1193 end loop; 1194 1195 if New_Capacity > Max_Length then 1196 1197 -- We have reached the limit of capacity, so no further expansion 1198 -- will occur. (This is not a problem, as there is never a need to 1199 -- have more capacity than the maximum container length.) 1200 1201 New_Capacity := Max_Length; 1202 end if; 1203 1204 -- We have computed the length of the new internal array (and this is 1205 -- what "vector capacity" means), so use that to compute its last index. 1206 1207 if Index_Type'Base'Last >= Count_Type_Last then 1208 Dst_Last := No_Index + Index_Type'Base (New_Capacity); 1209 else 1210 Dst_Last := 1211 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); 1212 end if; 1213 1214 -- Now we allocate the new, longer internal array. If the allocation 1215 -- fails, we have not changed any container state, so no side-effect 1216 -- will occur as a result of propagating the exception. 1217 1218 Dst := new Elements_Type (Dst_Last); 1219 1220 -- We have our new internal array. All that needs to be done now is to 1221 -- copy the existing items (if any) from the old array (the "source" 1222 -- array, object SA below) to the new array (the "destination" array, 1223 -- object DA below), and then deallocate the old array. 1224 1225 declare 1226 SA : Elements_Array renames Container.Elements.EA; -- source 1227 DA : Elements_Array renames Dst.EA; -- destination 1228 1229 begin 1230 DA (Index_Type'First .. Before - 1) := 1231 SA (Index_Type'First .. Before - 1); 1232 1233 if Before > Container.Last then 1234 DA (Before .. New_Last) := (others => New_Item); 1235 1236 else 1237 -- The new items are being inserted before some existing elements, 1238 -- so we must slide the existing elements up to their new home. 1239 1240 if Index_Type'Base'Last >= Count_Type_Last then 1241 Index := Before + Index_Type'Base (Count); 1242 else 1243 Index := Index_Type'Base (Count_Type'Base (Before) + Count); 1244 end if; 1245 1246 DA (Before .. Index - 1) := (others => New_Item); 1247 DA (Index .. New_Last) := SA (Before .. Container.Last); 1248 end if; 1249 1250 exception 1251 when others => 1252 Free (Dst); 1253 raise; 1254 end; 1255 1256 -- We have successfully copied the items onto the new array, so the 1257 -- final thing to do is deallocate the old array. 1258 1259 declare 1260 X : Elements_Access := Container.Elements; 1261 1262 begin 1263 -- We first isolate the old internal array, removing it from the 1264 -- container and replacing it with the new internal array, before we 1265 -- deallocate the old array (which can fail if finalization of 1266 -- elements propagates an exception). 1267 1268 Container.Elements := Dst; 1269 Container.Last := New_Last; 1270 1271 -- The container invariants have been restored, so it is now safe to 1272 -- attempt to deallocate the old array. 1273 1274 Free (X); 1275 end; 1276 end Insert; 1277 1278 procedure Insert 1279 (Container : in out Vector; 1280 Before : Extended_Index; 1281 New_Item : Vector) 1282 is 1283 N : constant Count_Type := Length (New_Item); 1284 J : Index_Type'Base; 1285 1286 begin 1287 -- Use Insert_Space to create the "hole" (the destination slice) into 1288 -- which we copy the source items. 1289 1290 Insert_Space (Container, Before, Count => N); 1291 1292 if N = 0 then 1293 1294 -- There's nothing else to do here (vetting of parameters was 1295 -- performed already in Insert_Space), so we simply return. 1296 1297 return; 1298 end if; 1299 1300 -- We calculate the last index value of the destination slice using the 1301 -- wider of Index_Type'Base and count_Type'Base. 1302 1303 if Index_Type'Base'Last >= Count_Type_Last then 1304 J := (Before - 1) + Index_Type'Base (N); 1305 else 1306 J := Index_Type'Base (Count_Type'Base (Before - 1) + N); 1307 end if; 1308 1309 if Container'Address /= New_Item'Address then 1310 1311 -- This is the simple case. New_Item denotes an object different 1312 -- from Container, so there's nothing special we need to do to copy 1313 -- the source items to their destination, because all of the source 1314 -- items are contiguous. 1315 1316 Container.Elements.EA (Before .. J) := 1317 New_Item.Elements.EA (Index_Type'First .. New_Item.Last); 1318 1319 return; 1320 end if; 1321 1322 -- New_Item denotes the same object as Container, so an insertion has 1323 -- potentially split the source items. The destination is always the 1324 -- range [Before, J], but the source is [Index_Type'First, Before) and 1325 -- (J, Container.Last]. We perform the copy in two steps, using each of 1326 -- the two slices of the source items. 1327 1328 declare 1329 L : constant Index_Type'Base := Before - 1; 1330 1331 subtype Src_Index_Subtype is Index_Type'Base range 1332 Index_Type'First .. L; 1333 1334 Src : Elements_Array renames 1335 Container.Elements.EA (Src_Index_Subtype); 1336 1337 K : Index_Type'Base; 1338 1339 begin 1340 -- We first copy the source items that precede the space we 1341 -- inserted. Index value K is the last index of that portion 1342 -- destination that receives this slice of the source. (If Before 1343 -- equals Index_Type'First, then this first source slice will be 1344 -- empty, which is harmless.) 1345 1346 if Index_Type'Base'Last >= Count_Type_Last then 1347 K := L + Index_Type'Base (Src'Length); 1348 else 1349 K := Index_Type'Base (Count_Type'Base (L) + Src'Length); 1350 end if; 1351 1352 Container.Elements.EA (Before .. K) := Src; 1353 1354 if Src'Length = N then 1355 1356 -- The new items were effectively appended to the container, so we 1357 -- have already copied all of the items that need to be copied. 1358 -- We return early here, even though the source slice below is 1359 -- empty (so the assignment would be harmless), because we want to 1360 -- avoid computing J + 1, which will overflow if J equals 1361 -- Index_Type'Base'Last. 1362 1363 return; 1364 end if; 1365 end; 1366 1367 declare 1368 -- Note that we want to avoid computing J + 1 here, in case J equals 1369 -- Index_Type'Base'Last. We prevent that by returning early above, 1370 -- immediately after copying the first slice of the source, and 1371 -- determining that this second slice of the source is empty. 1372 1373 F : constant Index_Type'Base := J + 1; 1374 1375 subtype Src_Index_Subtype is Index_Type'Base range 1376 F .. Container.Last; 1377 1378 Src : Elements_Array renames 1379 Container.Elements.EA (Src_Index_Subtype); 1380 1381 K : Index_Type'Base; 1382 1383 begin 1384 -- We next copy the source items that follow the space we inserted. 1385 -- Index value K is the first index of that portion of the 1386 -- destination that receives this slice of the source. (For the 1387 -- reasons given above, this slice is guaranteed to be non-empty.) 1388 1389 if Index_Type'Base'Last >= Count_Type_Last then 1390 K := F - Index_Type'Base (Src'Length); 1391 else 1392 K := Index_Type'Base (Count_Type'Base (F) - Src'Length); 1393 end if; 1394 1395 Container.Elements.EA (K .. J) := Src; 1396 end; 1397 end Insert; 1398 1399 procedure Insert 1400 (Container : in out Vector; 1401 Before : Cursor; 1402 New_Item : Vector) 1403 is 1404 Index : Index_Type'Base; 1405 1406 begin 1407 if Checks and then Before.Container /= null 1408 and then Before.Container /= Container'Unrestricted_Access 1409 then 1410 raise Program_Error with "Before cursor denotes wrong container"; 1411 end if; 1412 1413 if Is_Empty (New_Item) then 1414 return; 1415 end if; 1416 1417 if Before.Container = null or else Before.Index > Container.Last then 1418 if Checks and then Container.Last = Index_Type'Last then 1419 raise Constraint_Error with 1420 "vector is already at its maximum length"; 1421 end if; 1422 1423 Index := Container.Last + 1; 1424 1425 else 1426 Index := Before.Index; 1427 end if; 1428 1429 Insert (Container, Index, New_Item); 1430 end Insert; 1431 1432 procedure Insert 1433 (Container : in out Vector; 1434 Before : Cursor; 1435 New_Item : Vector; 1436 Position : out Cursor) 1437 is 1438 Index : Index_Type'Base; 1439 1440 begin 1441 if Checks and then Before.Container /= null 1442 and then Before.Container /= Container'Unrestricted_Access 1443 then 1444 raise Program_Error with "Before cursor denotes wrong container"; 1445 end if; 1446 1447 if Is_Empty (New_Item) then 1448 if Before.Container = null or else Before.Index > Container.Last then 1449 Position := No_Element; 1450 else 1451 Position := (Container'Unrestricted_Access, Before.Index); 1452 end if; 1453 1454 return; 1455 end if; 1456 1457 if Before.Container = null or else Before.Index > Container.Last then 1458 if Checks and then Container.Last = Index_Type'Last then 1459 raise Constraint_Error with 1460 "vector is already at its maximum length"; 1461 end if; 1462 1463 Index := Container.Last + 1; 1464 1465 else 1466 Index := Before.Index; 1467 end if; 1468 1469 Insert (Container, Index, New_Item); 1470 1471 Position := (Container'Unrestricted_Access, Index); 1472 end Insert; 1473 1474 procedure Insert 1475 (Container : in out Vector; 1476 Before : Cursor; 1477 New_Item : Element_Type; 1478 Count : Count_Type := 1) 1479 is 1480 Index : Index_Type'Base; 1481 1482 begin 1483 if Checks and then Before.Container /= null 1484 and then Before.Container /= Container'Unrestricted_Access 1485 then 1486 raise Program_Error with "Before cursor denotes wrong container"; 1487 end if; 1488 1489 if Count = 0 then 1490 return; 1491 end if; 1492 1493 if Before.Container = null or else Before.Index > Container.Last then 1494 if Checks and then Container.Last = Index_Type'Last then 1495 raise Constraint_Error with 1496 "vector is already at its maximum length"; 1497 else 1498 Index := Container.Last + 1; 1499 end if; 1500 1501 else 1502 Index := Before.Index; 1503 end if; 1504 1505 Insert (Container, Index, New_Item, Count); 1506 end Insert; 1507 1508 procedure Insert 1509 (Container : in out Vector; 1510 Before : Cursor; 1511 New_Item : Element_Type; 1512 Position : out Cursor; 1513 Count : Count_Type := 1) 1514 is 1515 Index : Index_Type'Base; 1516 1517 begin 1518 if Checks and then Before.Container /= null 1519 and then Before.Container /= Container'Unrestricted_Access 1520 then 1521 raise Program_Error with "Before cursor denotes wrong container"; 1522 end if; 1523 1524 if Count = 0 then 1525 if Before.Container = null or else Before.Index > Container.Last then 1526 Position := No_Element; 1527 else 1528 Position := (Container'Unrestricted_Access, Before.Index); 1529 end if; 1530 1531 return; 1532 end if; 1533 1534 if Before.Container = null or else Before.Index > Container.Last then 1535 if Checks and then Container.Last = Index_Type'Last then 1536 raise Constraint_Error with 1537 "vector is already at its maximum length"; 1538 end if; 1539 1540 Index := Container.Last + 1; 1541 1542 else 1543 Index := Before.Index; 1544 end if; 1545 1546 Insert (Container, Index, New_Item, Count); 1547 1548 Position := (Container'Unrestricted_Access, Index); 1549 end Insert; 1550 1551 procedure Insert 1552 (Container : in out Vector; 1553 Before : Extended_Index; 1554 Count : Count_Type := 1) 1555 is 1556 New_Item : Element_Type; -- Default-initialized value 1557 pragma Warnings (Off, New_Item); 1558 1559 begin 1560 Insert (Container, Before, New_Item, Count); 1561 end Insert; 1562 1563 procedure Insert 1564 (Container : in out Vector; 1565 Before : Cursor; 1566 Position : out Cursor; 1567 Count : Count_Type := 1) 1568 is 1569 New_Item : Element_Type; -- Default-initialized value 1570 pragma Warnings (Off, New_Item); 1571 begin 1572 Insert (Container, Before, New_Item, Position, Count); 1573 end Insert; 1574 1575 ------------------ 1576 -- Insert_Space -- 1577 ------------------ 1578 1579 procedure Insert_Space 1580 (Container : in out Vector; 1581 Before : Extended_Index; 1582 Count : Count_Type := 1) 1583 is 1584 Old_Length : constant Count_Type := Container.Length; 1585 1586 Max_Length : Count_Type'Base; -- determined from range of Index_Type 1587 New_Length : Count_Type'Base; -- sum of current length and Count 1588 New_Last : Index_Type'Base; -- last index of vector after insertion 1589 1590 Index : Index_Type'Base; -- scratch for intermediate values 1591 J : Count_Type'Base; -- scratch 1592 1593 New_Capacity : Count_Type'Base; -- length of new, expanded array 1594 Dst_Last : Index_Type'Base; -- last index of new, expanded array 1595 Dst : Elements_Access; -- new, expanded internal array 1596 1597 begin 1598 if Checks then 1599 -- As a precondition on the generic actual Index_Type, the base type 1600 -- must include Index_Type'Pred (Index_Type'First); this is the value 1601 -- that Container.Last assumes when the vector is empty. However, we 1602 -- do not allow that as the value for Index when specifying where the 1603 -- new items should be inserted, so we must manually check. (That the 1604 -- user is allowed to specify the value at all here is a consequence 1605 -- of the declaration of the Extended_Index subtype, which includes 1606 -- the values in the base range that immediately precede and 1607 -- immediately follow the values in the Index_Type.) 1608 1609 if Before < Index_Type'First then 1610 raise Constraint_Error with 1611 "Before index is out of range (too small)"; 1612 end if; 1613 1614 -- We do allow a value greater than Container.Last to be specified as 1615 -- the Index, but only if it's immediately greater. This allows for 1616 -- the case of appending items to the back end of the vector. (It is 1617 -- assumed that specifying an index value greater than Last + 1 1618 -- indicates some deeper flaw in the caller's algorithm, so that case 1619 -- is treated as a proper error.) 1620 1621 if Before > Container.Last + 1 then 1622 raise Constraint_Error with 1623 "Before index is out of range (too large)"; 1624 end if; 1625 end if; 1626 1627 -- We treat inserting 0 items into the container as a no-op, even when 1628 -- the container is busy, so we simply return. 1629 1630 if Count = 0 then 1631 return; 1632 end if; 1633 1634 -- There are two constraints we need to satisfy. The first constraint is 1635 -- that a container cannot have more than Count_Type'Last elements, so 1636 -- we must check the sum of the current length and the insertion count. 1637 -- Note: we cannot simply add these values, because of the possibility 1638 -- of overflow. 1639 1640 if Checks and then Old_Length > Count_Type'Last - Count then 1641 raise Constraint_Error with "Count is out of range"; 1642 end if; 1643 1644 -- It is now safe compute the length of the new vector, without fear of 1645 -- overflow. 1646 1647 New_Length := Old_Length + Count; 1648 1649 -- The second constraint is that the new Last index value cannot exceed 1650 -- Index_Type'Last. In each branch below, we calculate the maximum 1651 -- length (computed from the range of values in Index_Type), and then 1652 -- compare the new length to the maximum length. If the new length is 1653 -- acceptable, then we compute the new last index from that. 1654 1655 if Index_Type'Base'Last >= Count_Type_Last then 1656 -- We have to handle the case when there might be more values in the 1657 -- range of Index_Type than in the range of Count_Type. 1658 1659 if Index_Type'First <= 0 then 1660 1661 -- We know that No_Index (the same as Index_Type'First - 1) is 1662 -- less than 0, so it is safe to compute the following sum without 1663 -- fear of overflow. We need to suppress warnings, because 1664 -- otherwise we get an error in -gnatwE mode. 1665 1666 pragma Warnings (Off); 1667 Index := No_Index + Index_Type'Base (Count_Type'Last); 1668 pragma Warnings (On); 1669 1670 if Index <= Index_Type'Last then 1671 1672 -- We have determined that range of Index_Type has at least as 1673 -- many values as in Count_Type, so Count_Type'Last is the 1674 -- maximum number of items that are allowed. 1675 1676 Max_Length := Count_Type'Last; 1677 1678 else 1679 -- The range of Index_Type has fewer values than in Count_Type, 1680 -- so the maximum number of items is computed from the range of 1681 -- the Index_Type. 1682 1683 Max_Length := Count_Type'Base (Index_Type'Last - No_Index); 1684 end if; 1685 1686 else 1687 -- No_Index is equal or greater than 0, so we can safely compute 1688 -- the difference without fear of overflow (which we would have to 1689 -- worry about if No_Index were less than 0, but that case is 1690 -- handled above). 1691 1692 if Index_Type'Last - No_Index >= Count_Type_Last then 1693 -- We have determined that range of Index_Type has at least as 1694 -- many values as in Count_Type, so Count_Type'Last is the 1695 -- maximum number of items that are allowed. 1696 1697 Max_Length := Count_Type'Last; 1698 1699 else 1700 -- The range of Index_Type has fewer values than in Count_Type, 1701 -- so the maximum number of items is computed from the range of 1702 -- the Index_Type. 1703 1704 Max_Length := Count_Type'Base (Index_Type'Last - No_Index); 1705 end if; 1706 end if; 1707 1708 elsif Index_Type'First <= 0 then 1709 1710 -- We know that No_Index (the same as Index_Type'First - 1) is less 1711 -- than 0, so it is safe to compute the following sum without fear of 1712 -- overflow. 1713 1714 J := Count_Type'Base (No_Index) + Count_Type'Last; 1715 1716 if J <= Count_Type'Base (Index_Type'Last) then 1717 1718 -- We have determined that range of Index_Type has at least as 1719 -- many values as in Count_Type, so Count_Type'Last is the maximum 1720 -- number of items that are allowed. 1721 1722 Max_Length := Count_Type'Last; 1723 1724 else 1725 -- The range of Index_Type has fewer values than Count_Type does, 1726 -- so the maximum number of items is computed from the range of 1727 -- the Index_Type. 1728 1729 Max_Length := 1730 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); 1731 end if; 1732 1733 else 1734 -- No_Index is equal or greater than 0, so we can safely compute the 1735 -- difference without fear of overflow (which we would have to worry 1736 -- about if No_Index were less than 0, but that case is handled 1737 -- above). 1738 1739 Max_Length := 1740 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); 1741 end if; 1742 1743 -- We have just computed the maximum length (number of items). We must 1744 -- now compare the requested length to the maximum length, as we do not 1745 -- allow a vector expand beyond the maximum (because that would create 1746 -- an internal array with a last index value greater than 1747 -- Index_Type'Last, with no way to index those elements). 1748 1749 if Checks and then New_Length > Max_Length then 1750 raise Constraint_Error with "Count is out of range"; 1751 end if; 1752 1753 -- New_Last is the last index value of the items in the container after 1754 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to 1755 -- compute its value from the New_Length. 1756 1757 if Index_Type'Base'Last >= Count_Type_Last then 1758 New_Last := No_Index + Index_Type'Base (New_Length); 1759 else 1760 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); 1761 end if; 1762 1763 if Container.Elements = null then 1764 pragma Assert (Container.Last = No_Index); 1765 1766 -- This is the simplest case, with which we must always begin: we're 1767 -- inserting items into an empty vector that hasn't allocated an 1768 -- internal array yet. Note that we don't need to check the busy bit 1769 -- here, because an empty container cannot be busy. 1770 1771 -- In order to preserve container invariants, we allocate the new 1772 -- internal array first, before setting the Last index value, in case 1773 -- the allocation fails (which can happen either because there is no 1774 -- storage available, or because default-valued element 1775 -- initialization fails). 1776 1777 Container.Elements := new Elements_Type (New_Last); 1778 1779 -- The allocation of the new, internal array succeeded, so it is now 1780 -- safe to update the Last index, restoring container invariants. 1781 1782 Container.Last := New_Last; 1783 1784 return; 1785 end if; 1786 1787 -- The tampering bits exist to prevent an item from being harmfully 1788 -- manipulated while it is being visited. Query, Update, and Iterate 1789 -- increment the busy count on entry, and decrement the count on 1790 -- exit. Insert checks the count to determine whether it is being called 1791 -- while the associated callback procedure is executing. 1792 1793 TC_Check (Container.TC); 1794 1795 -- An internal array has already been allocated, so we must determine 1796 -- whether there is enough unused storage for the new items. 1797 1798 if New_Last <= Container.Elements.Last then 1799 1800 -- In this case, we're inserting space into a vector that has already 1801 -- allocated an internal array, and the existing array has enough 1802 -- unused storage for the new items. 1803 1804 declare 1805 EA : Elements_Array renames Container.Elements.EA; 1806 1807 begin 1808 if Before <= Container.Last then 1809 1810 -- The space is being inserted before some existing elements, 1811 -- so we must slide the existing elements up to their new 1812 -- home. We use the wider of Index_Type'Base and 1813 -- Count_Type'Base as the type for intermediate index values. 1814 1815 if Index_Type'Base'Last >= Count_Type_Last then 1816 Index := Before + Index_Type'Base (Count); 1817 1818 else 1819 Index := Index_Type'Base (Count_Type'Base (Before) + Count); 1820 end if; 1821 1822 EA (Index .. New_Last) := EA (Before .. Container.Last); 1823 end if; 1824 end; 1825 1826 Container.Last := New_Last; 1827 return; 1828 end if; 1829 1830 -- In this case, we're inserting space into a vector that has already 1831 -- allocated an internal array, but the existing array does not have 1832 -- enough storage, so we must allocate a new, longer array. In order to 1833 -- guarantee that the amortized insertion cost is O(1), we always 1834 -- allocate an array whose length is some power-of-two factor of the 1835 -- current array length. (The new array cannot have a length less than 1836 -- the New_Length of the container, but its last index value cannot be 1837 -- greater than Index_Type'Last.) 1838 1839 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); 1840 while New_Capacity < New_Length loop 1841 if New_Capacity > Count_Type'Last / 2 then 1842 New_Capacity := Count_Type'Last; 1843 exit; 1844 end if; 1845 1846 New_Capacity := 2 * New_Capacity; 1847 end loop; 1848 1849 if New_Capacity > Max_Length then 1850 1851 -- We have reached the limit of capacity, so no further expansion 1852 -- will occur. (This is not a problem, as there is never a need to 1853 -- have more capacity than the maximum container length.) 1854 1855 New_Capacity := Max_Length; 1856 end if; 1857 1858 -- We have computed the length of the new internal array (and this is 1859 -- what "vector capacity" means), so use that to compute its last index. 1860 1861 if Index_Type'Base'Last >= Count_Type_Last then 1862 Dst_Last := No_Index + Index_Type'Base (New_Capacity); 1863 else 1864 Dst_Last := 1865 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); 1866 end if; 1867 1868 -- Now we allocate the new, longer internal array. If the allocation 1869 -- fails, we have not changed any container state, so no side-effect 1870 -- will occur as a result of propagating the exception. 1871 1872 Dst := new Elements_Type (Dst_Last); 1873 1874 -- We have our new internal array. All that needs to be done now is to 1875 -- copy the existing items (if any) from the old array (the "source" 1876 -- array, object SA below) to the new array (the "destination" array, 1877 -- object DA below), and then deallocate the old array. 1878 1879 declare 1880 SA : Elements_Array renames Container.Elements.EA; -- source 1881 DA : Elements_Array renames Dst.EA; -- destination 1882 1883 begin 1884 DA (Index_Type'First .. Before - 1) := 1885 SA (Index_Type'First .. Before - 1); 1886 1887 if Before <= Container.Last then 1888 1889 -- The space is being inserted before some existing elements, so 1890 -- we must slide the existing elements up to their new home. 1891 1892 if Index_Type'Base'Last >= Count_Type_Last then 1893 Index := Before + Index_Type'Base (Count); 1894 else 1895 Index := Index_Type'Base (Count_Type'Base (Before) + Count); 1896 end if; 1897 1898 DA (Index .. New_Last) := SA (Before .. Container.Last); 1899 end if; 1900 1901 exception 1902 when others => 1903 Free (Dst); 1904 raise; 1905 end; 1906 1907 -- We have successfully copied the items onto the new array, so the 1908 -- final thing to do is restore invariants, and deallocate the old 1909 -- array. 1910 1911 declare 1912 X : Elements_Access := Container.Elements; 1913 1914 begin 1915 -- We first isolate the old internal array, removing it from the 1916 -- container and replacing it with the new internal array, before we 1917 -- deallocate the old array (which can fail if finalization of 1918 -- elements propagates an exception). 1919 1920 Container.Elements := Dst; 1921 Container.Last := New_Last; 1922 1923 -- The container invariants have been restored, so it is now safe to 1924 -- attempt to deallocate the old array. 1925 1926 Free (X); 1927 end; 1928 end Insert_Space; 1929 1930 procedure Insert_Space 1931 (Container : in out Vector; 1932 Before : Cursor; 1933 Position : out Cursor; 1934 Count : Count_Type := 1) 1935 is 1936 Index : Index_Type'Base; 1937 1938 begin 1939 if Checks and then Before.Container /= null 1940 and then Before.Container /= Container'Unrestricted_Access 1941 then 1942 raise Program_Error with "Before cursor denotes wrong container"; 1943 end if; 1944 1945 if Count = 0 then 1946 if Before.Container = null or else Before.Index > Container.Last then 1947 Position := No_Element; 1948 else 1949 Position := (Container'Unrestricted_Access, Before.Index); 1950 end if; 1951 1952 return; 1953 end if; 1954 1955 if Before.Container = null or else Before.Index > Container.Last then 1956 if Checks and then Container.Last = Index_Type'Last then 1957 raise Constraint_Error with 1958 "vector is already at its maximum length"; 1959 else 1960 Index := Container.Last + 1; 1961 end if; 1962 1963 else 1964 Index := Before.Index; 1965 end if; 1966 1967 Insert_Space (Container, Index, Count); 1968 1969 Position := (Container'Unrestricted_Access, Index); 1970 end Insert_Space; 1971 1972 -------------- 1973 -- Is_Empty -- 1974 -------------- 1975 1976 function Is_Empty (Container : Vector) return Boolean is 1977 begin 1978 return Container.Last < Index_Type'First; 1979 end Is_Empty; 1980 1981 ------------- 1982 -- Iterate -- 1983 ------------- 1984 1985 procedure Iterate 1986 (Container : Vector; 1987 Process : not null access procedure (Position : Cursor)) 1988 is 1989 Busy : With_Busy (Container.TC'Unrestricted_Access); 1990 begin 1991 for Indx in Index_Type'First .. Container.Last loop 1992 Process (Cursor'(Container'Unrestricted_Access, Indx)); 1993 end loop; 1994 end Iterate; 1995 1996 function Iterate 1997 (Container : Vector) 1998 return Vector_Iterator_Interfaces.Reversible_Iterator'Class 1999 is 2000 V : constant Vector_Access := Container'Unrestricted_Access; 2001 begin 2002 -- The value of its Index component influences the behavior of the First 2003 -- and Last selector functions of the iterator object. When the Index 2004 -- component is No_Index (as is the case here), this means the iterator 2005 -- object was constructed without a start expression. This is a complete 2006 -- iterator, meaning that the iteration starts from the (logical) 2007 -- beginning of the sequence of items. 2008 2009 -- Note: For a forward iterator, Container.First is the beginning, and 2010 -- for a reverse iterator, Container.Last is the beginning. 2011 2012 return It : constant Iterator := 2013 (Limited_Controlled with 2014 Container => V, 2015 Index => No_Index) 2016 do 2017 Busy (Container.TC'Unrestricted_Access.all); 2018 end return; 2019 end Iterate; 2020 2021 function Iterate 2022 (Container : Vector; 2023 Start : Cursor) 2024 return Vector_Iterator_Interfaces.Reversible_Iterator'Class 2025 is 2026 V : constant Vector_Access := Container'Unrestricted_Access; 2027 begin 2028 -- It was formerly the case that when Start = No_Element, the partial 2029 -- iterator was defined to behave the same as for a complete iterator, 2030 -- and iterate over the entire sequence of items. However, those 2031 -- semantics were unintuitive and arguably error-prone (it is too easy 2032 -- to accidentally create an endless loop), and so they were changed, 2033 -- per the ARG meeting in Denver on 2011/11. However, there was no 2034 -- consensus about what positive meaning this corner case should have, 2035 -- and so it was decided to simply raise an exception. This does imply, 2036 -- however, that it is not possible to use a partial iterator to specify 2037 -- an empty sequence of items. 2038 2039 if Checks then 2040 if Start.Container = null then 2041 raise Constraint_Error with 2042 "Start position for iterator equals No_Element"; 2043 end if; 2044 2045 if Start.Container /= V then 2046 raise Program_Error with 2047 "Start cursor of Iterate designates wrong vector"; 2048 end if; 2049 2050 if Start.Index > V.Last then 2051 raise Constraint_Error with 2052 "Start position for iterator equals No_Element"; 2053 end if; 2054 end if; 2055 2056 -- The value of its Index component influences the behavior of the First 2057 -- and Last selector functions of the iterator object. When the Index 2058 -- component is not No_Index (as is the case here), it means that this 2059 -- is a partial iteration, over a subset of the complete sequence of 2060 -- items. The iterator object was constructed with a start expression, 2061 -- indicating the position from which the iteration begins. Note that 2062 -- the start position has the same value irrespective of whether this 2063 -- is a forward or reverse iteration. 2064 2065 return It : constant Iterator := 2066 (Limited_Controlled with 2067 Container => V, 2068 Index => Start.Index) 2069 do 2070 Busy (Container.TC'Unrestricted_Access.all); 2071 end return; 2072 end Iterate; 2073 2074 ---------- 2075 -- Last -- 2076 ---------- 2077 2078 function Last (Container : Vector) return Cursor is 2079 begin 2080 if Is_Empty (Container) then 2081 return No_Element; 2082 else 2083 return (Container'Unrestricted_Access, Container.Last); 2084 end if; 2085 end Last; 2086 2087 function Last (Object : Iterator) return Cursor is 2088 begin 2089 -- The value of the iterator object's Index component influences the 2090 -- behavior of the Last (and First) selector function. 2091 2092 -- When the Index component is No_Index, this means the iterator 2093 -- object was constructed without a start expression, in which case the 2094 -- (reverse) iteration starts from the (logical) beginning of the entire 2095 -- sequence (corresponding to Container.Last, for a reverse iterator). 2096 2097 -- Otherwise, this is iteration over a partial sequence of items. 2098 -- When the Index component is not No_Index, the iterator object was 2099 -- constructed with a start expression, that specifies the position 2100 -- from which the (reverse) partial iteration begins. 2101 2102 if Object.Index = No_Index then 2103 return Last (Object.Container.all); 2104 else 2105 return Cursor'(Object.Container, Object.Index); 2106 end if; 2107 end Last; 2108 2109 ------------------ 2110 -- Last_Element -- 2111 ------------------ 2112 2113 function Last_Element (Container : Vector) return Element_Type is 2114 begin 2115 if Checks and then Container.Last = No_Index then 2116 raise Constraint_Error with "Container is empty"; 2117 else 2118 return Container.Elements.EA (Container.Last); 2119 end if; 2120 end Last_Element; 2121 2122 ---------------- 2123 -- Last_Index -- 2124 ---------------- 2125 2126 function Last_Index (Container : Vector) return Extended_Index is 2127 begin 2128 return Container.Last; 2129 end Last_Index; 2130 2131 ------------ 2132 -- Length -- 2133 ------------ 2134 2135 function Length (Container : Vector) return Count_Type is 2136 L : constant Index_Type'Base := Container.Last; 2137 F : constant Index_Type := Index_Type'First; 2138 2139 begin 2140 -- The base range of the index type (Index_Type'Base) might not include 2141 -- all values for length (Count_Type). Contrariwise, the index type 2142 -- might include values outside the range of length. Hence we use 2143 -- whatever type is wider for intermediate values when calculating 2144 -- length. Note that no matter what the index type is, the maximum 2145 -- length to which a vector is allowed to grow is always the minimum 2146 -- of Count_Type'Last and (IT'Last - IT'First + 1). 2147 2148 -- For example, an Index_Type with range -127 .. 127 is only guaranteed 2149 -- to have a base range of -128 .. 127, but the corresponding vector 2150 -- would have lengths in the range 0 .. 255. In this case we would need 2151 -- to use Count_Type'Base for intermediate values. 2152 2153 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The 2154 -- vector would have a maximum length of 10, but the index values lie 2155 -- outside the range of Count_Type (which is only 32 bits). In this 2156 -- case we would need to use Index_Type'Base for intermediate values. 2157 2158 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then 2159 return Count_Type'Base (L) - Count_Type'Base (F) + 1; 2160 else 2161 return Count_Type (L - F + 1); 2162 end if; 2163 end Length; 2164 2165 ---------- 2166 -- Move -- 2167 ---------- 2168 2169 procedure Move 2170 (Target : in out Vector; 2171 Source : in out Vector) 2172 is 2173 begin 2174 if Target'Address = Source'Address then 2175 return; 2176 end if; 2177 2178 TC_Check (Target.TC); 2179 TC_Check (Source.TC); 2180 2181 declare 2182 Target_Elements : constant Elements_Access := Target.Elements; 2183 begin 2184 Target.Elements := Source.Elements; 2185 Source.Elements := Target_Elements; 2186 end; 2187 2188 Target.Last := Source.Last; 2189 Source.Last := No_Index; 2190 end Move; 2191 2192 ---------- 2193 -- Next -- 2194 ---------- 2195 2196 function Next (Position : Cursor) return Cursor is 2197 begin 2198 if Position.Container = null then 2199 return No_Element; 2200 elsif Position.Index < Position.Container.Last then 2201 return (Position.Container, Position.Index + 1); 2202 else 2203 return No_Element; 2204 end if; 2205 end Next; 2206 2207 function Next (Object : Iterator; Position : Cursor) return Cursor is 2208 begin 2209 if Position.Container = null then 2210 return No_Element; 2211 elsif Checks and then Position.Container /= Object.Container then 2212 raise Program_Error with 2213 "Position cursor of Next designates wrong vector"; 2214 else 2215 return Next (Position); 2216 end if; 2217 end Next; 2218 2219 procedure Next (Position : in out Cursor) is 2220 begin 2221 if Position.Container = null then 2222 return; 2223 elsif Position.Index < Position.Container.Last then 2224 Position.Index := Position.Index + 1; 2225 else 2226 Position := No_Element; 2227 end if; 2228 end Next; 2229 2230 ------------- 2231 -- Prepend -- 2232 ------------- 2233 2234 procedure Prepend (Container : in out Vector; New_Item : Vector) is 2235 begin 2236 Insert (Container, Index_Type'First, New_Item); 2237 end Prepend; 2238 2239 procedure Prepend 2240 (Container : in out Vector; 2241 New_Item : Element_Type; 2242 Count : Count_Type := 1) 2243 is 2244 begin 2245 Insert (Container, Index_Type'First, New_Item, Count); 2246 end Prepend; 2247 2248 -------------- 2249 -- Previous -- 2250 -------------- 2251 2252 function Previous (Position : Cursor) return Cursor is 2253 begin 2254 if Position.Container = null then 2255 return No_Element; 2256 elsif Position.Index > Index_Type'First then 2257 return (Position.Container, Position.Index - 1); 2258 else 2259 return No_Element; 2260 end if; 2261 end Previous; 2262 2263 function Previous (Object : Iterator; Position : Cursor) return Cursor is 2264 begin 2265 if Position.Container = null then 2266 return No_Element; 2267 elsif Checks and then Position.Container /= Object.Container then 2268 raise Program_Error with 2269 "Position cursor of Previous designates wrong vector"; 2270 else 2271 return Previous (Position); 2272 end if; 2273 end Previous; 2274 2275 procedure Previous (Position : in out Cursor) is 2276 begin 2277 if Position.Container = null then 2278 return; 2279 elsif Position.Index > Index_Type'First then 2280 Position.Index := Position.Index - 1; 2281 else 2282 Position := No_Element; 2283 end if; 2284 end Previous; 2285 2286 ---------------------- 2287 -- Pseudo_Reference -- 2288 ---------------------- 2289 2290 function Pseudo_Reference 2291 (Container : aliased Vector'Class) return Reference_Control_Type 2292 is 2293 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; 2294 begin 2295 return R : constant Reference_Control_Type := (Controlled with TC) do 2296 Lock (TC.all); 2297 end return; 2298 end Pseudo_Reference; 2299 2300 ------------------- 2301 -- Query_Element -- 2302 ------------------- 2303 2304 procedure Query_Element 2305 (Container : Vector; 2306 Index : Index_Type; 2307 Process : not null access procedure (Element : Element_Type)) 2308 is 2309 Lock : With_Lock (Container.TC'Unrestricted_Access); 2310 begin 2311 if Checks and then Index > Container.Last then 2312 raise Constraint_Error with "Index is out of range"; 2313 end if; 2314 2315 Process (Container.Elements.EA (Index)); 2316 end Query_Element; 2317 2318 procedure Query_Element 2319 (Position : Cursor; 2320 Process : not null access procedure (Element : Element_Type)) 2321 is 2322 begin 2323 if Checks and then Position.Container = null then 2324 raise Constraint_Error with "Position cursor has no element"; 2325 else 2326 Query_Element (Position.Container.all, Position.Index, Process); 2327 end if; 2328 end Query_Element; 2329 2330 ---------- 2331 -- Read -- 2332 ---------- 2333 2334 procedure Read 2335 (Stream : not null access Root_Stream_Type'Class; 2336 Container : out Vector) 2337 is 2338 Length : Count_Type'Base; 2339 Last : Index_Type'Base := No_Index; 2340 2341 begin 2342 Clear (Container); 2343 2344 Count_Type'Base'Read (Stream, Length); 2345 2346 if Length > Capacity (Container) then 2347 Reserve_Capacity (Container, Capacity => Length); 2348 end if; 2349 2350 for J in Count_Type range 1 .. Length loop 2351 Last := Last + 1; 2352 Element_Type'Read (Stream, Container.Elements.EA (Last)); 2353 Container.Last := Last; 2354 end loop; 2355 end Read; 2356 2357 procedure Read 2358 (Stream : not null access Root_Stream_Type'Class; 2359 Position : out Cursor) 2360 is 2361 begin 2362 raise Program_Error with "attempt to stream vector cursor"; 2363 end Read; 2364 2365 procedure Read 2366 (Stream : not null access Root_Stream_Type'Class; 2367 Item : out Reference_Type) 2368 is 2369 begin 2370 raise Program_Error with "attempt to stream reference"; 2371 end Read; 2372 2373 procedure Read 2374 (Stream : not null access Root_Stream_Type'Class; 2375 Item : out Constant_Reference_Type) 2376 is 2377 begin 2378 raise Program_Error with "attempt to stream reference"; 2379 end Read; 2380 2381 --------------- 2382 -- Reference -- 2383 --------------- 2384 2385 function Reference 2386 (Container : aliased in out Vector; 2387 Position : Cursor) return Reference_Type 2388 is 2389 begin 2390 if Checks then 2391 if Position.Container = null then 2392 raise Constraint_Error with "Position cursor has no element"; 2393 end if; 2394 2395 if Position.Container /= Container'Unrestricted_Access then 2396 raise Program_Error with "Position cursor denotes wrong container"; 2397 end if; 2398 2399 if Position.Index > Position.Container.Last then 2400 raise Constraint_Error with "Position cursor is out of range"; 2401 end if; 2402 end if; 2403 2404 declare 2405 TC : constant Tamper_Counts_Access := 2406 Container.TC'Unrestricted_Access; 2407 begin 2408 return R : constant Reference_Type := 2409 (Element => Container.Elements.EA (Position.Index)'Access, 2410 Control => (Controlled with TC)) 2411 do 2412 Lock (TC.all); 2413 end return; 2414 end; 2415 end Reference; 2416 2417 function Reference 2418 (Container : aliased in out Vector; 2419 Index : Index_Type) return Reference_Type 2420 is 2421 begin 2422 if Checks and then Index > Container.Last then 2423 raise Constraint_Error with "Index is out of range"; 2424 end if; 2425 2426 declare 2427 TC : constant Tamper_Counts_Access := 2428 Container.TC'Unrestricted_Access; 2429 begin 2430 return R : constant Reference_Type := 2431 (Element => Container.Elements.EA (Index)'Access, 2432 Control => (Controlled with TC)) 2433 do 2434 Lock (TC.all); 2435 end return; 2436 end; 2437 end Reference; 2438 2439 --------------------- 2440 -- Replace_Element -- 2441 --------------------- 2442 2443 procedure Replace_Element 2444 (Container : in out Vector; 2445 Index : Index_Type; 2446 New_Item : Element_Type) 2447 is 2448 begin 2449 if Checks and then Index > Container.Last then 2450 raise Constraint_Error with "Index is out of range"; 2451 end if; 2452 2453 TE_Check (Container.TC); 2454 Container.Elements.EA (Index) := New_Item; 2455 end Replace_Element; 2456 2457 procedure Replace_Element 2458 (Container : in out Vector; 2459 Position : Cursor; 2460 New_Item : Element_Type) 2461 is 2462 begin 2463 if Checks then 2464 if Position.Container = null then 2465 raise Constraint_Error with "Position cursor has no element"; 2466 2467 elsif Position.Container /= Container'Unrestricted_Access then 2468 raise Program_Error with "Position cursor denotes wrong container"; 2469 2470 elsif Position.Index > Container.Last then 2471 raise Constraint_Error with "Position cursor is out of range"; 2472 end if; 2473 end if; 2474 2475 TE_Check (Container.TC); 2476 Container.Elements.EA (Position.Index) := New_Item; 2477 end Replace_Element; 2478 2479 ---------------------- 2480 -- Reserve_Capacity -- 2481 ---------------------- 2482 2483 procedure Reserve_Capacity 2484 (Container : in out Vector; 2485 Capacity : Count_Type) 2486 is 2487 N : constant Count_Type := Length (Container); 2488 2489 Index : Count_Type'Base; 2490 Last : Index_Type'Base; 2491 2492 begin 2493 -- Reserve_Capacity can be used to either expand the storage available 2494 -- for elements (this would be its typical use, in anticipation of 2495 -- future insertion), or to trim back storage. In the latter case, 2496 -- storage can only be trimmed back to the limit of the container 2497 -- length. Note that Reserve_Capacity neither deletes (active) elements 2498 -- nor inserts elements; it only affects container capacity, never 2499 -- container length. 2500 2501 if Capacity = 0 then 2502 2503 -- This is a request to trim back storage, to the minimum amount 2504 -- possible given the current state of the container. 2505 2506 if N = 0 then 2507 2508 -- The container is empty, so in this unique case we can 2509 -- deallocate the entire internal array. Note that an empty 2510 -- container can never be busy, so there's no need to check the 2511 -- tampering bits. 2512 2513 declare 2514 X : Elements_Access := Container.Elements; 2515 2516 begin 2517 -- First we remove the internal array from the container, to 2518 -- handle the case when the deallocation raises an exception. 2519 2520 Container.Elements := null; 2521 2522 -- Container invariants have been restored, so it is now safe 2523 -- to attempt to deallocate the internal array. 2524 2525 Free (X); 2526 end; 2527 2528 elsif N < Container.Elements.EA'Length then 2529 2530 -- The container is not empty, and the current length is less than 2531 -- the current capacity, so there's storage available to trim. In 2532 -- this case, we allocate a new internal array having a length 2533 -- that exactly matches the number of items in the 2534 -- container. (Reserve_Capacity does not delete active elements, 2535 -- so this is the best we can do with respect to minimizing 2536 -- storage). 2537 2538 TC_Check (Container.TC); 2539 2540 declare 2541 subtype Src_Index_Subtype is Index_Type'Base range 2542 Index_Type'First .. Container.Last; 2543 2544 Src : Elements_Array renames 2545 Container.Elements.EA (Src_Index_Subtype); 2546 2547 X : Elements_Access := Container.Elements; 2548 2549 begin 2550 -- Although we have isolated the old internal array that we're 2551 -- going to deallocate, we don't deallocate it until we have 2552 -- successfully allocated a new one. If there is an exception 2553 -- during allocation (either because there is not enough 2554 -- storage, or because initialization of the elements fails), 2555 -- we let it propagate without causing any side-effect. 2556 2557 Container.Elements := new Elements_Type'(Container.Last, Src); 2558 2559 -- We have successfully allocated a new internal array (with a 2560 -- smaller length than the old one, and containing a copy of 2561 -- just the active elements in the container), so it is now 2562 -- safe to attempt to deallocate the old array. The old array 2563 -- has been isolated, and container invariants have been 2564 -- restored, so if the deallocation fails (because finalization 2565 -- of the elements fails), we simply let it propagate. 2566 2567 Free (X); 2568 end; 2569 end if; 2570 2571 return; 2572 end if; 2573 2574 -- Reserve_Capacity can be used to expand the storage available for 2575 -- elements, but we do not let the capacity grow beyond the number of 2576 -- values in Index_Type'Range. (Were it otherwise, there would be no way 2577 -- to refer to the elements with an index value greater than 2578 -- Index_Type'Last, so that storage would be wasted.) Here we compute 2579 -- the Last index value of the new internal array, in a way that avoids 2580 -- any possibility of overflow. 2581 2582 if Index_Type'Base'Last >= Count_Type_Last then 2583 2584 -- We perform a two-part test. First we determine whether the 2585 -- computed Last value lies in the base range of the type, and then 2586 -- determine whether it lies in the range of the index (sub)type. 2587 2588 -- Last must satisfy this relation: 2589 -- First + Length - 1 <= Last 2590 -- We regroup terms: 2591 -- First - 1 <= Last - Length 2592 -- Which can rewrite as: 2593 -- No_Index <= Last - Length 2594 2595 if Checks and then 2596 Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index 2597 then 2598 raise Constraint_Error with "Capacity is out of range"; 2599 end if; 2600 2601 -- We now know that the computed value of Last is within the base 2602 -- range of the type, so it is safe to compute its value: 2603 2604 Last := No_Index + Index_Type'Base (Capacity); 2605 2606 -- Finally we test whether the value is within the range of the 2607 -- generic actual index subtype: 2608 2609 if Checks and then Last > Index_Type'Last then 2610 raise Constraint_Error with "Capacity is out of range"; 2611 end if; 2612 2613 elsif Index_Type'First <= 0 then 2614 2615 -- Here we can compute Last directly, in the normal way. We know that 2616 -- No_Index is less than 0, so there is no danger of overflow when 2617 -- adding the (positive) value of Capacity. 2618 2619 Index := Count_Type'Base (No_Index) + Capacity; -- Last 2620 2621 if Checks and then Index > Count_Type'Base (Index_Type'Last) then 2622 raise Constraint_Error with "Capacity is out of range"; 2623 end if; 2624 2625 -- We know that the computed value (having type Count_Type) of Last 2626 -- is within the range of the generic actual index subtype, so it is 2627 -- safe to convert to Index_Type: 2628 2629 Last := Index_Type'Base (Index); 2630 2631 else 2632 -- Here Index_Type'First (and Index_Type'Last) is positive, so we 2633 -- must test the length indirectly (by working backwards from the 2634 -- largest possible value of Last), in order to prevent overflow. 2635 2636 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index 2637 2638 if Checks and then Index < Count_Type'Base (No_Index) then 2639 raise Constraint_Error with "Capacity is out of range"; 2640 end if; 2641 2642 -- We have determined that the value of Capacity would not create a 2643 -- Last index value outside of the range of Index_Type, so we can now 2644 -- safely compute its value. 2645 2646 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); 2647 end if; 2648 2649 -- The requested capacity is non-zero, but we don't know yet whether 2650 -- this is a request for expansion or contraction of storage. 2651 2652 if Container.Elements = null then 2653 2654 -- The container is empty (it doesn't even have an internal array), 2655 -- so this represents a request to allocate (expand) storage having 2656 -- the given capacity. 2657 2658 Container.Elements := new Elements_Type (Last); 2659 return; 2660 end if; 2661 2662 if Capacity <= N then 2663 2664 -- This is a request to trim back storage, but only to the limit of 2665 -- what's already in the container. (Reserve_Capacity never deletes 2666 -- active elements, it only reclaims excess storage.) 2667 2668 if N < Container.Elements.EA'Length then 2669 2670 -- The container is not empty (because the requested capacity is 2671 -- positive, and less than or equal to the container length), and 2672 -- the current length is less than the current capacity, so 2673 -- there's storage available to trim. In this case, we allocate a 2674 -- new internal array having a length that exactly matches the 2675 -- number of items in the container. 2676 2677 TC_Check (Container.TC); 2678 2679 declare 2680 subtype Src_Index_Subtype is Index_Type'Base range 2681 Index_Type'First .. Container.Last; 2682 2683 Src : Elements_Array renames 2684 Container.Elements.EA (Src_Index_Subtype); 2685 2686 X : Elements_Access := Container.Elements; 2687 2688 begin 2689 -- Although we have isolated the old internal array that we're 2690 -- going to deallocate, we don't deallocate it until we have 2691 -- successfully allocated a new one. If there is an exception 2692 -- during allocation (either because there is not enough 2693 -- storage, or because initialization of the elements fails), 2694 -- we let it propagate without causing any side-effect. 2695 2696 Container.Elements := new Elements_Type'(Container.Last, Src); 2697 2698 -- We have successfully allocated a new internal array (with a 2699 -- smaller length than the old one, and containing a copy of 2700 -- just the active elements in the container), so it is now 2701 -- safe to attempt to deallocate the old array. The old array 2702 -- has been isolated, and container invariants have been 2703 -- restored, so if the deallocation fails (because finalization 2704 -- of the elements fails), we simply let it propagate. 2705 2706 Free (X); 2707 end; 2708 end if; 2709 2710 return; 2711 end if; 2712 2713 -- The requested capacity is larger than the container length (the 2714 -- number of active elements). Whether this represents a request for 2715 -- expansion or contraction of the current capacity depends on what the 2716 -- current capacity is. 2717 2718 if Capacity = Container.Elements.EA'Length then 2719 2720 -- The requested capacity matches the existing capacity, so there's 2721 -- nothing to do here. We treat this case as a no-op, and simply 2722 -- return without checking the busy bit. 2723 2724 return; 2725 end if; 2726 2727 -- There is a change in the capacity of a non-empty container, so a new 2728 -- internal array will be allocated. (The length of the new internal 2729 -- array could be less or greater than the old internal array. We know 2730 -- only that the length of the new internal array is greater than the 2731 -- number of active elements in the container.) We must check whether 2732 -- the container is busy before doing anything else. 2733 2734 TC_Check (Container.TC); 2735 2736 -- We now allocate a new internal array, having a length different from 2737 -- its current value. 2738 2739 declare 2740 E : Elements_Access := new Elements_Type (Last); 2741 2742 begin 2743 -- We have successfully allocated the new internal array. We first 2744 -- attempt to copy the existing elements from the old internal array 2745 -- ("src" elements) onto the new internal array ("tgt" elements). 2746 2747 declare 2748 subtype Index_Subtype is Index_Type'Base range 2749 Index_Type'First .. Container.Last; 2750 2751 Src : Elements_Array renames 2752 Container.Elements.EA (Index_Subtype); 2753 2754 Tgt : Elements_Array renames E.EA (Index_Subtype); 2755 2756 begin 2757 Tgt := Src; 2758 2759 exception 2760 when others => 2761 Free (E); 2762 raise; 2763 end; 2764 2765 -- We have successfully copied the existing elements onto the new 2766 -- internal array, so now we can attempt to deallocate the old one. 2767 2768 declare 2769 X : Elements_Access := Container.Elements; 2770 2771 begin 2772 -- First we isolate the old internal array, and replace it in the 2773 -- container with the new internal array. 2774 2775 Container.Elements := E; 2776 2777 -- Container invariants have been restored, so it is now safe to 2778 -- attempt to deallocate the old internal array. 2779 2780 Free (X); 2781 end; 2782 end; 2783 end Reserve_Capacity; 2784 2785 ---------------------- 2786 -- Reverse_Elements -- 2787 ---------------------- 2788 2789 procedure Reverse_Elements (Container : in out Vector) is 2790 begin 2791 if Container.Length <= 1 then 2792 return; 2793 end if; 2794 2795 -- The exception behavior for the vector container must match that for 2796 -- the list container, so we check for cursor tampering here (which will 2797 -- catch more things) instead of for element tampering (which will catch 2798 -- fewer things). It's true that the elements of this vector container 2799 -- could be safely moved around while (say) an iteration is taking place 2800 -- (iteration only increments the busy counter), and so technically 2801 -- all we would need here is a test for element tampering (indicated 2802 -- by the lock counter), that's simply an artifact of our array-based 2803 -- implementation. Logically Reverse_Elements requires a check for 2804 -- cursor tampering. 2805 2806 TC_Check (Container.TC); 2807 2808 declare 2809 K : Index_Type; 2810 J : Index_Type; 2811 E : Elements_Type renames Container.Elements.all; 2812 2813 begin 2814 K := Index_Type'First; 2815 J := Container.Last; 2816 while K < J loop 2817 declare 2818 EK : constant Element_Type := E.EA (K); 2819 begin 2820 E.EA (K) := E.EA (J); 2821 E.EA (J) := EK; 2822 end; 2823 2824 K := K + 1; 2825 J := J - 1; 2826 end loop; 2827 end; 2828 end Reverse_Elements; 2829 2830 ------------------ 2831 -- Reverse_Find -- 2832 ------------------ 2833 2834 function Reverse_Find 2835 (Container : Vector; 2836 Item : Element_Type; 2837 Position : Cursor := No_Element) return Cursor 2838 is 2839 Last : Index_Type'Base; 2840 2841 begin 2842 if Checks and then Position.Container /= null 2843 and then Position.Container /= Container'Unrestricted_Access 2844 then 2845 raise Program_Error with "Position cursor denotes wrong container"; 2846 end if; 2847 2848 Last := 2849 (if Position.Container = null or else Position.Index > Container.Last 2850 then Container.Last 2851 else Position.Index); 2852 2853 -- Per AI05-0022, the container implementation is required to detect 2854 -- element tampering by a generic actual subprogram. 2855 2856 declare 2857 Lock : With_Lock (Container.TC'Unrestricted_Access); 2858 begin 2859 for Indx in reverse Index_Type'First .. Last loop 2860 if Container.Elements.EA (Indx) = Item then 2861 return Cursor'(Container'Unrestricted_Access, Indx); 2862 end if; 2863 end loop; 2864 2865 return No_Element; 2866 end; 2867 end Reverse_Find; 2868 2869 ------------------------ 2870 -- Reverse_Find_Index -- 2871 ------------------------ 2872 2873 function Reverse_Find_Index 2874 (Container : Vector; 2875 Item : Element_Type; 2876 Index : Index_Type := Index_Type'Last) return Extended_Index 2877 is 2878 -- Per AI05-0022, the container implementation is required to detect 2879 -- element tampering by a generic actual subprogram. 2880 2881 Lock : With_Lock (Container.TC'Unrestricted_Access); 2882 2883 Last : constant Index_Type'Base := 2884 Index_Type'Min (Container.Last, Index); 2885 2886 begin 2887 for Indx in reverse Index_Type'First .. Last loop 2888 if Container.Elements.EA (Indx) = Item then 2889 return Indx; 2890 end if; 2891 end loop; 2892 2893 return No_Index; 2894 end Reverse_Find_Index; 2895 2896 --------------------- 2897 -- Reverse_Iterate -- 2898 --------------------- 2899 2900 procedure Reverse_Iterate 2901 (Container : Vector; 2902 Process : not null access procedure (Position : Cursor)) 2903 is 2904 Busy : With_Busy (Container.TC'Unrestricted_Access); 2905 begin 2906 for Indx in reverse Index_Type'First .. Container.Last loop 2907 Process (Cursor'(Container'Unrestricted_Access, Indx)); 2908 end loop; 2909 end Reverse_Iterate; 2910 2911 ---------------- 2912 -- Set_Length -- 2913 ---------------- 2914 2915 procedure Set_Length (Container : in out Vector; Length : Count_Type) is 2916 Count : constant Count_Type'Base := Container.Length - Length; 2917 2918 begin 2919 -- Set_Length allows the user to set the length explicitly, instead 2920 -- of implicitly as a side-effect of deletion or insertion. If the 2921 -- requested length is less than the current length, this is equivalent 2922 -- to deleting items from the back end of the vector. If the requested 2923 -- length is greater than the current length, then this is equivalent 2924 -- to inserting "space" (nonce items) at the end. 2925 2926 if Count >= 0 then 2927 Container.Delete_Last (Count); 2928 2929 elsif Checks and then Container.Last >= Index_Type'Last then 2930 raise Constraint_Error with "vector is already at its maximum length"; 2931 2932 else 2933 Container.Insert_Space (Container.Last + 1, -Count); 2934 end if; 2935 end Set_Length; 2936 2937 ---------- 2938 -- Swap -- 2939 ---------- 2940 2941 procedure Swap (Container : in out Vector; I, J : Index_Type) is 2942 begin 2943 if Checks then 2944 if I > Container.Last then 2945 raise Constraint_Error with "I index is out of range"; 2946 end if; 2947 2948 if J > Container.Last then 2949 raise Constraint_Error with "J index is out of range"; 2950 end if; 2951 end if; 2952 2953 if I = J then 2954 return; 2955 end if; 2956 2957 TE_Check (Container.TC); 2958 2959 declare 2960 EI_Copy : constant Element_Type := Container.Elements.EA (I); 2961 begin 2962 Container.Elements.EA (I) := Container.Elements.EA (J); 2963 Container.Elements.EA (J) := EI_Copy; 2964 end; 2965 end Swap; 2966 2967 procedure Swap (Container : in out Vector; I, J : Cursor) is 2968 begin 2969 if Checks then 2970 if I.Container = null then 2971 raise Constraint_Error with "I cursor has no element"; 2972 2973 elsif J.Container = null then 2974 raise Constraint_Error with "J cursor has no element"; 2975 2976 elsif I.Container /= Container'Unrestricted_Access then 2977 raise Program_Error with "I cursor denotes wrong container"; 2978 2979 elsif J.Container /= Container'Unrestricted_Access then 2980 raise Program_Error with "J cursor denotes wrong container"; 2981 end if; 2982 end if; 2983 2984 Swap (Container, I.Index, J.Index); 2985 end Swap; 2986 2987 --------------- 2988 -- To_Cursor -- 2989 --------------- 2990 2991 function To_Cursor 2992 (Container : Vector; 2993 Index : Extended_Index) return Cursor 2994 is 2995 begin 2996 if Index not in Index_Type'First .. Container.Last then 2997 return No_Element; 2998 else 2999 return (Container'Unrestricted_Access, Index); 3000 end if; 3001 end To_Cursor; 3002 3003 -------------- 3004 -- To_Index -- 3005 -------------- 3006 3007 function To_Index (Position : Cursor) return Extended_Index is 3008 begin 3009 if Position.Container = null then 3010 return No_Index; 3011 elsif Position.Index <= Position.Container.Last then 3012 return Position.Index; 3013 else 3014 return No_Index; 3015 end if; 3016 end To_Index; 3017 3018 --------------- 3019 -- To_Vector -- 3020 --------------- 3021 3022 function To_Vector (Length : Count_Type) return Vector is 3023 Index : Count_Type'Base; 3024 Last : Index_Type'Base; 3025 Elements : Elements_Access; 3026 3027 begin 3028 if Length = 0 then 3029 return Empty_Vector; 3030 end if; 3031 3032 -- We create a vector object with a capacity that matches the specified 3033 -- Length, but we do not allow the vector capacity (the length of the 3034 -- internal array) to exceed the number of values in Index_Type'Range 3035 -- (otherwise, there would be no way to refer to those components via an 3036 -- index). We must therefore check whether the specified Length would 3037 -- create a Last index value greater than Index_Type'Last. 3038 3039 if Index_Type'Base'Last >= Count_Type_Last then 3040 3041 -- We perform a two-part test. First we determine whether the 3042 -- computed Last value lies in the base range of the type, and then 3043 -- determine whether it lies in the range of the index (sub)type. 3044 3045 -- Last must satisfy this relation: 3046 -- First + Length - 1 <= Last 3047 -- We regroup terms: 3048 -- First - 1 <= Last - Length 3049 -- Which can rewrite as: 3050 -- No_Index <= Last - Length 3051 3052 if Checks and then 3053 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index 3054 then 3055 raise Constraint_Error with "Length is out of range"; 3056 end if; 3057 3058 -- We now know that the computed value of Last is within the base 3059 -- range of the type, so it is safe to compute its value: 3060 3061 Last := No_Index + Index_Type'Base (Length); 3062 3063 -- Finally we test whether the value is within the range of the 3064 -- generic actual index subtype: 3065 3066 if Checks and then Last > Index_Type'Last then 3067 raise Constraint_Error with "Length is out of range"; 3068 end if; 3069 3070 elsif Index_Type'First <= 0 then 3071 3072 -- Here we can compute Last directly, in the normal way. We know that 3073 -- No_Index is less than 0, so there is no danger of overflow when 3074 -- adding the (positive) value of Length. 3075 3076 Index := Count_Type'Base (No_Index) + Length; -- Last 3077 3078 if Checks and then Index > Count_Type'Base (Index_Type'Last) then 3079 raise Constraint_Error with "Length is out of range"; 3080 end if; 3081 3082 -- We know that the computed value (having type Count_Type) of Last 3083 -- is within the range of the generic actual index subtype, so it is 3084 -- safe to convert to Index_Type: 3085 3086 Last := Index_Type'Base (Index); 3087 3088 else 3089 -- Here Index_Type'First (and Index_Type'Last) is positive, so we 3090 -- must test the length indirectly (by working backwards from the 3091 -- largest possible value of Last), in order to prevent overflow. 3092 3093 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index 3094 3095 if Checks and then Index < Count_Type'Base (No_Index) then 3096 raise Constraint_Error with "Length is out of range"; 3097 end if; 3098 3099 -- We have determined that the value of Length would not create a 3100 -- Last index value outside of the range of Index_Type, so we can now 3101 -- safely compute its value. 3102 3103 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); 3104 end if; 3105 3106 Elements := new Elements_Type (Last); 3107 3108 return Vector'(Controlled with Elements, Last, TC => <>); 3109 end To_Vector; 3110 3111 function To_Vector 3112 (New_Item : Element_Type; 3113 Length : Count_Type) return Vector 3114 is 3115 Index : Count_Type'Base; 3116 Last : Index_Type'Base; 3117 Elements : Elements_Access; 3118 3119 begin 3120 if Length = 0 then 3121 return Empty_Vector; 3122 end if; 3123 3124 -- We create a vector object with a capacity that matches the specified 3125 -- Length, but we do not allow the vector capacity (the length of the 3126 -- internal array) to exceed the number of values in Index_Type'Range 3127 -- (otherwise, there would be no way to refer to those components via an 3128 -- index). We must therefore check whether the specified Length would 3129 -- create a Last index value greater than Index_Type'Last. 3130 3131 if Index_Type'Base'Last >= Count_Type_Last then 3132 3133 -- We perform a two-part test. First we determine whether the 3134 -- computed Last value lies in the base range of the type, and then 3135 -- determine whether it lies in the range of the index (sub)type. 3136 3137 -- Last must satisfy this relation: 3138 -- First + Length - 1 <= Last 3139 -- We regroup terms: 3140 -- First - 1 <= Last - Length 3141 -- Which can rewrite as: 3142 -- No_Index <= Last - Length 3143 3144 if Checks and then 3145 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index 3146 then 3147 raise Constraint_Error with "Length is out of range"; 3148 end if; 3149 3150 -- We now know that the computed value of Last is within the base 3151 -- range of the type, so it is safe to compute its value: 3152 3153 Last := No_Index + Index_Type'Base (Length); 3154 3155 -- Finally we test whether the value is within the range of the 3156 -- generic actual index subtype: 3157 3158 if Checks and then Last > Index_Type'Last then 3159 raise Constraint_Error with "Length is out of range"; 3160 end if; 3161 3162 elsif Index_Type'First <= 0 then 3163 3164 -- Here we can compute Last directly, in the normal way. We know that 3165 -- No_Index is less than 0, so there is no danger of overflow when 3166 -- adding the (positive) value of Length. 3167 3168 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last 3169 3170 if Checks and then Index > Count_Type'Base (Index_Type'Last) then 3171 raise Constraint_Error with "Length is out of range"; 3172 end if; 3173 3174 -- We know that the computed value (having type Count_Type) of Last 3175 -- is within the range of the generic actual index subtype, so it is 3176 -- safe to convert to Index_Type: 3177 3178 Last := Index_Type'Base (Index); 3179 3180 else 3181 -- Here Index_Type'First (and Index_Type'Last) is positive, so we 3182 -- must test the length indirectly (by working backwards from the 3183 -- largest possible value of Last), in order to prevent overflow. 3184 3185 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index 3186 3187 if Checks and then Index < Count_Type'Base (No_Index) then 3188 raise Constraint_Error with "Length is out of range"; 3189 end if; 3190 3191 -- We have determined that the value of Length would not create a 3192 -- Last index value outside of the range of Index_Type, so we can now 3193 -- safely compute its value. 3194 3195 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); 3196 end if; 3197 3198 Elements := new Elements_Type'(Last, EA => (others => New_Item)); 3199 3200 return (Controlled with Elements, Last, TC => <>); 3201 end To_Vector; 3202 3203 -------------------- 3204 -- Update_Element -- 3205 -------------------- 3206 3207 procedure Update_Element 3208 (Container : in out Vector; 3209 Index : Index_Type; 3210 Process : not null access procedure (Element : in out Element_Type)) 3211 is 3212 Lock : With_Lock (Container.TC'Unchecked_Access); 3213 begin 3214 if Checks and then Index > Container.Last then 3215 raise Constraint_Error with "Index is out of range"; 3216 end if; 3217 3218 Process (Container.Elements.EA (Index)); 3219 end Update_Element; 3220 3221 procedure Update_Element 3222 (Container : in out Vector; 3223 Position : Cursor; 3224 Process : not null access procedure (Element : in out Element_Type)) 3225 is 3226 begin 3227 if Checks then 3228 if Position.Container = null then 3229 raise Constraint_Error with "Position cursor has no element"; 3230 elsif Position.Container /= Container'Unrestricted_Access then 3231 raise Program_Error with "Position cursor denotes wrong container"; 3232 end if; 3233 end if; 3234 3235 Update_Element (Container, Position.Index, Process); 3236 end Update_Element; 3237 3238 ----------- 3239 -- Write -- 3240 ----------- 3241 3242 procedure Write 3243 (Stream : not null access Root_Stream_Type'Class; 3244 Container : Vector) 3245 is 3246 begin 3247 Count_Type'Base'Write (Stream, Length (Container)); 3248 3249 for J in Index_Type'First .. Container.Last loop 3250 Element_Type'Write (Stream, Container.Elements.EA (J)); 3251 end loop; 3252 end Write; 3253 3254 procedure Write 3255 (Stream : not null access Root_Stream_Type'Class; 3256 Position : Cursor) 3257 is 3258 begin 3259 raise Program_Error with "attempt to stream vector cursor"; 3260 end Write; 3261 3262 procedure Write 3263 (Stream : not null access Root_Stream_Type'Class; 3264 Item : Reference_Type) 3265 is 3266 begin 3267 raise Program_Error with "attempt to stream reference"; 3268 end Write; 3269 3270 procedure Write 3271 (Stream : not null access Root_Stream_Type'Class; 3272 Item : Constant_Reference_Type) 3273 is 3274 begin 3275 raise Program_Error with "attempt to stream reference"; 3276 end Write; 3277 3278end Ada.Containers.Vectors; 3279