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