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