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