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