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