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