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