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