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