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