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