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-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Containers.Generic_Array_Sort; 31with Ada.Unchecked_Deallocation; 32 33with System; use type System.Address; 34 35package body Ada.Containers.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 pragma Warnings (Off); 621 pragma Assert (T_Check); -- not called if check suppressed 622 pragma Warnings (On); 623 begin 624 Unbusy (Object.Container.TC); 625 end Finalize; 626 627 ---------- 628 -- Find -- 629 ---------- 630 631 function Find 632 (Container : Vector; 633 Item : Element_Type; 634 Position : Cursor := No_Element) return Cursor 635 is 636 begin 637 if Checks and then Position.Container /= null then 638 if Position.Container /= Container'Unrestricted_Access then 639 raise Program_Error with "Position cursor denotes wrong container"; 640 end if; 641 642 if Position.Index > Container.Last then 643 raise Program_Error with "Position index is out of range"; 644 end if; 645 end if; 646 647 -- Per AI05-0022, the container implementation is required to detect 648 -- element tampering by a generic actual subprogram. 649 650 declare 651 Lock : With_Lock (Container.TC'Unrestricted_Access); 652 begin 653 for J in Position.Index .. Container.Last loop 654 if Container.Elements.EA (J) = Item then 655 return Cursor'(Container'Unrestricted_Access, J); 656 end if; 657 end loop; 658 659 return No_Element; 660 end; 661 end Find; 662 663 ---------------- 664 -- Find_Index -- 665 ---------------- 666 667 function Find_Index 668 (Container : Vector; 669 Item : Element_Type; 670 Index : Index_Type := Index_Type'First) return Extended_Index 671 is 672 -- Per AI05-0022, the container implementation is required to detect 673 -- element tampering by a generic actual subprogram. 674 675 Lock : With_Lock (Container.TC'Unrestricted_Access); 676 begin 677 for Indx in Index .. Container.Last loop 678 if Container.Elements.EA (Indx) = Item then 679 return Indx; 680 end if; 681 end loop; 682 683 return No_Index; 684 end Find_Index; 685 686 ----------- 687 -- First -- 688 ----------- 689 690 function First (Container : Vector) return Cursor is 691 begin 692 if Is_Empty (Container) then 693 return No_Element; 694 end if; 695 696 return (Container'Unrestricted_Access, Index_Type'First); 697 end First; 698 699 function First (Object : Iterator) return Cursor is 700 begin 701 -- The value of the iterator object's Index component influences the 702 -- behavior of the First (and Last) selector function. 703 704 -- When the Index component is No_Index, this means the iterator 705 -- object was constructed without a start expression, in which case the 706 -- (forward) iteration starts from the (logical) beginning of the entire 707 -- sequence of items (corresponding to Container.First, for a forward 708 -- iterator). 709 710 -- Otherwise, this is iteration over a partial sequence of items. 711 -- When the Index component isn't No_Index, the iterator object was 712 -- constructed with a start expression, that specifies the position 713 -- from which the (forward) partial iteration begins. 714 715 if Object.Index = No_Index then 716 return First (Object.Container.all); 717 else 718 return Cursor'(Object.Container, Object.Index); 719 end if; 720 end First; 721 722 ------------------- 723 -- First_Element -- 724 ------------------- 725 726 function First_Element (Container : Vector) return Element_Type is 727 begin 728 if Checks and then Container.Last = No_Index then 729 raise Constraint_Error with "Container is empty"; 730 else 731 return Container.Elements.EA (Index_Type'First); 732 end if; 733 end First_Element; 734 735 ----------------- 736 -- First_Index -- 737 ----------------- 738 739 function First_Index (Container : Vector) return Index_Type is 740 pragma Unreferenced (Container); 741 begin 742 return Index_Type'First; 743 end First_Index; 744 745 --------------------- 746 -- Generic_Sorting -- 747 --------------------- 748 749 package body Generic_Sorting is 750 751 --------------- 752 -- Is_Sorted -- 753 --------------- 754 755 function Is_Sorted (Container : Vector) return Boolean is 756 begin 757 if Container.Last <= Index_Type'First then 758 return True; 759 end if; 760 761 -- Per AI05-0022, the container implementation is required to detect 762 -- element tampering by a generic actual subprogram. 763 764 declare 765 Lock : With_Lock (Container.TC'Unrestricted_Access); 766 EA : Elements_Array renames Container.Elements.EA; 767 begin 768 for J in Index_Type'First .. Container.Last - 1 loop 769 if EA (J + 1) < EA (J) then 770 return False; 771 end if; 772 end loop; 773 774 return True; 775 end; 776 end Is_Sorted; 777 778 ----------- 779 -- Merge -- 780 ----------- 781 782 procedure Merge (Target, Source : in out Vector) is 783 I : Index_Type'Base := Target.Last; 784 J : Index_Type'Base; 785 786 begin 787 -- The semantics of Merge changed slightly per AI05-0021. It was 788 -- originally the case that if Target and Source denoted the same 789 -- container object, then the GNAT implementation of Merge did 790 -- nothing. However, it was argued that RM05 did not precisely 791 -- specify the semantics for this corner case. The decision of the 792 -- ARG was that if Target and Source denote the same non-empty 793 -- container object, then Program_Error is raised. 794 795 if Source.Last < Index_Type'First then -- Source is empty 796 return; 797 end if; 798 799 if Checks and then Target'Address = Source'Address then 800 raise Program_Error with 801 "Target and Source denote same non-empty container"; 802 end if; 803 804 if Target.Last < Index_Type'First then -- Target is empty 805 Move (Target => Target, Source => Source); 806 return; 807 end if; 808 809 TC_Check (Source.TC); 810 811 Target.Set_Length (Length (Target) + Length (Source)); 812 813 -- Per AI05-0022, the container implementation is required to detect 814 -- element tampering by a generic actual subprogram. 815 816 declare 817 TA : Elements_Array renames Target.Elements.EA; 818 SA : Elements_Array renames Source.Elements.EA; 819 820 Lock_Target : With_Lock (Target.TC'Unchecked_Access); 821 Lock_Source : With_Lock (Source.TC'Unchecked_Access); 822 begin 823 J := Target.Last; 824 while Source.Last >= Index_Type'First loop 825 pragma Assert (Source.Last <= Index_Type'First 826 or else not (SA (Source.Last) < 827 SA (Source.Last - 1))); 828 829 if I < Index_Type'First then 830 TA (Index_Type'First .. J) := 831 SA (Index_Type'First .. Source.Last); 832 833 Source.Last := No_Index; 834 exit; 835 end if; 836 837 pragma Assert (I <= Index_Type'First 838 or else not (TA (I) < TA (I - 1))); 839 840 if SA (Source.Last) < TA (I) then 841 TA (J) := TA (I); 842 I := I - 1; 843 844 else 845 TA (J) := SA (Source.Last); 846 Source.Last := Source.Last - 1; 847 end if; 848 849 J := J - 1; 850 end loop; 851 end; 852 end Merge; 853 854 ---------- 855 -- Sort -- 856 ---------- 857 858 procedure Sort (Container : in out Vector) is 859 procedure Sort is 860 new Generic_Array_Sort 861 (Index_Type => Index_Type, 862 Element_Type => Element_Type, 863 Array_Type => Elements_Array, 864 "<" => "<"); 865 866 begin 867 if Container.Last <= Index_Type'First then 868 return; 869 end if; 870 871 -- The exception behavior for the vector container must match that 872 -- for the list container, so we check for cursor tampering here 873 -- (which will catch more things) instead of for element tampering 874 -- (which will catch fewer things). It's true that the elements of 875 -- this vector container could be safely moved around while (say) an 876 -- iteration is taking place (iteration only increments the busy 877 -- counter), and so technically all we would need here is a test for 878 -- element tampering (indicated by the lock counter), that's simply 879 -- an artifact of our array-based implementation. Logically Sort 880 -- requires a check for cursor tampering. 881 882 TC_Check (Container.TC); 883 884 -- Per AI05-0022, the container implementation is required to detect 885 -- element tampering by a generic actual subprogram. 886 887 declare 888 Lock : With_Lock (Container.TC'Unchecked_Access); 889 begin 890 Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); 891 end; 892 end Sort; 893 894 end Generic_Sorting; 895 896 ------------------------ 897 -- Get_Element_Access -- 898 ------------------------ 899 900 function Get_Element_Access 901 (Position : Cursor) return not null Element_Access is 902 begin 903 return Position.Container.Elements.EA (Position.Index)'Access; 904 end Get_Element_Access; 905 906 ----------------- 907 -- Has_Element -- 908 ----------------- 909 910 function Has_Element (Position : Cursor) return Boolean is 911 begin 912 return Position /= No_Element; 913 end Has_Element; 914 915 ------------ 916 -- Insert -- 917 ------------ 918 919 procedure Insert 920 (Container : in out Vector; 921 Before : Extended_Index; 922 New_Item : Element_Type; 923 Count : Count_Type := 1) 924 is 925 Old_Length : constant Count_Type := Container.Length; 926 927 Max_Length : Count_Type'Base; -- determined from range of Index_Type 928 New_Length : Count_Type'Base; -- sum of current length and Count 929 New_Last : Index_Type'Base; -- last index of vector after insertion 930 931 Index : Index_Type'Base; -- scratch for intermediate values 932 J : Count_Type'Base; -- scratch 933 934 New_Capacity : Count_Type'Base; -- length of new, expanded array 935 Dst_Last : Index_Type'Base; -- last index of new, expanded array 936 Dst : Elements_Access; -- new, expanded internal array 937 938 begin 939 if Checks then 940 -- As a precondition on the generic actual Index_Type, the base type 941 -- must include Index_Type'Pred (Index_Type'First); this is the value 942 -- that Container.Last assumes when the vector is empty. However, we 943 -- do not allow that as the value for Index when specifying where the 944 -- new items should be inserted, so we must manually check. (That the 945 -- user is allowed to specify the value at all here is a consequence 946 -- of the declaration of the Extended_Index subtype, which includes 947 -- the values in the base range that immediately precede and 948 -- immediately follow the values in the Index_Type.) 949 950 if Before < Index_Type'First then 951 raise Constraint_Error with 952 "Before index is out of range (too small)"; 953 end if; 954 955 -- We do allow a value greater than Container.Last to be specified as 956 -- the Index, but only if it's immediately greater. This allows for 957 -- the case of appending items to the back end of the vector. (It is 958 -- assumed that specifying an index value greater than Last + 1 959 -- indicates some deeper flaw in the caller's algorithm, so that case 960 -- is treated as a proper error.) 961 962 if Before > Container.Last + 1 then 963 raise Constraint_Error with 964 "Before index is out of range (too large)"; 965 end if; 966 end if; 967 968 -- We treat inserting 0 items into the container as a no-op, even when 969 -- the container is busy, so we simply return. 970 971 if Count = 0 then 972 return; 973 end if; 974 975 -- There are two constraints we need to satisfy. The first constraint is 976 -- that a container cannot have more than Count_Type'Last elements, so 977 -- we must check the sum of the current length and the insertion count. 978 -- Note: we cannot simply add these values, because of the possibility 979 -- of overflow. 980 981 if Checks and then Old_Length > Count_Type'Last - Count then 982 raise Constraint_Error with "Count is out of range"; 983 end if; 984 985 -- It is now safe compute the length of the new vector, without fear of 986 -- overflow. 987 988 New_Length := Old_Length + Count; 989 990 -- The second constraint is that the new Last index value cannot exceed 991 -- Index_Type'Last. In each branch below, we calculate the maximum 992 -- length (computed from the range of values in Index_Type), and then 993 -- compare the new length to the maximum length. If the new length is 994 -- acceptable, then we compute the new last index from that. 995 996 if Index_Type'Base'Last >= Count_Type_Last then 997 998 -- We have to handle the case when there might be more values in the 999 -- range of Index_Type than in the range of Count_Type. 1000 1001 if Index_Type'First <= 0 then 1002 1003 -- We know that No_Index (the same as Index_Type'First - 1) is 1004 -- less than 0, so it is safe to compute the following sum without 1005 -- fear of overflow. 1006 1007 Index := No_Index + Index_Type'Base (Count_Type'Last); 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. 1664 1665 Index := No_Index + Index_Type'Base (Count_Type'Last); 1666 1667 if Index <= Index_Type'Last then 1668 1669 -- We have determined that range of Index_Type has at least as 1670 -- many values as in Count_Type, so Count_Type'Last is the 1671 -- maximum number of items that are allowed. 1672 1673 Max_Length := Count_Type'Last; 1674 1675 else 1676 -- The range of Index_Type has fewer values than in Count_Type, 1677 -- so the maximum number of items is computed from the range of 1678 -- the Index_Type. 1679 1680 Max_Length := Count_Type'Base (Index_Type'Last - No_Index); 1681 end if; 1682 1683 else 1684 -- No_Index is equal or greater than 0, so we can safely compute 1685 -- the difference without fear of overflow (which we would have to 1686 -- worry about if No_Index were less than 0, but that case is 1687 -- handled above). 1688 1689 if Index_Type'Last - No_Index >= Count_Type_Last then 1690 -- We have determined that range of Index_Type has at least as 1691 -- many values as in Count_Type, so Count_Type'Last is the 1692 -- maximum number of items that are allowed. 1693 1694 Max_Length := Count_Type'Last; 1695 1696 else 1697 -- The range of Index_Type has fewer values than in Count_Type, 1698 -- so the maximum number of items is computed from the range of 1699 -- the Index_Type. 1700 1701 Max_Length := Count_Type'Base (Index_Type'Last - No_Index); 1702 end if; 1703 end if; 1704 1705 elsif Index_Type'First <= 0 then 1706 1707 -- We know that No_Index (the same as Index_Type'First - 1) is less 1708 -- than 0, so it is safe to compute the following sum without fear of 1709 -- overflow. 1710 1711 J := Count_Type'Base (No_Index) + Count_Type'Last; 1712 1713 if J <= Count_Type'Base (Index_Type'Last) then 1714 1715 -- We have determined that range of Index_Type has at least as 1716 -- many values as in Count_Type, so Count_Type'Last is the maximum 1717 -- number of items that are allowed. 1718 1719 Max_Length := Count_Type'Last; 1720 1721 else 1722 -- The range of Index_Type has fewer values than Count_Type does, 1723 -- so the maximum number of items is computed from the range of 1724 -- the Index_Type. 1725 1726 Max_Length := 1727 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); 1728 end if; 1729 1730 else 1731 -- No_Index is equal or greater than 0, so we can safely compute the 1732 -- difference without fear of overflow (which we would have to worry 1733 -- about if No_Index were less than 0, but that case is handled 1734 -- above). 1735 1736 Max_Length := 1737 Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); 1738 end if; 1739 1740 -- We have just computed the maximum length (number of items). We must 1741 -- now compare the requested length to the maximum length, as we do not 1742 -- allow a vector expand beyond the maximum (because that would create 1743 -- an internal array with a last index value greater than 1744 -- Index_Type'Last, with no way to index those elements). 1745 1746 if Checks and then New_Length > Max_Length then 1747 raise Constraint_Error with "Count is out of range"; 1748 end if; 1749 1750 -- New_Last is the last index value of the items in the container after 1751 -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to 1752 -- compute its value from the New_Length. 1753 1754 if Index_Type'Base'Last >= Count_Type_Last then 1755 New_Last := No_Index + Index_Type'Base (New_Length); 1756 else 1757 New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); 1758 end if; 1759 1760 if Container.Elements = null then 1761 pragma Assert (Container.Last = No_Index); 1762 1763 -- This is the simplest case, with which we must always begin: we're 1764 -- inserting items into an empty vector that hasn't allocated an 1765 -- internal array yet. Note that we don't need to check the busy bit 1766 -- here, because an empty container cannot be busy. 1767 1768 -- In order to preserve container invariants, we allocate the new 1769 -- internal array first, before setting the Last index value, in case 1770 -- the allocation fails (which can happen either because there is no 1771 -- storage available, or because default-valued element 1772 -- initialization fails). 1773 1774 Container.Elements := new Elements_Type (New_Last); 1775 1776 -- The allocation of the new, internal array succeeded, so it is now 1777 -- safe to update the Last index, restoring container invariants. 1778 1779 Container.Last := New_Last; 1780 1781 return; 1782 end if; 1783 1784 -- The tampering bits exist to prevent an item from being harmfully 1785 -- manipulated while it is being visited. Query, Update, and Iterate 1786 -- increment the busy count on entry, and decrement the count on 1787 -- exit. Insert checks the count to determine whether it is being called 1788 -- while the associated callback procedure is executing. 1789 1790 TC_Check (Container.TC); 1791 1792 -- An internal array has already been allocated, so we must determine 1793 -- whether there is enough unused storage for the new items. 1794 1795 if New_Last <= Container.Elements.Last then 1796 1797 -- In this case, we're inserting space into a vector that has already 1798 -- allocated an internal array, and the existing array has enough 1799 -- unused storage for the new items. 1800 1801 declare 1802 EA : Elements_Array renames Container.Elements.EA; 1803 1804 begin 1805 if Before <= Container.Last then 1806 1807 -- The space is being inserted before some existing elements, 1808 -- so we must slide the existing elements up to their new 1809 -- home. We use the wider of Index_Type'Base and 1810 -- Count_Type'Base as the type for intermediate index values. 1811 1812 if Index_Type'Base'Last >= Count_Type_Last then 1813 Index := Before + Index_Type'Base (Count); 1814 1815 else 1816 Index := Index_Type'Base (Count_Type'Base (Before) + Count); 1817 end if; 1818 1819 EA (Index .. New_Last) := EA (Before .. Container.Last); 1820 end if; 1821 end; 1822 1823 Container.Last := New_Last; 1824 return; 1825 end if; 1826 1827 -- In this case, we're inserting space into a vector that has already 1828 -- allocated an internal array, but the existing array does not have 1829 -- enough storage, so we must allocate a new, longer array. In order to 1830 -- guarantee that the amortized insertion cost is O(1), we always 1831 -- allocate an array whose length is some power-of-two factor of the 1832 -- current array length. (The new array cannot have a length less than 1833 -- the New_Length of the container, but its last index value cannot be 1834 -- greater than Index_Type'Last.) 1835 1836 New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); 1837 while New_Capacity < New_Length loop 1838 if New_Capacity > Count_Type'Last / 2 then 1839 New_Capacity := Count_Type'Last; 1840 exit; 1841 end if; 1842 1843 New_Capacity := 2 * New_Capacity; 1844 end loop; 1845 1846 if New_Capacity > Max_Length then 1847 1848 -- We have reached the limit of capacity, so no further expansion 1849 -- will occur. (This is not a problem, as there is never a need to 1850 -- have more capacity than the maximum container length.) 1851 1852 New_Capacity := Max_Length; 1853 end if; 1854 1855 -- We have computed the length of the new internal array (and this is 1856 -- what "vector capacity" means), so use that to compute its last index. 1857 1858 if Index_Type'Base'Last >= Count_Type_Last then 1859 Dst_Last := No_Index + Index_Type'Base (New_Capacity); 1860 else 1861 Dst_Last := 1862 Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); 1863 end if; 1864 1865 -- Now we allocate the new, longer internal array. If the allocation 1866 -- fails, we have not changed any container state, so no side-effect 1867 -- will occur as a result of propagating the exception. 1868 1869 Dst := new Elements_Type (Dst_Last); 1870 1871 -- We have our new internal array. All that needs to be done now is to 1872 -- copy the existing items (if any) from the old array (the "source" 1873 -- array, object SA below) to the new array (the "destination" array, 1874 -- object DA below), and then deallocate the old array. 1875 1876 declare 1877 SA : Elements_Array renames Container.Elements.EA; -- source 1878 DA : Elements_Array renames Dst.EA; -- destination 1879 1880 begin 1881 DA (Index_Type'First .. Before - 1) := 1882 SA (Index_Type'First .. Before - 1); 1883 1884 if Before <= Container.Last then 1885 1886 -- The space is being inserted before some existing elements, so 1887 -- we must slide the existing elements up to their new home. 1888 1889 if Index_Type'Base'Last >= Count_Type_Last then 1890 Index := Before + Index_Type'Base (Count); 1891 else 1892 Index := Index_Type'Base (Count_Type'Base (Before) + Count); 1893 end if; 1894 1895 DA (Index .. New_Last) := SA (Before .. Container.Last); 1896 end if; 1897 1898 exception 1899 when others => 1900 Free (Dst); 1901 raise; 1902 end; 1903 1904 -- We have successfully copied the items onto the new array, so the 1905 -- final thing to do is restore invariants, and deallocate the old 1906 -- array. 1907 1908 declare 1909 X : Elements_Access := Container.Elements; 1910 1911 begin 1912 -- We first isolate the old internal array, removing it from the 1913 -- container and replacing it with the new internal array, before we 1914 -- deallocate the old array (which can fail if finalization of 1915 -- elements propagates an exception). 1916 1917 Container.Elements := Dst; 1918 Container.Last := New_Last; 1919 1920 -- The container invariants have been restored, so it is now safe to 1921 -- attempt to deallocate the old array. 1922 1923 Free (X); 1924 end; 1925 end Insert_Space; 1926 1927 procedure Insert_Space 1928 (Container : in out Vector; 1929 Before : Cursor; 1930 Position : out Cursor; 1931 Count : Count_Type := 1) 1932 is 1933 Index : Index_Type'Base; 1934 1935 begin 1936 if Checks and then Before.Container /= null 1937 and then Before.Container /= Container'Unrestricted_Access 1938 then 1939 raise Program_Error with "Before cursor denotes wrong container"; 1940 end if; 1941 1942 if Count = 0 then 1943 if Before.Container = null or else Before.Index > Container.Last then 1944 Position := No_Element; 1945 else 1946 Position := (Container'Unrestricted_Access, Before.Index); 1947 end if; 1948 1949 return; 1950 end if; 1951 1952 if Before.Container = null or else Before.Index > Container.Last then 1953 if Checks and then Container.Last = Index_Type'Last then 1954 raise Constraint_Error with 1955 "vector is already at its maximum length"; 1956 else 1957 Index := Container.Last + 1; 1958 end if; 1959 1960 else 1961 Index := Before.Index; 1962 end if; 1963 1964 Insert_Space (Container, Index, Count); 1965 1966 Position := (Container'Unrestricted_Access, Index); 1967 end Insert_Space; 1968 1969 -------------- 1970 -- Is_Empty -- 1971 -------------- 1972 1973 function Is_Empty (Container : Vector) return Boolean is 1974 begin 1975 return Container.Last < Index_Type'First; 1976 end Is_Empty; 1977 1978 ------------- 1979 -- Iterate -- 1980 ------------- 1981 1982 procedure Iterate 1983 (Container : Vector; 1984 Process : not null access procedure (Position : Cursor)) 1985 is 1986 Busy : With_Busy (Container.TC'Unrestricted_Access); 1987 begin 1988 for Indx in Index_Type'First .. Container.Last loop 1989 Process (Cursor'(Container'Unrestricted_Access, Indx)); 1990 end loop; 1991 end Iterate; 1992 1993 function Iterate 1994 (Container : Vector) 1995 return Vector_Iterator_Interfaces.Reversible_Iterator'Class 1996 is 1997 V : constant Vector_Access := Container'Unrestricted_Access; 1998 begin 1999 -- The value of its Index component influences the behavior of the First 2000 -- and Last selector functions of the iterator object. When the Index 2001 -- component is No_Index (as is the case here), this means the iterator 2002 -- object was constructed without a start expression. This is a complete 2003 -- iterator, meaning that the iteration starts from the (logical) 2004 -- beginning of the sequence of items. 2005 2006 -- Note: For a forward iterator, Container.First is the beginning, and 2007 -- for a reverse iterator, Container.Last is the beginning. 2008 2009 return It : constant Iterator := 2010 (Limited_Controlled with 2011 Container => V, 2012 Index => No_Index) 2013 do 2014 Busy (Container.TC'Unrestricted_Access.all); 2015 end return; 2016 end Iterate; 2017 2018 function Iterate 2019 (Container : Vector; 2020 Start : Cursor) 2021 return Vector_Iterator_Interfaces.Reversible_Iterator'Class 2022 is 2023 V : constant Vector_Access := Container'Unrestricted_Access; 2024 begin 2025 -- It was formerly the case that when Start = No_Element, the partial 2026 -- iterator was defined to behave the same as for a complete iterator, 2027 -- and iterate over the entire sequence of items. However, those 2028 -- semantics were unintuitive and arguably error-prone (it is too easy 2029 -- to accidentally create an endless loop), and so they were changed, 2030 -- per the ARG meeting in Denver on 2011/11. However, there was no 2031 -- consensus about what positive meaning this corner case should have, 2032 -- and so it was decided to simply raise an exception. This does imply, 2033 -- however, that it is not possible to use a partial iterator to specify 2034 -- an empty sequence of items. 2035 2036 if Checks then 2037 if Start.Container = null then 2038 raise Constraint_Error with 2039 "Start position for iterator equals No_Element"; 2040 end if; 2041 2042 if Start.Container /= V then 2043 raise Program_Error with 2044 "Start cursor of Iterate designates wrong vector"; 2045 end if; 2046 2047 if Start.Index > V.Last then 2048 raise Constraint_Error with 2049 "Start position for iterator equals No_Element"; 2050 end if; 2051 end if; 2052 2053 -- The value of its Index component influences the behavior of the First 2054 -- and Last selector functions of the iterator object. When the Index 2055 -- component is not No_Index (as is the case here), it means that this 2056 -- is a partial iteration, over a subset of the complete sequence of 2057 -- items. The iterator object was constructed with a start expression, 2058 -- indicating the position from which the iteration begins. Note that 2059 -- the start position has the same value irrespective of whether this 2060 -- is a forward or reverse iteration. 2061 2062 return It : constant Iterator := 2063 (Limited_Controlled with 2064 Container => V, 2065 Index => Start.Index) 2066 do 2067 Busy (Container.TC'Unrestricted_Access.all); 2068 end return; 2069 end Iterate; 2070 2071 ---------- 2072 -- Last -- 2073 ---------- 2074 2075 function Last (Container : Vector) return Cursor is 2076 begin 2077 if Is_Empty (Container) then 2078 return No_Element; 2079 else 2080 return (Container'Unrestricted_Access, Container.Last); 2081 end if; 2082 end Last; 2083 2084 function Last (Object : Iterator) return Cursor is 2085 begin 2086 -- The value of the iterator object's Index component influences the 2087 -- behavior of the Last (and First) selector function. 2088 2089 -- When the Index component is No_Index, this means the iterator 2090 -- object was constructed without a start expression, in which case the 2091 -- (reverse) iteration starts from the (logical) beginning of the entire 2092 -- sequence (corresponding to Container.Last, for a reverse iterator). 2093 2094 -- Otherwise, this is iteration over a partial sequence of items. 2095 -- When the Index component is not No_Index, the iterator object was 2096 -- constructed with a start expression, that specifies the position 2097 -- from which the (reverse) partial iteration begins. 2098 2099 if Object.Index = No_Index then 2100 return Last (Object.Container.all); 2101 else 2102 return Cursor'(Object.Container, Object.Index); 2103 end if; 2104 end Last; 2105 2106 ------------------ 2107 -- Last_Element -- 2108 ------------------ 2109 2110 function Last_Element (Container : Vector) return Element_Type is 2111 begin 2112 if Checks and then Container.Last = No_Index then 2113 raise Constraint_Error with "Container is empty"; 2114 else 2115 return Container.Elements.EA (Container.Last); 2116 end if; 2117 end Last_Element; 2118 2119 ---------------- 2120 -- Last_Index -- 2121 ---------------- 2122 2123 function Last_Index (Container : Vector) return Extended_Index is 2124 begin 2125 return Container.Last; 2126 end Last_Index; 2127 2128 ------------ 2129 -- Length -- 2130 ------------ 2131 2132 function Length (Container : Vector) return Count_Type is 2133 L : constant Index_Type'Base := Container.Last; 2134 F : constant Index_Type := Index_Type'First; 2135 2136 begin 2137 -- The base range of the index type (Index_Type'Base) might not include 2138 -- all values for length (Count_Type). Contrariwise, the index type 2139 -- might include values outside the range of length. Hence we use 2140 -- whatever type is wider for intermediate values when calculating 2141 -- length. Note that no matter what the index type is, the maximum 2142 -- length to which a vector is allowed to grow is always the minimum 2143 -- of Count_Type'Last and (IT'Last - IT'First + 1). 2144 2145 -- For example, an Index_Type with range -127 .. 127 is only guaranteed 2146 -- to have a base range of -128 .. 127, but the corresponding vector 2147 -- would have lengths in the range 0 .. 255. In this case we would need 2148 -- to use Count_Type'Base for intermediate values. 2149 2150 -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The 2151 -- vector would have a maximum length of 10, but the index values lie 2152 -- outside the range of Count_Type (which is only 32 bits). In this 2153 -- case we would need to use Index_Type'Base for intermediate values. 2154 2155 if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then 2156 return Count_Type'Base (L) - Count_Type'Base (F) + 1; 2157 else 2158 return Count_Type (L - F + 1); 2159 end if; 2160 end Length; 2161 2162 ---------- 2163 -- Move -- 2164 ---------- 2165 2166 procedure Move 2167 (Target : in out Vector; 2168 Source : in out Vector) 2169 is 2170 begin 2171 if Target'Address = Source'Address then 2172 return; 2173 end if; 2174 2175 TC_Check (Target.TC); 2176 TC_Check (Source.TC); 2177 2178 declare 2179 Target_Elements : constant Elements_Access := Target.Elements; 2180 begin 2181 Target.Elements := Source.Elements; 2182 Source.Elements := Target_Elements; 2183 end; 2184 2185 Target.Last := Source.Last; 2186 Source.Last := No_Index; 2187 end Move; 2188 2189 ---------- 2190 -- Next -- 2191 ---------- 2192 2193 function Next (Position : Cursor) return Cursor is 2194 begin 2195 if Position.Container = null then 2196 return No_Element; 2197 elsif Position.Index < Position.Container.Last then 2198 return (Position.Container, Position.Index + 1); 2199 else 2200 return No_Element; 2201 end if; 2202 end Next; 2203 2204 function Next (Object : Iterator; Position : Cursor) return Cursor is 2205 begin 2206 if Position.Container = null then 2207 return No_Element; 2208 elsif Checks and then Position.Container /= Object.Container then 2209 raise Program_Error with 2210 "Position cursor of Next designates wrong vector"; 2211 else 2212 return Next (Position); 2213 end if; 2214 end Next; 2215 2216 procedure Next (Position : in out Cursor) is 2217 begin 2218 if Position.Container = null then 2219 return; 2220 elsif Position.Index < Position.Container.Last then 2221 Position.Index := Position.Index + 1; 2222 else 2223 Position := No_Element; 2224 end if; 2225 end Next; 2226 2227 ------------- 2228 -- Prepend -- 2229 ------------- 2230 2231 procedure Prepend (Container : in out Vector; New_Item : Vector) is 2232 begin 2233 Insert (Container, Index_Type'First, New_Item); 2234 end Prepend; 2235 2236 procedure Prepend 2237 (Container : in out Vector; 2238 New_Item : Element_Type; 2239 Count : Count_Type := 1) 2240 is 2241 begin 2242 Insert (Container, Index_Type'First, New_Item, Count); 2243 end Prepend; 2244 2245 -------------- 2246 -- Previous -- 2247 -------------- 2248 2249 function Previous (Position : Cursor) return Cursor is 2250 begin 2251 if Position.Container = null then 2252 return No_Element; 2253 elsif Position.Index > Index_Type'First then 2254 return (Position.Container, Position.Index - 1); 2255 else 2256 return No_Element; 2257 end if; 2258 end Previous; 2259 2260 function Previous (Object : Iterator; Position : Cursor) return Cursor is 2261 begin 2262 if Position.Container = null then 2263 return No_Element; 2264 elsif Checks and then Position.Container /= Object.Container then 2265 raise Program_Error with 2266 "Position cursor of Previous designates wrong vector"; 2267 else 2268 return Previous (Position); 2269 end if; 2270 end Previous; 2271 2272 procedure Previous (Position : in out Cursor) is 2273 begin 2274 if Position.Container = null then 2275 return; 2276 elsif Position.Index > Index_Type'First then 2277 Position.Index := Position.Index - 1; 2278 else 2279 Position := No_Element; 2280 end if; 2281 end Previous; 2282 2283 ---------------------- 2284 -- Pseudo_Reference -- 2285 ---------------------- 2286 2287 function Pseudo_Reference 2288 (Container : aliased Vector'Class) return Reference_Control_Type 2289 is 2290 TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; 2291 begin 2292 return R : constant Reference_Control_Type := (Controlled with TC) do 2293 Lock (TC.all); 2294 end return; 2295 end Pseudo_Reference; 2296 2297 ------------------- 2298 -- Query_Element -- 2299 ------------------- 2300 2301 procedure Query_Element 2302 (Container : Vector; 2303 Index : Index_Type; 2304 Process : not null access procedure (Element : Element_Type)) 2305 is 2306 Lock : With_Lock (Container.TC'Unrestricted_Access); 2307 V : Vector renames Container'Unrestricted_Access.all; 2308 2309 begin 2310 if Checks and then Index > Container.Last then 2311 raise Constraint_Error with "Index is out of range"; 2312 end if; 2313 2314 Process (V.Elements.EA (Index)); 2315 end Query_Element; 2316 2317 procedure Query_Element 2318 (Position : Cursor; 2319 Process : not null access procedure (Element : Element_Type)) 2320 is 2321 begin 2322 if Checks and then Position.Container = null then 2323 raise Constraint_Error with "Position cursor has no element"; 2324 else 2325 Query_Element (Position.Container.all, Position.Index, Process); 2326 end if; 2327 end Query_Element; 2328 2329 ---------- 2330 -- Read -- 2331 ---------- 2332 2333 procedure Read 2334 (Stream : not null access Root_Stream_Type'Class; 2335 Container : out Vector) 2336 is 2337 Length : Count_Type'Base; 2338 Last : Index_Type'Base := No_Index; 2339 2340 begin 2341 Clear (Container); 2342 2343 Count_Type'Base'Read (Stream, Length); 2344 2345 if Length > Capacity (Container) then 2346 Reserve_Capacity (Container, Capacity => Length); 2347 end if; 2348 2349 for J in Count_Type range 1 .. Length loop 2350 Last := Last + 1; 2351 Element_Type'Read (Stream, Container.Elements.EA (Last)); 2352 Container.Last := Last; 2353 end loop; 2354 end Read; 2355 2356 procedure Read 2357 (Stream : not null access Root_Stream_Type'Class; 2358 Position : out Cursor) 2359 is 2360 begin 2361 raise Program_Error with "attempt to stream vector cursor"; 2362 end Read; 2363 2364 procedure Read 2365 (Stream : not null access Root_Stream_Type'Class; 2366 Item : out Reference_Type) 2367 is 2368 begin 2369 raise Program_Error with "attempt to stream reference"; 2370 end Read; 2371 2372 procedure Read 2373 (Stream : not null access Root_Stream_Type'Class; 2374 Item : out Constant_Reference_Type) 2375 is 2376 begin 2377 raise Program_Error with "attempt to stream reference"; 2378 end Read; 2379 2380 --------------- 2381 -- Reference -- 2382 --------------- 2383 2384 function Reference 2385 (Container : aliased in out Vector; 2386 Position : Cursor) return Reference_Type 2387 is 2388 begin 2389 if Checks then 2390 if Position.Container = null then 2391 raise Constraint_Error with "Position cursor has no element"; 2392 end if; 2393 2394 if Position.Container /= Container'Unrestricted_Access then 2395 raise Program_Error with "Position cursor denotes wrong container"; 2396 end if; 2397 2398 if Position.Index > Position.Container.Last then 2399 raise Constraint_Error with "Position cursor is out of range"; 2400 end if; 2401 end if; 2402 2403 declare 2404 TC : constant Tamper_Counts_Access := 2405 Container.TC'Unrestricted_Access; 2406 begin 2407 return R : constant Reference_Type := 2408 (Element => Container.Elements.EA (Position.Index)'Access, 2409 Control => (Controlled with TC)) 2410 do 2411 Lock (TC.all); 2412 end return; 2413 end; 2414 end Reference; 2415 2416 function Reference 2417 (Container : aliased in out Vector; 2418 Index : Index_Type) return Reference_Type 2419 is 2420 begin 2421 if Checks and then Index > Container.Last then 2422 raise Constraint_Error with "Index is out of range"; 2423 end if; 2424 2425 declare 2426 TC : constant Tamper_Counts_Access := 2427 Container.TC'Unrestricted_Access; 2428 begin 2429 return R : constant Reference_Type := 2430 (Element => Container.Elements.EA (Index)'Access, 2431 Control => (Controlled with TC)) 2432 do 2433 Lock (TC.all); 2434 end return; 2435 end; 2436 end Reference; 2437 2438 --------------------- 2439 -- Replace_Element -- 2440 --------------------- 2441 2442 procedure Replace_Element 2443 (Container : in out Vector; 2444 Index : Index_Type; 2445 New_Item : Element_Type) 2446 is 2447 begin 2448 if Checks and then Index > Container.Last then 2449 raise Constraint_Error with "Index is out of range"; 2450 end if; 2451 2452 TE_Check (Container.TC); 2453 Container.Elements.EA (Index) := New_Item; 2454 end Replace_Element; 2455 2456 procedure Replace_Element 2457 (Container : in out Vector; 2458 Position : Cursor; 2459 New_Item : Element_Type) 2460 is 2461 begin 2462 if Checks then 2463 if Position.Container = null then 2464 raise Constraint_Error with "Position cursor has no element"; 2465 2466 elsif Position.Container /= Container'Unrestricted_Access then 2467 raise Program_Error with "Position cursor denotes wrong container"; 2468 2469 elsif Position.Index > Container.Last then 2470 raise Constraint_Error with "Position cursor is out of range"; 2471 end if; 2472 end if; 2473 2474 TE_Check (Container.TC); 2475 Container.Elements.EA (Position.Index) := New_Item; 2476 end Replace_Element; 2477 2478 ---------------------- 2479 -- Reserve_Capacity -- 2480 ---------------------- 2481 2482 procedure Reserve_Capacity 2483 (Container : in out Vector; 2484 Capacity : Count_Type) 2485 is 2486 N : constant Count_Type := Length (Container); 2487 2488 Index : Count_Type'Base; 2489 Last : Index_Type'Base; 2490 2491 begin 2492 -- Reserve_Capacity can be used to either expand the storage available 2493 -- for elements (this would be its typical use, in anticipation of 2494 -- future insertion), or to trim back storage. In the latter case, 2495 -- storage can only be trimmed back to the limit of the container 2496 -- length. Note that Reserve_Capacity neither deletes (active) elements 2497 -- nor inserts elements; it only affects container capacity, never 2498 -- container length. 2499 2500 if Capacity = 0 then 2501 2502 -- This is a request to trim back storage, to the minimum amount 2503 -- possible given the current state of the container. 2504 2505 if N = 0 then 2506 2507 -- The container is empty, so in this unique case we can 2508 -- deallocate the entire internal array. Note that an empty 2509 -- container can never be busy, so there's no need to check the 2510 -- tampering bits. 2511 2512 declare 2513 X : Elements_Access := Container.Elements; 2514 2515 begin 2516 -- First we remove the internal array from the container, to 2517 -- handle the case when the deallocation raises an exception. 2518 2519 Container.Elements := null; 2520 2521 -- Container invariants have been restored, so it is now safe 2522 -- to attempt to deallocate the internal array. 2523 2524 Free (X); 2525 end; 2526 2527 elsif N < Container.Elements.EA'Length then 2528 2529 -- The container is not empty, and the current length is less than 2530 -- the current capacity, so there's storage available to trim. In 2531 -- this case, we allocate a new internal array having a length 2532 -- that exactly matches the number of items in the 2533 -- container. (Reserve_Capacity does not delete active elements, 2534 -- so this is the best we can do with respect to minimizing 2535 -- storage). 2536 2537 TC_Check (Container.TC); 2538 2539 declare 2540 subtype Src_Index_Subtype is Index_Type'Base range 2541 Index_Type'First .. Container.Last; 2542 2543 Src : Elements_Array renames 2544 Container.Elements.EA (Src_Index_Subtype); 2545 2546 X : Elements_Access := Container.Elements; 2547 2548 begin 2549 -- Although we have isolated the old internal array that we're 2550 -- going to deallocate, we don't deallocate it until we have 2551 -- successfully allocated a new one. If there is an exception 2552 -- during allocation (either because there is not enough 2553 -- storage, or because initialization of the elements fails), 2554 -- we let it propagate without causing any side-effect. 2555 2556 Container.Elements := new Elements_Type'(Container.Last, Src); 2557 2558 -- We have successfully allocated a new internal array (with a 2559 -- smaller length than the old one, and containing a copy of 2560 -- just the active elements in the container), so it is now 2561 -- safe to attempt to deallocate the old array. The old array 2562 -- has been isolated, and container invariants have been 2563 -- restored, so if the deallocation fails (because finalization 2564 -- of the elements fails), we simply let it propagate. 2565 2566 Free (X); 2567 end; 2568 end if; 2569 2570 return; 2571 end if; 2572 2573 -- Reserve_Capacity can be used to expand the storage available for 2574 -- elements, but we do not let the capacity grow beyond the number of 2575 -- values in Index_Type'Range. (Were it otherwise, there would be no way 2576 -- to refer to the elements with an index value greater than 2577 -- Index_Type'Last, so that storage would be wasted.) Here we compute 2578 -- the Last index value of the new internal array, in a way that avoids 2579 -- any possibility of overflow. 2580 2581 if Index_Type'Base'Last >= Count_Type_Last then 2582 2583 -- We perform a two-part test. First we determine whether the 2584 -- computed Last value lies in the base range of the type, and then 2585 -- determine whether it lies in the range of the index (sub)type. 2586 2587 -- Last must satisfy this relation: 2588 -- First + Length - 1 <= Last 2589 -- We regroup terms: 2590 -- First - 1 <= Last - Length 2591 -- Which can rewrite as: 2592 -- No_Index <= Last - Length 2593 2594 if Checks and then 2595 Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index 2596 then 2597 raise Constraint_Error with "Capacity is out of range"; 2598 end if; 2599 2600 -- We now know that the computed value of Last is within the base 2601 -- range of the type, so it is safe to compute its value: 2602 2603 Last := No_Index + Index_Type'Base (Capacity); 2604 2605 -- Finally we test whether the value is within the range of the 2606 -- generic actual index subtype: 2607 2608 if Checks and then Last > Index_Type'Last then 2609 raise Constraint_Error with "Capacity is out of range"; 2610 end if; 2611 2612 elsif Index_Type'First <= 0 then 2613 2614 -- Here we can compute Last directly, in the normal way. We know that 2615 -- No_Index is less than 0, so there is no danger of overflow when 2616 -- adding the (positive) value of Capacity. 2617 2618 Index := Count_Type'Base (No_Index) + Capacity; -- Last 2619 2620 if Checks and then Index > Count_Type'Base (Index_Type'Last) then 2621 raise Constraint_Error with "Capacity is out of range"; 2622 end if; 2623 2624 -- We know that the computed value (having type Count_Type) of Last 2625 -- is within the range of the generic actual index subtype, so it is 2626 -- safe to convert to Index_Type: 2627 2628 Last := Index_Type'Base (Index); 2629 2630 else 2631 -- Here Index_Type'First (and Index_Type'Last) is positive, so we 2632 -- must test the length indirectly (by working backwards from the 2633 -- largest possible value of Last), in order to prevent overflow. 2634 2635 Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index 2636 2637 if Checks and then Index < Count_Type'Base (No_Index) then 2638 raise Constraint_Error with "Capacity is out of range"; 2639 end if; 2640 2641 -- We have determined that the value of Capacity would not create a 2642 -- Last index value outside of the range of Index_Type, so we can now 2643 -- safely compute its value. 2644 2645 Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); 2646 end if; 2647 2648 -- The requested capacity is non-zero, but we don't know yet whether 2649 -- this is a request for expansion or contraction of storage. 2650 2651 if Container.Elements = null then 2652 2653 -- The container is empty (it doesn't even have an internal array), 2654 -- so this represents a request to allocate (expand) storage having 2655 -- the given capacity. 2656 2657 Container.Elements := new Elements_Type (Last); 2658 return; 2659 end if; 2660 2661 if Capacity <= N then 2662 2663 -- This is a request to trim back storage, but only to the limit of 2664 -- what's already in the container. (Reserve_Capacity never deletes 2665 -- active elements, it only reclaims excess storage.) 2666 2667 if N < Container.Elements.EA'Length then 2668 2669 -- The container is not empty (because the requested capacity is 2670 -- positive, and less than or equal to the container length), and 2671 -- the current length is less than the current capacity, so 2672 -- there's storage available to trim. In this case, we allocate a 2673 -- new internal array having a length that exactly matches the 2674 -- number of items in the container. 2675 2676 TC_Check (Container.TC); 2677 2678 declare 2679 subtype Src_Index_Subtype is Index_Type'Base range 2680 Index_Type'First .. Container.Last; 2681 2682 Src : Elements_Array renames 2683 Container.Elements.EA (Src_Index_Subtype); 2684 2685 X : Elements_Access := Container.Elements; 2686 2687 begin 2688 -- Although we have isolated the old internal array that we're 2689 -- going to deallocate, we don't deallocate it until we have 2690 -- successfully allocated a new one. If there is an exception 2691 -- during allocation (either because there is not enough 2692 -- storage, or because initialization of the elements fails), 2693 -- we let it propagate without causing any side-effect. 2694 2695 Container.Elements := new Elements_Type'(Container.Last, Src); 2696 2697 -- We have successfully allocated a new internal array (with a 2698 -- smaller length than the old one, and containing a copy of 2699 -- just the active elements in the container), so it is now 2700 -- safe to attempt to deallocate the old array. The old array 2701 -- has been isolated, and container invariants have been 2702 -- restored, so if the deallocation fails (because finalization 2703 -- of the elements fails), we simply let it propagate. 2704 2705 Free (X); 2706 end; 2707 end if; 2708 2709 return; 2710 end if; 2711 2712 -- The requested capacity is larger than the container length (the 2713 -- number of active elements). Whether this represents a request for 2714 -- expansion or contraction of the current capacity depends on what the 2715 -- current capacity is. 2716 2717 if Capacity = Container.Elements.EA'Length then 2718 2719 -- The requested capacity matches the existing capacity, so there's 2720 -- nothing to do here. We treat this case as a no-op, and simply 2721 -- return without checking the busy bit. 2722 2723 return; 2724 end if; 2725 2726 -- There is a change in the capacity of a non-empty container, so a new 2727 -- internal array will be allocated. (The length of the new internal 2728 -- array could be less or greater than the old internal array. We know 2729 -- only that the length of the new internal array is greater than the 2730 -- number of active elements in the container.) We must check whether 2731 -- the container is busy before doing anything else. 2732 2733 TC_Check (Container.TC); 2734 2735 -- We now allocate a new internal array, having a length different from 2736 -- its current value. 2737 2738 declare 2739 E : Elements_Access := new Elements_Type (Last); 2740 2741 begin 2742 -- We have successfully allocated the new internal array. We first 2743 -- attempt to copy the existing elements from the old internal array 2744 -- ("src" elements) onto the new internal array ("tgt" elements). 2745 2746 declare 2747 subtype Index_Subtype is Index_Type'Base range 2748 Index_Type'First .. Container.Last; 2749 2750 Src : Elements_Array renames 2751 Container.Elements.EA (Index_Subtype); 2752 2753 Tgt : Elements_Array renames E.EA (Index_Subtype); 2754 2755 begin 2756 Tgt := Src; 2757 2758 exception 2759 when others => 2760 Free (E); 2761 raise; 2762 end; 2763 2764 -- We have successfully copied the existing elements onto the new 2765 -- internal array, so now we can attempt to deallocate the old one. 2766 2767 declare 2768 X : Elements_Access := Container.Elements; 2769 2770 begin 2771 -- First we isolate the old internal array, and replace it in the 2772 -- container with the new internal array. 2773 2774 Container.Elements := E; 2775 2776 -- Container invariants have been restored, so it is now safe to 2777 -- attempt to deallocate the old internal array. 2778 2779 Free (X); 2780 end; 2781 end; 2782 end Reserve_Capacity; 2783 2784 ---------------------- 2785 -- Reverse_Elements -- 2786 ---------------------- 2787 2788 procedure Reverse_Elements (Container : in out Vector) is 2789 begin 2790 if Container.Length <= 1 then 2791 return; 2792 end if; 2793 2794 -- The exception behavior for the vector container must match that for 2795 -- the list container, so we check for cursor tampering here (which will 2796 -- catch more things) instead of for element tampering (which will catch 2797 -- fewer things). It's true that the elements of this vector container 2798 -- could be safely moved around while (say) an iteration is taking place 2799 -- (iteration only increments the busy counter), and so technically 2800 -- all we would need here is a test for element tampering (indicated 2801 -- by the lock counter), that's simply an artifact of our array-based 2802 -- implementation. Logically Reverse_Elements requires a check for 2803 -- cursor tampering. 2804 2805 TC_Check (Container.TC); 2806 2807 declare 2808 K : Index_Type; 2809 J : Index_Type; 2810 E : Elements_Type renames Container.Elements.all; 2811 2812 begin 2813 K := Index_Type'First; 2814 J := Container.Last; 2815 while K < J loop 2816 declare 2817 EK : constant Element_Type := E.EA (K); 2818 begin 2819 E.EA (K) := E.EA (J); 2820 E.EA (J) := EK; 2821 end; 2822 2823 K := K + 1; 2824 J := J - 1; 2825 end loop; 2826 end; 2827 end Reverse_Elements; 2828 2829 ------------------ 2830 -- Reverse_Find -- 2831 ------------------ 2832 2833 function Reverse_Find 2834 (Container : Vector; 2835 Item : Element_Type; 2836 Position : Cursor := No_Element) return Cursor 2837 is 2838 Last : Index_Type'Base; 2839 2840 begin 2841 if Checks and then Position.Container /= null 2842 and then Position.Container /= Container'Unrestricted_Access 2843 then 2844 raise Program_Error with "Position cursor denotes wrong container"; 2845 end if; 2846 2847 Last := 2848 (if Position.Container = null or else Position.Index > Container.Last 2849 then Container.Last 2850 else Position.Index); 2851 2852 -- Per AI05-0022, the container implementation is required to detect 2853 -- element tampering by a generic actual subprogram. 2854 2855 declare 2856 Lock : With_Lock (Container.TC'Unrestricted_Access); 2857 begin 2858 for Indx in reverse Index_Type'First .. Last loop 2859 if Container.Elements.EA (Indx) = Item then 2860 return Cursor'(Container'Unrestricted_Access, Indx); 2861 end if; 2862 end loop; 2863 2864 return No_Element; 2865 end; 2866 end Reverse_Find; 2867 2868 ------------------------ 2869 -- Reverse_Find_Index -- 2870 ------------------------ 2871 2872 function Reverse_Find_Index 2873 (Container : Vector; 2874 Item : Element_Type; 2875 Index : Index_Type := Index_Type'Last) return Extended_Index 2876 is 2877 -- Per AI05-0022, the container implementation is required to detect 2878 -- element tampering by a generic actual subprogram. 2879 2880 Lock : With_Lock (Container.TC'Unrestricted_Access); 2881 2882 Last : constant Index_Type'Base := 2883 Index_Type'Min (Container.Last, Index); 2884 2885 begin 2886 for Indx in reverse Index_Type'First .. Last loop 2887 if Container.Elements.EA (Indx) = Item then 2888 return Indx; 2889 end if; 2890 end loop; 2891 2892 return No_Index; 2893 end Reverse_Find_Index; 2894 2895 --------------------- 2896 -- Reverse_Iterate -- 2897 --------------------- 2898 2899 procedure Reverse_Iterate 2900 (Container : Vector; 2901 Process : not null access procedure (Position : Cursor)) 2902 is 2903 Busy : With_Busy (Container.TC'Unrestricted_Access); 2904 begin 2905 for Indx in reverse Index_Type'First .. Container.Last loop 2906 Process (Cursor'(Container'Unrestricted_Access, Indx)); 2907 end loop; 2908 end Reverse_Iterate; 2909 2910 ---------------- 2911 -- Set_Length -- 2912 ---------------- 2913 2914 procedure Set_Length (Container : in out Vector; Length : Count_Type) is 2915 Count : constant Count_Type'Base := Container.Length - Length; 2916 2917 begin 2918 -- Set_Length allows the user to set the length explicitly, instead 2919 -- of implicitly as a side-effect of deletion or insertion. If the 2920 -- requested length is less than the current length, this is equivalent 2921 -- to deleting items from the back end of the vector. If the requested 2922 -- length is greater than the current length, then this is equivalent 2923 -- to inserting "space" (nonce items) at the end. 2924 2925 if Count >= 0 then 2926 Container.Delete_Last (Count); 2927 2928 elsif Checks and then Container.Last >= Index_Type'Last then 2929 raise Constraint_Error with "vector is already at its maximum length"; 2930 2931 else 2932 Container.Insert_Space (Container.Last + 1, -Count); 2933 end if; 2934 end Set_Length; 2935 2936 ---------- 2937 -- Swap -- 2938 ---------- 2939 2940 procedure Swap (Container : in out Vector; I, J : Index_Type) is 2941 begin 2942 if Checks then 2943 if I > Container.Last then 2944 raise Constraint_Error with "I index is out of range"; 2945 end if; 2946 2947 if J > Container.Last then 2948 raise Constraint_Error with "J index is out of range"; 2949 end if; 2950 end if; 2951 2952 if I = J then 2953 return; 2954 end if; 2955 2956 TE_Check (Container.TC); 2957 2958 declare 2959 EI_Copy : constant Element_Type := Container.Elements.EA (I); 2960 begin 2961 Container.Elements.EA (I) := Container.Elements.EA (J); 2962 Container.Elements.EA (J) := EI_Copy; 2963 end; 2964 end Swap; 2965 2966 procedure Swap (Container : in out Vector; I, J : Cursor) is 2967 begin 2968 if Checks then 2969 if I.Container = null then 2970 raise Constraint_Error with "I cursor has no element"; 2971 2972 elsif J.Container = null then 2973 raise Constraint_Error with "J cursor has no element"; 2974 2975 elsif I.Container /= Container'Unrestricted_Access then 2976 raise Program_Error with "I cursor denotes wrong container"; 2977 2978 elsif J.Container /= Container'Unrestricted_Access then 2979 raise Program_Error with "J cursor denotes wrong container"; 2980 end if; 2981 end if; 2982 2983 Swap (Container, I.Index, J.Index); 2984 end Swap; 2985 2986 --------------- 2987 -- To_Cursor -- 2988 --------------- 2989 2990 function To_Cursor 2991 (Container : Vector; 2992 Index : Extended_Index) return Cursor 2993 is 2994 begin 2995 if Index not in Index_Type'First .. Container.Last then 2996 return No_Element; 2997 else 2998 return (Container'Unrestricted_Access, Index); 2999 end if; 3000 end To_Cursor; 3001 3002 -------------- 3003 -- To_Index -- 3004 -------------- 3005 3006 function To_Index (Position : Cursor) return Extended_Index is 3007 begin 3008 if Position.Container = null then 3009 return No_Index; 3010 elsif Position.Index <= Position.Container.Last then 3011 return Position.Index; 3012 else 3013 return No_Index; 3014 end if; 3015 end To_Index; 3016 3017 --------------- 3018 -- To_Vector -- 3019 --------------- 3020 3021 function To_Vector (Length : Count_Type) return Vector is 3022 Index : Count_Type'Base; 3023 Last : Index_Type'Base; 3024 Elements : Elements_Access; 3025 3026 begin 3027 if Length = 0 then 3028 return Empty_Vector; 3029 end if; 3030 3031 -- We create a vector object with a capacity that matches the specified 3032 -- Length, but we do not allow the vector capacity (the length of the 3033 -- internal array) to exceed the number of values in Index_Type'Range 3034 -- (otherwise, there would be no way to refer to those components via an 3035 -- index). We must therefore check whether the specified Length would 3036 -- create a Last index value greater than Index_Type'Last. 3037 3038 if Index_Type'Base'Last >= Count_Type_Last then 3039 3040 -- We perform a two-part test. First we determine whether the 3041 -- computed Last value lies in the base range of the type, and then 3042 -- determine whether it lies in the range of the index (sub)type. 3043 3044 -- Last must satisfy this relation: 3045 -- First + Length - 1 <= Last 3046 -- We regroup terms: 3047 -- First - 1 <= Last - Length 3048 -- Which can rewrite as: 3049 -- No_Index <= Last - Length 3050 3051 if Checks and then 3052 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index 3053 then 3054 raise Constraint_Error with "Length is out of range"; 3055 end if; 3056 3057 -- We now know that the computed value of Last is within the base 3058 -- range of the type, so it is safe to compute its value: 3059 3060 Last := No_Index + Index_Type'Base (Length); 3061 3062 -- Finally we test whether the value is within the range of the 3063 -- generic actual index subtype: 3064 3065 if Checks and then Last > Index_Type'Last then 3066 raise Constraint_Error with "Length is out of range"; 3067 end if; 3068 3069 elsif Index_Type'First <= 0 then 3070 3071 -- Here we can compute Last directly, in the normal way. We know that 3072 -- No_Index is less than 0, so there is no danger of overflow when 3073 -- adding the (positive) value of Length. 3074 3075 Index := Count_Type'Base (No_Index) + Length; -- Last 3076 3077 if Checks and then Index > Count_Type'Base (Index_Type'Last) then 3078 raise Constraint_Error with "Length is out of range"; 3079 end if; 3080 3081 -- We know that the computed value (having type Count_Type) of Last 3082 -- is within the range of the generic actual index subtype, so it is 3083 -- safe to convert to Index_Type: 3084 3085 Last := Index_Type'Base (Index); 3086 3087 else 3088 -- Here Index_Type'First (and Index_Type'Last) is positive, so we 3089 -- must test the length indirectly (by working backwards from the 3090 -- largest possible value of Last), in order to prevent overflow. 3091 3092 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index 3093 3094 if Checks and then Index < Count_Type'Base (No_Index) then 3095 raise Constraint_Error with "Length is out of range"; 3096 end if; 3097 3098 -- We have determined that the value of Length would not create a 3099 -- Last index value outside of the range of Index_Type, so we can now 3100 -- safely compute its value. 3101 3102 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); 3103 end if; 3104 3105 Elements := new Elements_Type (Last); 3106 3107 return Vector'(Controlled with Elements, Last, TC => <>); 3108 end To_Vector; 3109 3110 function To_Vector 3111 (New_Item : Element_Type; 3112 Length : Count_Type) return Vector 3113 is 3114 Index : Count_Type'Base; 3115 Last : Index_Type'Base; 3116 Elements : Elements_Access; 3117 3118 begin 3119 if Length = 0 then 3120 return Empty_Vector; 3121 end if; 3122 3123 -- We create a vector object with a capacity that matches the specified 3124 -- Length, but we do not allow the vector capacity (the length of the 3125 -- internal array) to exceed the number of values in Index_Type'Range 3126 -- (otherwise, there would be no way to refer to those components via an 3127 -- index). We must therefore check whether the specified Length would 3128 -- create a Last index value greater than Index_Type'Last. 3129 3130 if Index_Type'Base'Last >= Count_Type_Last then 3131 3132 -- We perform a two-part test. First we determine whether the 3133 -- computed Last value lies in the base range of the type, and then 3134 -- determine whether it lies in the range of the index (sub)type. 3135 3136 -- Last must satisfy this relation: 3137 -- First + Length - 1 <= Last 3138 -- We regroup terms: 3139 -- First - 1 <= Last - Length 3140 -- Which can rewrite as: 3141 -- No_Index <= Last - Length 3142 3143 if Checks and then 3144 Index_Type'Base'Last - Index_Type'Base (Length) < No_Index 3145 then 3146 raise Constraint_Error with "Length is out of range"; 3147 end if; 3148 3149 -- We now know that the computed value of Last is within the base 3150 -- range of the type, so it is safe to compute its value: 3151 3152 Last := No_Index + Index_Type'Base (Length); 3153 3154 -- Finally we test whether the value is within the range of the 3155 -- generic actual index subtype: 3156 3157 if Checks and then Last > Index_Type'Last then 3158 raise Constraint_Error with "Length is out of range"; 3159 end if; 3160 3161 elsif Index_Type'First <= 0 then 3162 3163 -- Here we can compute Last directly, in the normal way. We know that 3164 -- No_Index is less than 0, so there is no danger of overflow when 3165 -- adding the (positive) value of Length. 3166 3167 Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last 3168 3169 if Checks and then Index > Count_Type'Base (Index_Type'Last) then 3170 raise Constraint_Error with "Length is out of range"; 3171 end if; 3172 3173 -- We know that the computed value (having type Count_Type) of Last 3174 -- is within the range of the generic actual index subtype, so it is 3175 -- safe to convert to Index_Type: 3176 3177 Last := Index_Type'Base (Index); 3178 3179 else 3180 -- Here Index_Type'First (and Index_Type'Last) is positive, so we 3181 -- must test the length indirectly (by working backwards from the 3182 -- largest possible value of Last), in order to prevent overflow. 3183 3184 Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index 3185 3186 if Checks and then Index < Count_Type'Base (No_Index) then 3187 raise Constraint_Error with "Length is out of range"; 3188 end if; 3189 3190 -- We have determined that the value of Length would not create a 3191 -- Last index value outside of the range of Index_Type, so we can now 3192 -- safely compute its value. 3193 3194 Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); 3195 end if; 3196 3197 Elements := new Elements_Type'(Last, EA => (others => New_Item)); 3198 3199 return (Controlled with Elements, Last, TC => <>); 3200 end To_Vector; 3201 3202 -------------------- 3203 -- Update_Element -- 3204 -------------------- 3205 3206 procedure Update_Element 3207 (Container : in out Vector; 3208 Index : Index_Type; 3209 Process : not null access procedure (Element : in out Element_Type)) 3210 is 3211 Lock : With_Lock (Container.TC'Unchecked_Access); 3212 begin 3213 if Checks and then Index > Container.Last then 3214 raise Constraint_Error with "Index is out of range"; 3215 end if; 3216 3217 Process (Container.Elements.EA (Index)); 3218 end Update_Element; 3219 3220 procedure Update_Element 3221 (Container : in out Vector; 3222 Position : Cursor; 3223 Process : not null access procedure (Element : in out Element_Type)) 3224 is 3225 begin 3226 if Checks then 3227 if Position.Container = null then 3228 raise Constraint_Error with "Position cursor has no element"; 3229 elsif Position.Container /= Container'Unrestricted_Access then 3230 raise Program_Error with "Position cursor denotes wrong container"; 3231 end if; 3232 end if; 3233 3234 Update_Element (Container, Position.Index, Process); 3235 end Update_Element; 3236 3237 ----------- 3238 -- Write -- 3239 ----------- 3240 3241 procedure Write 3242 (Stream : not null access Root_Stream_Type'Class; 3243 Container : Vector) 3244 is 3245 begin 3246 Count_Type'Base'Write (Stream, Length (Container)); 3247 3248 for J in Index_Type'First .. Container.Last loop 3249 Element_Type'Write (Stream, Container.Elements.EA (J)); 3250 end loop; 3251 end Write; 3252 3253 procedure Write 3254 (Stream : not null access Root_Stream_Type'Class; 3255 Position : Cursor) 3256 is 3257 begin 3258 raise Program_Error with "attempt to stream vector cursor"; 3259 end Write; 3260 3261 procedure Write 3262 (Stream : not null access Root_Stream_Type'Class; 3263 Item : Reference_Type) 3264 is 3265 begin 3266 raise Program_Error with "attempt to stream reference"; 3267 end Write; 3268 3269 procedure Write 3270 (Stream : not null access Root_Stream_Type'Class; 3271 Item : Constant_Reference_Type) 3272 is 3273 begin 3274 raise Program_Error with "attempt to stream reference"; 3275 end Write; 3276 3277end Ada.Containers.Vectors; 3278