1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-2013, 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 28with Ada.Containers.Generic_Array_Sort; 29with System; use type System.Address; 30 31package body Ada.Containers.Formal_Vectors is 32 33 type Int is range System.Min_Int .. System.Max_Int; 34 type UInt is mod System.Max_Binary_Modulus; 35 36 function Get_Element 37 (Container : Vector; 38 Position : Count_Type) return Element_Type; 39 40 procedure Insert_Space 41 (Container : in out Vector; 42 Before : Extended_Index; 43 Count : Count_Type := 1); 44 45 --------- 46 -- "&" -- 47 --------- 48 49 function "&" (Left, Right : Vector) return Vector is 50 LN : constant Count_Type := Length (Left); 51 RN : constant Count_Type := Length (Right); 52 53 begin 54 if LN = 0 then 55 if RN = 0 then 56 return Empty_Vector; 57 end if; 58 59 declare 60 E : constant Elements_Array (1 .. Length (Right)) := 61 Right.Elements (1 .. RN); 62 begin 63 return (Length (Right), E, Last => Right.Last, others => <>); 64 end; 65 end if; 66 67 if RN = 0 then 68 declare 69 E : constant Elements_Array (1 .. Length (Left)) := 70 Left.Elements (1 .. LN); 71 begin 72 return (Length (Left), E, Last => Left.Last, others => <>); 73 end; 74 end if; 75 76 declare 77 N : constant Int'Base := Int (LN) + Int (RN); 78 Last_As_Int : Int'Base; 79 80 begin 81 if Int (No_Index) > Int'Last - N then 82 raise Constraint_Error with "new length is out of range"; 83 end if; 84 85 Last_As_Int := Int (No_Index) + N; 86 87 if Last_As_Int > Int (Index_Type'Last) then 88 raise Constraint_Error with "new length is out of range"; 89 end if; 90 91 -- TODO: should check whether length > max capacity (cnt_t'last) ??? 92 93 declare 94 Last : constant Index_Type := Index_Type (Last_As_Int); 95 96 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); 97 RE : Elements_Array renames Right.Elements (1 .. RN); 98 99 Capacity : constant Count_Type := Length (Left) + Length (Right); 100 101 begin 102 return (Capacity, LE & RE, Last => Last, others => <>); 103 end; 104 end; 105 end "&"; 106 107 function "&" (Left : Vector; Right : Element_Type) return Vector is 108 LN : constant Count_Type := Length (Left); 109 Last_As_Int : Int'Base; 110 111 begin 112 if LN = 0 then 113 return (1, (1 .. 1 => Right), Index_Type'First, others => <>); 114 end if; 115 116 if Int (Index_Type'First) > Int'Last - Int (LN) then 117 raise Constraint_Error with "new length is out of range"; 118 end if; 119 120 Last_As_Int := Int (Index_Type'First) + Int (LN); 121 122 if Last_As_Int > Int (Index_Type'Last) then 123 raise Constraint_Error with "new length is out of range"; 124 end if; 125 126 declare 127 Last : constant Index_Type := Index_Type (Last_As_Int); 128 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); 129 130 Capacity : constant Count_Type := Length (Left) + 1; 131 132 begin 133 return (Capacity, LE & Right, Last => Last, others => <>); 134 end; 135 end "&"; 136 137 function "&" (Left : Element_Type; Right : Vector) return Vector is 138 RN : constant Count_Type := Length (Right); 139 Last_As_Int : Int'Base; 140 141 begin 142 if RN = 0 then 143 return (1, (1 .. 1 => Left), 144 Index_Type'First, others => <>); 145 end if; 146 147 if Int (Index_Type'First) > Int'Last - Int (RN) then 148 raise Constraint_Error with "new length is out of range"; 149 end if; 150 151 Last_As_Int := Int (Index_Type'First) + Int (RN); 152 153 if Last_As_Int > Int (Index_Type'Last) then 154 raise Constraint_Error with "new length is out of range"; 155 end if; 156 157 declare 158 Last : constant Index_Type := Index_Type (Last_As_Int); 159 RE : Elements_Array renames Right.Elements (1 .. RN); 160 Capacity : constant Count_Type := 1 + Length (Right); 161 begin 162 return (Capacity, Left & RE, Last => Last, others => <>); 163 end; 164 end "&"; 165 166 function "&" (Left, Right : Element_Type) return Vector is 167 begin 168 if Index_Type'First >= Index_Type'Last then 169 raise Constraint_Error with "new length is out of range"; 170 end if; 171 172 declare 173 Last : constant Index_Type := Index_Type'First + 1; 174 begin 175 return (2, (Left, Right), Last => Last, others => <>); 176 end; 177 end "&"; 178 179 --------- 180 -- "=" -- 181 --------- 182 183 function "=" (Left, Right : Vector) return Boolean is 184 begin 185 if Left'Address = Right'Address then 186 return True; 187 end if; 188 189 if Length (Left) /= Length (Right) then 190 return False; 191 end if; 192 193 for J in Count_Type range 1 .. Length (Left) loop 194 if Get_Element (Left, J) /= Get_Element (Right, J) then 195 return False; 196 end if; 197 end loop; 198 199 return True; 200 end "="; 201 202 ------------ 203 -- Append -- 204 ------------ 205 206 procedure Append (Container : in out Vector; New_Item : Vector) is 207 begin 208 if Is_Empty (New_Item) then 209 return; 210 end if; 211 212 if Container.Last = Index_Type'Last then 213 raise Constraint_Error with "vector is already at its maximum length"; 214 end if; 215 216 Insert (Container, Container.Last + 1, New_Item); 217 end Append; 218 219 procedure Append 220 (Container : in out Vector; 221 New_Item : Element_Type; 222 Count : Count_Type := 1) 223 is 224 begin 225 if Count = 0 then 226 return; 227 end if; 228 229 if Container.Last = Index_Type'Last then 230 raise Constraint_Error with "vector is already at its maximum length"; 231 end if; 232 233 -- TODO: should check whether length > max capacity (cnt_t'last) ??? 234 235 Insert (Container, Container.Last + 1, New_Item, Count); 236 end Append; 237 238 ------------ 239 -- Assign -- 240 ------------ 241 242 procedure Assign (Target : in out Vector; Source : Vector) is 243 LS : constant Count_Type := Length (Source); 244 245 begin 246 if Target'Address = Source'Address then 247 return; 248 end if; 249 250 if Target.Capacity < LS then 251 raise Constraint_Error; 252 end if; 253 254 Clear (Target); 255 256 Target.Elements (1 .. LS) := Source.Elements (1 .. LS); 257 Target.Last := Source.Last; 258 end Assign; 259 260 -------------- 261 -- Capacity -- 262 -------------- 263 264 function Capacity (Container : Vector) return Count_Type is 265 begin 266 return Container.Elements'Length; 267 end Capacity; 268 269 ----------- 270 -- Clear -- 271 ----------- 272 273 procedure Clear (Container : in out Vector) is 274 begin 275 Container.Last := No_Index; 276 end Clear; 277 278 -------------- 279 -- Contains -- 280 -------------- 281 282 function Contains 283 (Container : Vector; 284 Item : Element_Type) return Boolean 285 is 286 begin 287 return Find_Index (Container, Item) /= No_Index; 288 end Contains; 289 290 ---------- 291 -- Copy -- 292 ---------- 293 294 function Copy 295 (Source : Vector; 296 Capacity : Count_Type := 0) return Vector 297 is 298 LS : constant Count_Type := Length (Source); 299 C : Count_Type; 300 301 begin 302 if Capacity = 0 then 303 C := LS; 304 elsif Capacity >= LS and then Capacity in Capacity_Range then 305 C := Capacity; 306 else 307 raise Capacity_Error; 308 end if; 309 310 return Target : Vector (C) do 311 Target.Elements (1 .. LS) := Source.Elements (1 .. LS); 312 Target.Last := Source.Last; 313 end return; 314 end Copy; 315 316 --------------------- 317 -- Current_To_Last -- 318 --------------------- 319 320 function Current_To_Last 321 (Container : Vector; 322 Current : Cursor) return Vector 323 is 324 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); 325 326 begin 327 if Current = No_Element then 328 Clear (C); 329 return C; 330 331 elsif not Has_Element (Container, Current) then 332 raise Constraint_Error; 333 334 else 335 while C.Last /= Container.Last - Current.Index + 1 loop 336 Delete_First (C); 337 end loop; 338 339 return C; 340 end if; 341 end Current_To_Last; 342 343 ------------ 344 -- Delete -- 345 ------------ 346 347 procedure Delete 348 (Container : in out Vector; 349 Index : Extended_Index; 350 Count : Count_Type := 1) 351 is 352 begin 353 if Index < Index_Type'First then 354 raise Constraint_Error with "Index is out of range (too small)"; 355 end if; 356 357 if Index > Container.Last then 358 if Index > Container.Last + 1 then 359 raise Constraint_Error with "Index is out of range (too large)"; 360 end if; 361 362 return; 363 end if; 364 365 if Count = 0 then 366 return; 367 end if; 368 369 declare 370 I_As_Int : constant Int := Int (Index); 371 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); 372 373 Count1 : constant Int'Base := Count_Type'Pos (Count); 374 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; 375 N : constant Int'Base := Int'Min (Count1, Count2); 376 377 J_As_Int : constant Int'Base := I_As_Int + N; 378 379 begin 380 if J_As_Int > Old_Last_As_Int then 381 Container.Last := Index - 1; 382 383 else 384 declare 385 EA : Elements_Array renames Container.Elements; 386 387 II : constant Int'Base := I_As_Int - Int (No_Index); 388 I : constant Count_Type := Count_Type (II); 389 390 JJ : constant Int'Base := J_As_Int - Int (No_Index); 391 J : constant Count_Type := Count_Type (JJ); 392 393 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; 394 New_Last : constant Index_Type := 395 Index_Type (New_Last_As_Int); 396 397 KK : constant Int := New_Last_As_Int - Int (No_Index); 398 K : constant Count_Type := Count_Type (KK); 399 400 begin 401 EA (I .. K) := EA (J .. Length (Container)); 402 Container.Last := New_Last; 403 end; 404 end if; 405 end; 406 end Delete; 407 408 procedure Delete 409 (Container : in out Vector; 410 Position : in out Cursor; 411 Count : Count_Type := 1) 412 is 413 begin 414 if not Position.Valid then 415 raise Constraint_Error with "Position cursor has no element"; 416 end if; 417 418 if Position.Index > Container.Last then 419 raise Program_Error with "Position index is out of range"; 420 end if; 421 422 Delete (Container, Position.Index, Count); 423 Position := No_Element; 424 end Delete; 425 426 ------------------ 427 -- Delete_First -- 428 ------------------ 429 430 procedure Delete_First 431 (Container : in out Vector; 432 Count : Count_Type := 1) 433 is 434 begin 435 if Count = 0 then 436 return; 437 end if; 438 439 if Count >= Length (Container) then 440 Clear (Container); 441 return; 442 end if; 443 444 Delete (Container, Index_Type'First, Count); 445 end Delete_First; 446 447 ----------------- 448 -- Delete_Last -- 449 ----------------- 450 451 procedure Delete_Last 452 (Container : in out Vector; 453 Count : Count_Type := 1) 454 is 455 Index : Int'Base; 456 457 begin 458 if Count = 0 then 459 return; 460 end if; 461 462 Index := Int'Base (Container.Last) - Int'Base (Count); 463 464 if Index < Index_Type'Pos (Index_Type'First) then 465 Container.Last := No_Index; 466 else 467 Container.Last := Index_Type (Index); 468 end if; 469 end Delete_Last; 470 471 ------------- 472 -- Element -- 473 ------------- 474 475 function Element 476 (Container : Vector; 477 Index : Index_Type) return Element_Type 478 is 479 begin 480 if Index > Container.Last then 481 raise Constraint_Error with "Index is out of range"; 482 end if; 483 484 declare 485 II : constant Int'Base := Int (Index) - Int (No_Index); 486 I : constant Count_Type := Count_Type (II); 487 begin 488 return Get_Element (Container, I); 489 end; 490 end Element; 491 492 function Element 493 (Container : Vector; 494 Position : Cursor) return Element_Type 495 is 496 Lst : constant Index_Type := Last_Index (Container); 497 498 begin 499 if not Position.Valid then 500 raise Constraint_Error with "Position cursor has no element"; 501 end if; 502 503 if Position.Index > Lst then 504 raise Constraint_Error with "Position cursor is out of range"; 505 end if; 506 507 declare 508 II : constant Int'Base := Int (Position.Index) - Int (No_Index); 509 I : constant Count_Type := Count_Type (II); 510 begin 511 return Get_Element (Container, I); 512 end; 513 end Element; 514 515 ---------- 516 -- Find -- 517 ---------- 518 519 function Find 520 (Container : Vector; 521 Item : Element_Type; 522 Position : Cursor := No_Element) return Cursor 523 is 524 K : Count_Type; 525 Last : constant Index_Type := Last_Index (Container); 526 527 begin 528 if Position.Valid then 529 if Position.Index > Last_Index (Container) then 530 raise Program_Error with "Position index is out of range"; 531 end if; 532 end if; 533 534 K := Count_Type (Int (Position.Index) - Int (No_Index)); 535 536 for J in Position.Index .. Last loop 537 if Get_Element (Container, K) = Item then 538 return Cursor'(Index => J, others => <>); 539 end if; 540 541 K := K + 1; 542 end loop; 543 544 return No_Element; 545 end Find; 546 547 ---------------- 548 -- Find_Index -- 549 ---------------- 550 551 function Find_Index 552 (Container : Vector; 553 Item : Element_Type; 554 Index : Index_Type := Index_Type'First) return Extended_Index 555 is 556 K : Count_Type; 557 Last : constant Index_Type := Last_Index (Container); 558 559 begin 560 K := Count_Type (Int (Index) - Int (No_Index)); 561 for Indx in Index .. Last loop 562 if Get_Element (Container, K) = Item then 563 return Indx; 564 end if; 565 566 K := K + 1; 567 end loop; 568 569 return No_Index; 570 end Find_Index; 571 572 ----------- 573 -- First -- 574 ----------- 575 576 function First (Container : Vector) return Cursor is 577 begin 578 if Is_Empty (Container) then 579 return No_Element; 580 end if; 581 582 return (True, Index_Type'First); 583 end First; 584 585 ------------------- 586 -- First_Element -- 587 ------------------- 588 589 function First_Element (Container : Vector) return Element_Type is 590 begin 591 if Is_Empty (Container) then 592 raise Constraint_Error with "Container is empty"; 593 end if; 594 595 return Get_Element (Container, 1); 596 end First_Element; 597 598 ----------------- 599 -- First_Index -- 600 ----------------- 601 602 function First_Index (Container : Vector) return Index_Type is 603 pragma Unreferenced (Container); 604 begin 605 return Index_Type'First; 606 end First_Index; 607 608 ----------------------- 609 -- First_To_Previous -- 610 ----------------------- 611 612 function First_To_Previous 613 (Container : Vector; 614 Current : Cursor) return Vector 615 is 616 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); 617 618 begin 619 if Current = No_Element then 620 return C; 621 622 elsif not Has_Element (Container, Current) then 623 raise Constraint_Error; 624 625 else 626 while C.Last /= Current.Index - 1 loop 627 Delete_Last (C); 628 end loop; 629 630 return C; 631 end if; 632 end First_To_Previous; 633 634 --------------------- 635 -- Generic_Sorting -- 636 --------------------- 637 638 package body Generic_Sorting is 639 640 --------------- 641 -- Is_Sorted -- 642 --------------- 643 644 function Is_Sorted (Container : Vector) return Boolean is 645 Last : constant Index_Type := Last_Index (Container); 646 647 begin 648 if Container.Last <= Last then 649 return True; 650 end if; 651 652 declare 653 L : constant Count_Type := Length (Container); 654 begin 655 for J in Count_Type range 1 .. L - 1 loop 656 if Get_Element (Container, J + 1) < 657 Get_Element (Container, J) 658 then 659 return False; 660 end if; 661 end loop; 662 end; 663 664 return True; 665 end Is_Sorted; 666 667 ----------- 668 -- Merge -- 669 ----------- 670 671 procedure Merge (Target, Source : in out Vector) is 672 begin 673 declare 674 TA : Elements_Array renames Target.Elements; 675 SA : Elements_Array renames Source.Elements; 676 677 I, J : Count_Type; 678 679 begin 680 -- ??? 681 -- if Target.Last < Index_Type'First then 682 -- Move (Target => Target, Source => Source); 683 -- return; 684 -- end if; 685 686 if Target'Address = Source'Address then 687 return; 688 end if; 689 690 if Source.Last < Index_Type'First then 691 return; 692 end if; 693 694 -- I think we're missing this check in a-convec.adb... ??? 695 696 I := Length (Target); 697 Set_Length (Target, I + Length (Source)); 698 699 J := Length (Target); 700 while not Is_Empty (Source) loop 701 pragma Assert (Length (Source) <= 1 702 or else not (SA (Length (Source)) < 703 SA (Length (Source) - 1))); 704 705 if I = 0 then 706 TA (1 .. J) := SA (1 .. Length (Source)); 707 Source.Last := No_Index; 708 return; 709 end if; 710 711 pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1))); 712 713 if SA (Length (Source)) < TA (I) then 714 TA (J) := TA (I); 715 I := I - 1; 716 717 else 718 TA (J) := SA (Length (Source)); 719 Source.Last := Source.Last - 1; 720 end if; 721 722 J := J - 1; 723 end loop; 724 end; 725 end Merge; 726 727 ---------- 728 -- Sort -- 729 ---------- 730 731 procedure Sort (Container : in out Vector) 732 is 733 procedure Sort is 734 new Generic_Array_Sort 735 (Index_Type => Count_Type, 736 Element_Type => Element_Type, 737 Array_Type => Elements_Array, 738 "<" => "<"); 739 740 begin 741 if Container.Last <= Index_Type'First then 742 return; 743 end if; 744 745 Sort (Container.Elements (1 .. Length (Container))); 746 end Sort; 747 748 end Generic_Sorting; 749 750 ----------------- 751 -- Get_Element -- 752 ----------------- 753 754 function Get_Element 755 (Container : Vector; 756 Position : Count_Type) return Element_Type 757 is 758 begin 759 return Container.Elements (Position); 760 end Get_Element; 761 762 ----------------- 763 -- Has_Element -- 764 ----------------- 765 766 function Has_Element 767 (Container : Vector; 768 Position : Cursor) return Boolean 769 is 770 begin 771 if not Position.Valid then 772 return False; 773 else 774 return Position.Index <= Last_Index (Container); 775 end if; 776 end Has_Element; 777 778 ------------ 779 -- Insert -- 780 ------------ 781 782 procedure Insert 783 (Container : in out Vector; 784 Before : Extended_Index; 785 New_Item : Element_Type; 786 Count : Count_Type := 1) 787 is 788 N : constant Int := Count_Type'Pos (Count); 789 790 First : constant Int := Int (Index_Type'First); 791 New_Last_As_Int : Int'Base; 792 New_Last : Index_Type; 793 New_Length : UInt; 794 Max_Length : constant UInt := UInt (Container.Capacity); 795 796 begin 797 if Before < Index_Type'First then 798 raise Constraint_Error with 799 "Before index is out of range (too small)"; 800 end if; 801 802 if Before > Container.Last 803 and then Before > Container.Last + 1 804 then 805 raise Constraint_Error with 806 "Before index is out of range (too large)"; 807 end if; 808 809 if Count = 0 then 810 return; 811 end if; 812 813 declare 814 Old_Last_As_Int : constant Int := Int (Container.Last); 815 816 begin 817 if Old_Last_As_Int > Int'Last - N then 818 raise Constraint_Error with "new length is out of range"; 819 end if; 820 821 New_Last_As_Int := Old_Last_As_Int + N; 822 823 if New_Last_As_Int > Int (Index_Type'Last) then 824 raise Constraint_Error with "new length is out of range"; 825 end if; 826 827 New_Length := UInt (New_Last_As_Int - First + Int'(1)); 828 829 if New_Length > Max_Length then 830 raise Constraint_Error with "new length is out of range"; 831 end if; 832 833 New_Last := Index_Type (New_Last_As_Int); 834 835 -- Resolve issue of capacity vs. max index ??? 836 end; 837 838 declare 839 EA : Elements_Array renames Container.Elements; 840 841 BB : constant Int'Base := Int (Before) - Int (No_Index); 842 B : constant Count_Type := Count_Type (BB); 843 844 LL : constant Int'Base := New_Last_As_Int - Int (No_Index); 845 L : constant Count_Type := Count_Type (LL); 846 847 begin 848 if Before <= Container.Last then 849 declare 850 II : constant Int'Base := BB + N; 851 I : constant Count_Type := Count_Type (II); 852 begin 853 EA (I .. L) := EA (B .. Length (Container)); 854 EA (B .. I - 1) := (others => New_Item); 855 end; 856 857 else 858 EA (B .. L) := (others => New_Item); 859 end if; 860 end; 861 862 Container.Last := New_Last; 863 end Insert; 864 865 procedure Insert 866 (Container : in out Vector; 867 Before : Extended_Index; 868 New_Item : Vector) 869 is 870 N : constant Count_Type := Length (New_Item); 871 872 begin 873 if Before < Index_Type'First then 874 raise Constraint_Error with 875 "Before index is out of range (too small)"; 876 end if; 877 878 if Before > Container.Last 879 and then Before > Container.Last + 1 880 then 881 raise Constraint_Error with 882 "Before index is out of range (too large)"; 883 end if; 884 885 if N = 0 then 886 return; 887 end if; 888 889 Insert_Space (Container, Before, Count => N); 890 891 declare 892 Dst_Last_As_Int : constant Int'Base := 893 Int (Before) + Int (N) - 1 - Int (No_Index); 894 895 Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int); 896 897 BB : constant Int'Base := Int (Before) - Int (No_Index); 898 B : constant Count_Type := Count_Type (BB); 899 900 begin 901 if Container'Address /= New_Item'Address then 902 Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N); 903 return; 904 end if; 905 906 declare 907 Src : Elements_Array renames Container.Elements (1 .. B - 1); 908 909 Index_As_Int : constant Int'Base := BB + Src'Length - 1; 910 911 Index : constant Count_Type := Count_Type (Index_As_Int); 912 913 Dst : Elements_Array renames Container.Elements (B .. Index); 914 915 begin 916 Dst := Src; 917 end; 918 919 if Dst_Last = Length (Container) then 920 return; 921 end if; 922 923 declare 924 Src : Elements_Array renames 925 Container.Elements (Dst_Last + 1 .. Length (Container)); 926 927 Index_As_Int : constant Int'Base := 928 Dst_Last_As_Int - Src'Length + 1; 929 930 Index : constant Count_Type := Count_Type (Index_As_Int); 931 932 Dst : Elements_Array renames 933 Container.Elements (Index .. Dst_Last); 934 935 begin 936 Dst := Src; 937 end; 938 end; 939 end Insert; 940 941 procedure Insert 942 (Container : in out Vector; 943 Before : Cursor; 944 New_Item : Vector) 945 is 946 Index : Index_Type'Base; 947 948 begin 949 if Is_Empty (New_Item) then 950 return; 951 end if; 952 953 if not Before.Valid 954 or else Before.Index > Container.Last 955 then 956 if Container.Last = Index_Type'Last then 957 raise Constraint_Error with 958 "vector is already at its maximum length"; 959 end if; 960 961 Index := Container.Last + 1; 962 963 else 964 Index := Before.Index; 965 end if; 966 967 Insert (Container, Index, New_Item); 968 end Insert; 969 970 procedure Insert 971 (Container : in out Vector; 972 Before : Cursor; 973 New_Item : Vector; 974 Position : out Cursor) 975 is 976 Index : Index_Type'Base; 977 978 begin 979 if Is_Empty (New_Item) then 980 if not Before.Valid 981 or else Before.Index > Container.Last 982 then 983 Position := No_Element; 984 else 985 Position := (True, Before.Index); 986 end if; 987 988 return; 989 end if; 990 991 if not Before.Valid 992 or else Before.Index > Container.Last 993 then 994 if Container.Last = Index_Type'Last then 995 raise Constraint_Error with 996 "vector is already at its maximum length"; 997 end if; 998 999 Index := Container.Last + 1; 1000 1001 else 1002 Index := Before.Index; 1003 end if; 1004 1005 Insert (Container, Index, New_Item); 1006 1007 Position := Cursor'(True, Index); 1008 end Insert; 1009 1010 procedure Insert 1011 (Container : in out Vector; 1012 Before : Cursor; 1013 New_Item : Element_Type; 1014 Count : Count_Type := 1) 1015 is 1016 Index : Index_Type'Base; 1017 1018 begin 1019 if Count = 0 then 1020 return; 1021 end if; 1022 1023 if not Before.Valid 1024 or else Before.Index > Container.Last 1025 then 1026 if Container.Last = Index_Type'Last then 1027 raise Constraint_Error with 1028 "vector is already at its maximum length"; 1029 end if; 1030 1031 Index := Container.Last + 1; 1032 1033 else 1034 Index := Before.Index; 1035 end if; 1036 1037 Insert (Container, Index, New_Item, Count); 1038 end Insert; 1039 1040 procedure Insert 1041 (Container : in out Vector; 1042 Before : Cursor; 1043 New_Item : Element_Type; 1044 Position : out Cursor; 1045 Count : Count_Type := 1) 1046 is 1047 Index : Index_Type'Base; 1048 1049 begin 1050 if Count = 0 then 1051 if not Before.Valid 1052 or else Before.Index > Container.Last 1053 then 1054 Position := No_Element; 1055 else 1056 Position := (True, Before.Index); 1057 end if; 1058 1059 return; 1060 end if; 1061 1062 if not Before.Valid 1063 or else Before.Index > Container.Last 1064 then 1065 if Container.Last = Index_Type'Last then 1066 raise Constraint_Error with 1067 "vector is already at its maximum length"; 1068 end if; 1069 1070 Index := Container.Last + 1; 1071 1072 else 1073 Index := Before.Index; 1074 end if; 1075 1076 Insert (Container, Index, New_Item, Count); 1077 1078 Position := Cursor'(True, Index); 1079 end Insert; 1080 1081 ------------------ 1082 -- Insert_Space -- 1083 ------------------ 1084 1085 procedure Insert_Space 1086 (Container : in out Vector; 1087 Before : Extended_Index; 1088 Count : Count_Type := 1) 1089 is 1090 N : constant Int := Count_Type'Pos (Count); 1091 1092 First : constant Int := Int (Index_Type'First); 1093 New_Last_As_Int : Int'Base; 1094 New_Last : Index_Type; 1095 New_Length : UInt; 1096 Max_Length : constant UInt := UInt (Count_Type'Last); 1097 1098 begin 1099 if Before < Index_Type'First then 1100 raise Constraint_Error with 1101 "Before index is out of range (too small)"; 1102 end if; 1103 1104 if Before > Container.Last 1105 and then Before > Container.Last + 1 1106 then 1107 raise Constraint_Error with 1108 "Before index is out of range (too large)"; 1109 end if; 1110 1111 if Count = 0 then 1112 return; 1113 end if; 1114 1115 declare 1116 Old_Last_As_Int : constant Int := Int (Container.Last); 1117 1118 begin 1119 if Old_Last_As_Int > Int'Last - N then 1120 raise Constraint_Error with "new length is out of range"; 1121 end if; 1122 1123 New_Last_As_Int := Old_Last_As_Int + N; 1124 1125 if New_Last_As_Int > Int (Index_Type'Last) then 1126 raise Constraint_Error with "new length is out of range"; 1127 end if; 1128 1129 New_Length := UInt (New_Last_As_Int - First + Int'(1)); 1130 1131 if New_Length > Max_Length then 1132 raise Constraint_Error with "new length is out of range"; 1133 end if; 1134 1135 New_Last := Index_Type (New_Last_As_Int); 1136 1137 -- Resolve issue of capacity vs. max index ??? 1138 end; 1139 1140 declare 1141 EA : Elements_Array renames Container.Elements; 1142 1143 BB : constant Int'Base := Int (Before) - Int (No_Index); 1144 B : constant Count_Type := Count_Type (BB); 1145 1146 LL : constant Int'Base := New_Last_As_Int - Int (No_Index); 1147 L : constant Count_Type := Count_Type (LL); 1148 1149 begin 1150 if Before <= Container.Last then 1151 declare 1152 II : constant Int'Base := BB + N; 1153 I : constant Count_Type := Count_Type (II); 1154 begin 1155 EA (I .. L) := EA (B .. Length (Container)); 1156 end; 1157 end if; 1158 end; 1159 1160 Container.Last := New_Last; 1161 end Insert_Space; 1162 1163 -------------- 1164 -- Is_Empty -- 1165 -------------- 1166 1167 function Is_Empty (Container : Vector) return Boolean is 1168 begin 1169 return Last_Index (Container) < Index_Type'First; 1170 end Is_Empty; 1171 1172 ---------- 1173 -- Last -- 1174 ---------- 1175 1176 function Last (Container : Vector) return Cursor is 1177 begin 1178 if Is_Empty (Container) then 1179 return No_Element; 1180 end if; 1181 1182 return (True, Last_Index (Container)); 1183 end Last; 1184 1185 ------------------ 1186 -- Last_Element -- 1187 ------------------ 1188 1189 function Last_Element (Container : Vector) return Element_Type is 1190 begin 1191 if Is_Empty (Container) then 1192 raise Constraint_Error with "Container is empty"; 1193 end if; 1194 1195 return Get_Element (Container, Length (Container)); 1196 end Last_Element; 1197 1198 ---------------- 1199 -- Last_Index -- 1200 ---------------- 1201 1202 function Last_Index (Container : Vector) return Extended_Index is 1203 begin 1204 return Container.Last; 1205 end Last_Index; 1206 1207 ------------ 1208 -- Length -- 1209 ------------ 1210 1211 function Length (Container : Vector) return Count_Type is 1212 L : constant Int := Int (Last_Index (Container)); 1213 F : constant Int := Int (Index_Type'First); 1214 N : constant Int'Base := L - F + 1; 1215 1216 begin 1217 return Count_Type (N); 1218 end Length; 1219 1220 ---------- 1221 -- Move -- 1222 ---------- 1223 1224 procedure Move 1225 (Target : in out Vector; 1226 Source : in out Vector) 1227 is 1228 N : constant Count_Type := Length (Source); 1229 1230 begin 1231 if Target'Address = Source'Address then 1232 return; 1233 end if; 1234 1235 if N > Target.Capacity then 1236 raise Constraint_Error with -- correct exception here??? 1237 "length of Source is greater than capacity of Target"; 1238 end if; 1239 1240 -- We could also write this as a loop, and incrementally 1241 -- copy elements from source to target. 1242 1243 Target.Last := No_Index; -- in case array assignment files 1244 Target.Elements (1 .. N) := Source.Elements (1 .. N); 1245 1246 Target.Last := Source.Last; 1247 Source.Last := No_Index; 1248 end Move; 1249 1250 ---------- 1251 -- Next -- 1252 ---------- 1253 1254 function Next (Container : Vector; Position : Cursor) return Cursor is 1255 begin 1256 if not Position.Valid then 1257 return No_Element; 1258 end if; 1259 1260 if Position.Index < Last_Index (Container) then 1261 return (True, Position.Index + 1); 1262 end if; 1263 1264 return No_Element; 1265 end Next; 1266 1267 ---------- 1268 -- Next -- 1269 ---------- 1270 1271 procedure Next (Container : Vector; Position : in out Cursor) is 1272 begin 1273 if not Position.Valid then 1274 return; 1275 end if; 1276 1277 if Position.Index < Last_Index (Container) then 1278 Position.Index := Position.Index + 1; 1279 else 1280 Position := No_Element; 1281 end if; 1282 end Next; 1283 1284 ------------- 1285 -- Prepend -- 1286 ------------- 1287 1288 procedure Prepend (Container : in out Vector; New_Item : Vector) is 1289 begin 1290 Insert (Container, Index_Type'First, New_Item); 1291 end Prepend; 1292 1293 procedure Prepend 1294 (Container : in out Vector; 1295 New_Item : Element_Type; 1296 Count : Count_Type := 1) 1297 is 1298 begin 1299 Insert (Container, 1300 Index_Type'First, 1301 New_Item, 1302 Count); 1303 end Prepend; 1304 1305 -------------- 1306 -- Previous -- 1307 -------------- 1308 1309 procedure Previous (Container : Vector; Position : in out Cursor) is 1310 begin 1311 if not Position.Valid then 1312 return; 1313 end if; 1314 1315 if Position.Index > Index_Type'First 1316 and then Position.Index <= Last_Index (Container) 1317 then 1318 Position.Index := Position.Index - 1; 1319 else 1320 Position := No_Element; 1321 end if; 1322 end Previous; 1323 1324 function Previous (Container : Vector; Position : Cursor) return Cursor is 1325 begin 1326 if not Position.Valid then 1327 return No_Element; 1328 end if; 1329 1330 if Position.Index > Index_Type'First 1331 and then Position.Index <= Last_Index (Container) 1332 then 1333 return (True, Position.Index - 1); 1334 end if; 1335 1336 return No_Element; 1337 end Previous; 1338 1339 --------------------- 1340 -- Replace_Element -- 1341 --------------------- 1342 1343 procedure Replace_Element 1344 (Container : in out Vector; 1345 Index : Index_Type; 1346 New_Item : Element_Type) 1347 is 1348 begin 1349 if Index > Container.Last then 1350 raise Constraint_Error with "Index is out of range"; 1351 end if; 1352 1353 declare 1354 II : constant Int'Base := Int (Index) - Int (No_Index); 1355 I : constant Count_Type := Count_Type (II); 1356 1357 begin 1358 Container.Elements (I) := New_Item; 1359 end; 1360 end Replace_Element; 1361 1362 procedure Replace_Element 1363 (Container : in out Vector; 1364 Position : Cursor; 1365 New_Item : Element_Type) 1366 is 1367 begin 1368 if not Position.Valid then 1369 raise Constraint_Error with "Position cursor has no element"; 1370 end if; 1371 1372 if Position.Index > Container.Last then 1373 raise Constraint_Error with "Position cursor is out of range"; 1374 end if; 1375 1376 declare 1377 II : constant Int'Base := Int (Position.Index) - Int (No_Index); 1378 I : constant Count_Type := Count_Type (II); 1379 begin 1380 Container.Elements (I) := New_Item; 1381 end; 1382 end Replace_Element; 1383 1384 ---------------------- 1385 -- Reserve_Capacity -- 1386 ---------------------- 1387 1388 procedure Reserve_Capacity 1389 (Container : in out Vector; 1390 Capacity : Count_Type) 1391 is 1392 begin 1393 if Capacity > Container.Capacity then 1394 raise Constraint_Error with "Capacity is out of range"; 1395 end if; 1396 end Reserve_Capacity; 1397 1398 ---------------------- 1399 -- Reverse_Elements -- 1400 ---------------------- 1401 1402 procedure Reverse_Elements (Container : in out Vector) is 1403 begin 1404 if Length (Container) <= 1 then 1405 return; 1406 end if; 1407 1408 declare 1409 I, J : Count_Type; 1410 E : Elements_Array renames Container.Elements; 1411 1412 begin 1413 I := 1; 1414 J := Length (Container); 1415 while I < J loop 1416 declare 1417 EI : constant Element_Type := E (I); 1418 begin 1419 E (I) := E (J); 1420 E (J) := EI; 1421 end; 1422 1423 I := I + 1; 1424 J := J - 1; 1425 end loop; 1426 end; 1427 end Reverse_Elements; 1428 1429 ------------------ 1430 -- Reverse_Find -- 1431 ------------------ 1432 1433 function Reverse_Find 1434 (Container : Vector; 1435 Item : Element_Type; 1436 Position : Cursor := No_Element) return Cursor 1437 is 1438 Last : Index_Type'Base; 1439 K : Count_Type; 1440 1441 begin 1442 if not Position.Valid 1443 or else Position.Index > Last_Index (Container) 1444 then 1445 Last := Last_Index (Container); 1446 else 1447 Last := Position.Index; 1448 end if; 1449 1450 K := Count_Type (Int (Last) - Int (No_Index)); 1451 for Indx in reverse Index_Type'First .. Last loop 1452 if Get_Element (Container, K) = Item then 1453 return (True, Indx); 1454 end if; 1455 1456 K := K - 1; 1457 end loop; 1458 1459 return No_Element; 1460 end Reverse_Find; 1461 1462 ------------------------ 1463 -- Reverse_Find_Index -- 1464 ------------------------ 1465 1466 function Reverse_Find_Index 1467 (Container : Vector; 1468 Item : Element_Type; 1469 Index : Index_Type := Index_Type'Last) return Extended_Index 1470 is 1471 Last : Index_Type'Base; 1472 K : Count_Type; 1473 1474 begin 1475 if Index > Last_Index (Container) then 1476 Last := Last_Index (Container); 1477 else 1478 Last := Index; 1479 end if; 1480 1481 K := Count_Type (Int (Last) - Int (No_Index)); 1482 for Indx in reverse Index_Type'First .. Last loop 1483 if Get_Element (Container, K) = Item then 1484 return Indx; 1485 end if; 1486 1487 K := K - 1; 1488 end loop; 1489 1490 return No_Index; 1491 end Reverse_Find_Index; 1492 1493 ---------------- 1494 -- Set_Length -- 1495 ---------------- 1496 1497 procedure Set_Length 1498 (Container : in out Vector; 1499 New_Length : Count_Type) 1500 is 1501 begin 1502 if New_Length = Formal_Vectors.Length (Container) then 1503 return; 1504 end if; 1505 1506 if New_Length > Container.Capacity then 1507 raise Constraint_Error; -- ??? 1508 end if; 1509 1510 declare 1511 Last_As_Int : constant Int'Base := 1512 Int (Index_Type'First) + Int (New_Length) - 1; 1513 begin 1514 Container.Last := Index_Type'Base (Last_As_Int); 1515 end; 1516 end Set_Length; 1517 1518 ------------------ 1519 -- Strict_Equal -- 1520 ------------------ 1521 1522 function Strict_Equal (Left, Right : Vector) return Boolean is 1523 begin 1524 -- On bounded vectors, cursors are indexes. As a consequence, two 1525 -- vectors always have the same cursor at the same position and 1526 -- Strict_Equal is simply = 1527 1528 return Left = Right; 1529 end Strict_Equal; 1530 1531 ---------- 1532 -- Swap -- 1533 ---------- 1534 1535 procedure Swap (Container : in out Vector; I, J : Index_Type) is 1536 begin 1537 if I > Container.Last then 1538 raise Constraint_Error with "I index is out of range"; 1539 end if; 1540 1541 if J > Container.Last then 1542 raise Constraint_Error with "J index is out of range"; 1543 end if; 1544 1545 if I = J then 1546 return; 1547 end if; 1548 1549 declare 1550 II : constant Int'Base := Int (I) - Int (No_Index); 1551 JJ : constant Int'Base := Int (J) - Int (No_Index); 1552 1553 EI : Element_Type renames Container.Elements (Count_Type (II)); 1554 EJ : Element_Type renames Container.Elements (Count_Type (JJ)); 1555 1556 EI_Copy : constant Element_Type := EI; 1557 1558 begin 1559 EI := EJ; 1560 EJ := EI_Copy; 1561 end; 1562 end Swap; 1563 1564 procedure Swap (Container : in out Vector; I, J : Cursor) is 1565 begin 1566 if not I.Valid then 1567 raise Constraint_Error with "I cursor has no element"; 1568 end if; 1569 1570 if not J.Valid then 1571 raise Constraint_Error with "J cursor has no element"; 1572 end if; 1573 1574 Swap (Container, I.Index, J.Index); 1575 end Swap; 1576 1577 --------------- 1578 -- To_Cursor -- 1579 --------------- 1580 1581 function To_Cursor 1582 (Container : Vector; 1583 Index : Extended_Index) return Cursor 1584 is 1585 begin 1586 if Index not in Index_Type'First .. Last_Index (Container) then 1587 return No_Element; 1588 end if; 1589 1590 return Cursor'(True, Index); 1591 end To_Cursor; 1592 1593 -------------- 1594 -- To_Index -- 1595 -------------- 1596 1597 function To_Index (Position : Cursor) return Extended_Index is 1598 begin 1599 if not Position.Valid then 1600 return No_Index; 1601 end if; 1602 1603 return Position.Index; 1604 end To_Index; 1605 1606 --------------- 1607 -- To_Vector -- 1608 --------------- 1609 1610 function To_Vector 1611 (New_Item : Element_Type; 1612 Length : Count_Type) return Vector 1613 is 1614 begin 1615 if Length = 0 then 1616 return Empty_Vector; 1617 end if; 1618 1619 declare 1620 First : constant Int := Int (Index_Type'First); 1621 Last_As_Int : constant Int'Base := First + Int (Length) - 1; 1622 Last : Index_Type; 1623 1624 begin 1625 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then 1626 raise Constraint_Error with "Length is out of range"; -- ??? 1627 end if; 1628 1629 Last := Index_Type (Last_As_Int); 1630 1631 return (Length, (others => New_Item), Last => Last, 1632 others => <>); 1633 end; 1634 end To_Vector; 1635 1636end Ada.Containers.Formal_Vectors; 1637