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