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-2012, 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 --------- 41 -- "&" -- 42 --------- 43 44 function "&" (Left, Right : Vector) return Vector is 45 LN : constant Count_Type := Length (Left); 46 RN : constant Count_Type := Length (Right); 47 48 begin 49 if LN = 0 then 50 if RN = 0 then 51 return Empty_Vector; 52 end if; 53 54 declare 55 E : constant Elements_Array (1 .. Length (Right)) := 56 Right.Elements (1 .. RN); 57 begin 58 return (Length (Right), E, Last => Right.Last, others => <>); 59 end; 60 end if; 61 62 if RN = 0 then 63 declare 64 E : constant Elements_Array (1 .. Length (Left)) := 65 Left.Elements (1 .. LN); 66 begin 67 return (Length (Left), E, Last => Left.Last, others => <>); 68 end; 69 end if; 70 71 declare 72 N : constant Int'Base := Int (LN) + Int (RN); 73 Last_As_Int : Int'Base; 74 75 begin 76 if Int (No_Index) > Int'Last - N then 77 raise Constraint_Error with "new length is out of range"; 78 end if; 79 80 Last_As_Int := Int (No_Index) + N; 81 82 if Last_As_Int > Int (Index_Type'Last) then 83 raise Constraint_Error with "new length is out of range"; 84 end if; 85 86 -- TODO: should check whether length > max capacity (cnt_t'last) ??? 87 88 declare 89 Last : constant Index_Type := Index_Type (Last_As_Int); 90 91 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); 92 RE : Elements_Array renames Right.Elements (1 .. RN); 93 94 Capacity : constant Count_Type := Length (Left) + Length (Right); 95 96 begin 97 return (Capacity, LE & RE, Last => Last, others => <>); 98 end; 99 end; 100 end "&"; 101 102 function "&" (Left : Vector; Right : Element_Type) return Vector is 103 LN : constant Count_Type := Length (Left); 104 Last_As_Int : Int'Base; 105 106 begin 107 if LN = 0 then 108 return (1, (1 .. 1 => Right), Index_Type'First, others => <>); 109 end if; 110 111 if Int (Index_Type'First) > Int'Last - Int (LN) then 112 raise Constraint_Error with "new length is out of range"; 113 end if; 114 115 Last_As_Int := Int (Index_Type'First) + Int (LN); 116 117 if Last_As_Int > Int (Index_Type'Last) then 118 raise Constraint_Error with "new length is out of range"; 119 end if; 120 121 declare 122 Last : constant Index_Type := Index_Type (Last_As_Int); 123 LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); 124 125 Capacity : constant Count_Type := Length (Left) + 1; 126 127 begin 128 return (Capacity, LE & Right, Last => Last, others => <>); 129 end; 130 end "&"; 131 132 function "&" (Left : Element_Type; Right : Vector) return Vector is 133 RN : constant Count_Type := Length (Right); 134 Last_As_Int : Int'Base; 135 136 begin 137 if RN = 0 then 138 return (1, (1 .. 1 => Left), 139 Index_Type'First, others => <>); 140 end if; 141 142 if Int (Index_Type'First) > Int'Last - Int (RN) then 143 raise Constraint_Error with "new length is out of range"; 144 end if; 145 146 Last_As_Int := Int (Index_Type'First) + Int (RN); 147 148 if Last_As_Int > Int (Index_Type'Last) then 149 raise Constraint_Error with "new length is out of range"; 150 end if; 151 152 declare 153 Last : constant Index_Type := Index_Type (Last_As_Int); 154 RE : Elements_Array renames Right.Elements (1 .. RN); 155 Capacity : constant Count_Type := 1 + Length (Right); 156 begin 157 return (Capacity, Left & RE, Last => Last, others => <>); 158 end; 159 end "&"; 160 161 function "&" (Left, Right : Element_Type) return Vector is 162 begin 163 if Index_Type'First >= Index_Type'Last then 164 raise Constraint_Error with "new length is out of range"; 165 end if; 166 167 declare 168 Last : constant Index_Type := Index_Type'First + 1; 169 begin 170 return (2, (Left, Right), Last => Last, others => <>); 171 end; 172 end "&"; 173 174 --------- 175 -- "=" -- 176 --------- 177 178 function "=" (Left, Right : Vector) return Boolean is 179 begin 180 if Left'Address = Right'Address then 181 return True; 182 end if; 183 184 if Length (Left) /= Length (Right) then 185 return False; 186 end if; 187 188 for J in Count_Type range 1 .. Length (Left) loop 189 if Get_Element (Left, J) /= Get_Element (Right, J) then 190 return False; 191 end if; 192 end loop; 193 194 return True; 195 end "="; 196 197 ------------ 198 -- Append -- 199 ------------ 200 201 procedure Append (Container : in out Vector; New_Item : Vector) is 202 begin 203 if Is_Empty (New_Item) then 204 return; 205 end if; 206 207 if Container.Last = Index_Type'Last then 208 raise Constraint_Error with "vector is already at its maximum length"; 209 end if; 210 211 Insert (Container, Container.Last + 1, New_Item); 212 end Append; 213 214 procedure Append 215 (Container : in out Vector; 216 New_Item : Element_Type; 217 Count : Count_Type := 1) 218 is 219 begin 220 if Count = 0 then 221 return; 222 end if; 223 224 if Container.Last = Index_Type'Last then 225 raise Constraint_Error with "vector is already at its maximum length"; 226 end if; 227 228 -- TODO: should check whether length > max capacity (cnt_t'last) ??? 229 230 Insert (Container, Container.Last + 1, New_Item, Count); 231 end Append; 232 233 ------------ 234 -- Assign -- 235 ------------ 236 237 procedure Assign (Target : in out Vector; Source : Vector) is 238 LS : constant Count_Type := Length (Source); 239 240 begin 241 if Target'Address = Source'Address then 242 return; 243 end if; 244 245 if Target.Capacity < LS then 246 raise Constraint_Error; 247 end if; 248 249 Target.Clear; 250 251 Target.Elements (1 .. LS) := Source.Elements (1 .. LS); 252 Target.Last := Source.Last; 253 end Assign; 254 255 -------------- 256 -- Capacity -- 257 -------------- 258 259 function Capacity (Container : Vector) return Capacity_Subtype is 260 begin 261 return Container.Elements'Length; 262 end Capacity; 263 264 ----------- 265 -- Clear -- 266 ----------- 267 268 procedure Clear (Container : in out Vector) is 269 begin 270 if Container.Busy > 0 then 271 raise Program_Error with 272 "attempt to tamper with elements (vector is busy)"; 273 end if; 274 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 : Capacity_Subtype := 0) return Vector 297 is 298 LS : constant Count_Type := Length (Source); 299 C : Capacity_Subtype; 300 301 begin 302 if Capacity = 0 then 303 C := LS; 304 elsif Capacity >= LS then 305 C := Capacity; 306 else 307 raise Constraint_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 -- Delete -- 318 ------------ 319 320 procedure Delete 321 (Container : in out Vector; 322 Index : Extended_Index; 323 Count : Count_Type := 1) 324 is 325 begin 326 if Index < Index_Type'First then 327 raise Constraint_Error with "Index is out of range (too small)"; 328 end if; 329 330 if Index > Container.Last then 331 if Index > Container.Last + 1 then 332 raise Constraint_Error with "Index is out of range (too large)"; 333 end if; 334 335 return; 336 end if; 337 338 if Count = 0 then 339 return; 340 end if; 341 342 if Container.Busy > 0 then 343 raise Program_Error with 344 "attempt to tamper with elements (vector is busy)"; 345 end if; 346 347 declare 348 I_As_Int : constant Int := Int (Index); 349 Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); 350 351 Count1 : constant Int'Base := Count_Type'Pos (Count); 352 Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; 353 N : constant Int'Base := Int'Min (Count1, Count2); 354 355 J_As_Int : constant Int'Base := I_As_Int + N; 356 357 begin 358 if J_As_Int > Old_Last_As_Int then 359 Container.Last := Index - 1; 360 361 else 362 declare 363 EA : Elements_Array renames Container.Elements; 364 365 II : constant Int'Base := I_As_Int - Int (No_Index); 366 I : constant Count_Type := Count_Type (II); 367 368 JJ : constant Int'Base := J_As_Int - Int (No_Index); 369 J : constant Count_Type := Count_Type (JJ); 370 371 New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; 372 New_Last : constant Index_Type := 373 Index_Type (New_Last_As_Int); 374 375 KK : constant Int := New_Last_As_Int - Int (No_Index); 376 K : constant Count_Type := Count_Type (KK); 377 378 begin 379 EA (I .. K) := EA (J .. Length (Container)); 380 Container.Last := New_Last; 381 end; 382 end if; 383 end; 384 end Delete; 385 386 procedure Delete 387 (Container : in out Vector; 388 Position : in out Cursor; 389 Count : Count_Type := 1) 390 is 391 begin 392 if not Position.Valid then 393 raise Constraint_Error with "Position cursor has no element"; 394 end if; 395 396 if Position.Index > Container.Last then 397 raise Program_Error with "Position index is out of range"; 398 end if; 399 400 Delete (Container, Position.Index, Count); 401 Position := No_Element; 402 end Delete; 403 404 ------------------ 405 -- Delete_First -- 406 ------------------ 407 408 procedure Delete_First 409 (Container : in out Vector; 410 Count : Count_Type := 1) 411 is 412 begin 413 if Count = 0 then 414 return; 415 end if; 416 417 if Count >= Length (Container) then 418 Clear (Container); 419 return; 420 end if; 421 422 Delete (Container, Index_Type'First, Count); 423 end Delete_First; 424 425 ----------------- 426 -- Delete_Last -- 427 ----------------- 428 429 procedure Delete_Last 430 (Container : in out Vector; 431 Count : Count_Type := 1) 432 is 433 Index : Int'Base; 434 435 begin 436 if Count = 0 then 437 return; 438 end if; 439 440 if Container.Busy > 0 then 441 raise Program_Error with 442 "attempt to tamper with elements (vector is busy)"; 443 end if; 444 445 Index := Int'Base (Container.Last) - Int'Base (Count); 446 447 if Index < Index_Type'Pos (Index_Type'First) then 448 Container.Last := No_Index; 449 else 450 Container.Last := Index_Type (Index); 451 end if; 452 end Delete_Last; 453 454 ------------- 455 -- Element -- 456 ------------- 457 458 function Element 459 (Container : Vector; 460 Index : Index_Type) return Element_Type 461 is 462 begin 463 if Index > Container.Last then 464 raise Constraint_Error with "Index is out of range"; 465 end if; 466 467 declare 468 II : constant Int'Base := Int (Index) - Int (No_Index); 469 I : constant Count_Type := Count_Type (II); 470 begin 471 return Get_Element (Container, I); 472 end; 473 end Element; 474 475 function Element 476 (Container : Vector; 477 Position : Cursor) return Element_Type 478 is 479 Lst : constant Index_Type := Last_Index (Container); 480 481 begin 482 if not Position.Valid then 483 raise Constraint_Error with "Position cursor has no element"; 484 end if; 485 486 if Position.Index > Lst then 487 raise Constraint_Error with "Position cursor is out of range"; 488 end if; 489 490 declare 491 II : constant Int'Base := Int (Position.Index) - Int (No_Index); 492 I : constant Count_Type := Count_Type (II); 493 begin 494 return Get_Element (Container, I); 495 end; 496 end Element; 497 498 ---------- 499 -- Find -- 500 ---------- 501 502 function Find 503 (Container : Vector; 504 Item : Element_Type; 505 Position : Cursor := No_Element) return Cursor 506 is 507 K : Count_Type; 508 Last : constant Index_Type := Last_Index (Container); 509 510 begin 511 if Position.Valid then 512 if Position.Index > Last_Index (Container) then 513 raise Program_Error with "Position index is out of range"; 514 end if; 515 end if; 516 517 K := Count_Type (Int (Position.Index) - Int (No_Index)); 518 519 for J in Position.Index .. Last loop 520 if Get_Element (Container, K) = Item then 521 return Cursor'(Index => J, others => <>); 522 end if; 523 524 K := K + 1; 525 end loop; 526 527 return No_Element; 528 end Find; 529 530 ---------------- 531 -- Find_Index -- 532 ---------------- 533 534 function Find_Index 535 (Container : Vector; 536 Item : Element_Type; 537 Index : Index_Type := Index_Type'First) return Extended_Index 538 is 539 K : Count_Type; 540 Last : constant Index_Type := Last_Index (Container); 541 542 begin 543 K := Count_Type (Int (Index) - Int (No_Index)); 544 for Indx in Index .. Last loop 545 if Get_Element (Container, K) = Item then 546 return Indx; 547 end if; 548 549 K := K + 1; 550 end loop; 551 552 return No_Index; 553 end Find_Index; 554 555 ----------- 556 -- First -- 557 ----------- 558 559 function First (Container : Vector) return Cursor is 560 begin 561 if Is_Empty (Container) then 562 return No_Element; 563 end if; 564 565 return (True, Index_Type'First); 566 end First; 567 568 ------------------- 569 -- First_Element -- 570 ------------------- 571 572 function First_Element (Container : Vector) return Element_Type is 573 begin 574 if Is_Empty (Container) then 575 raise Constraint_Error with "Container is empty"; 576 end if; 577 578 return Get_Element (Container, 1); 579 end First_Element; 580 581 ----------------- 582 -- First_Index -- 583 ----------------- 584 585 function First_Index (Container : Vector) return Index_Type is 586 pragma Unreferenced (Container); 587 begin 588 return Index_Type'First; 589 end First_Index; 590 591 --------------------- 592 -- Generic_Sorting -- 593 --------------------- 594 595 package body Generic_Sorting is 596 597 --------------- 598 -- Is_Sorted -- 599 --------------- 600 601 function Is_Sorted (Container : Vector) return Boolean is 602 Last : constant Index_Type := Last_Index (Container); 603 604 begin 605 if Container.Last <= Last then 606 return True; 607 end if; 608 609 declare 610 L : constant Capacity_Subtype := Length (Container); 611 begin 612 for J in Count_Type range 1 .. L - 1 loop 613 if Get_Element (Container, J + 1) < 614 Get_Element (Container, J) 615 then 616 return False; 617 end if; 618 end loop; 619 end; 620 621 return True; 622 end Is_Sorted; 623 624 ----------- 625 -- Merge -- 626 ----------- 627 628 procedure Merge (Target, Source : in out Vector) is 629 begin 630 declare 631 TA : Elements_Array renames Target.Elements; 632 SA : Elements_Array renames Source.Elements; 633 634 I, J : Count_Type; 635 636 begin 637 -- ??? 638 -- if Target.Last < Index_Type'First then 639 -- Move (Target => Target, Source => Source); 640 -- return; 641 -- end if; 642 643 if Target'Address = Source'Address then 644 return; 645 end if; 646 647 if Source.Last < Index_Type'First then 648 return; 649 end if; 650 651 -- I think we're missing this check in a-convec.adb... ??? 652 653 if Target.Busy > 0 then 654 raise Program_Error with 655 "attempt to tamper with elements (vector is busy)"; 656 end if; 657 658 if Source.Busy > 0 then 659 raise Program_Error with 660 "attempt to tamper with elements (vector is busy)"; 661 end if; 662 663 I := Length (Target); 664 Target.Set_Length (I + Length (Source)); 665 666 J := Length (Target); 667 while not Source.Is_Empty loop 668 pragma Assert (Length (Source) <= 1 669 or else not (SA (Length (Source)) < 670 SA (Length (Source) - 1))); 671 672 if I = 0 then 673 TA (1 .. J) := SA (1 .. Length (Source)); 674 Source.Last := No_Index; 675 return; 676 end if; 677 678 pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1))); 679 680 if SA (Length (Source)) < TA (I) then 681 TA (J) := TA (I); 682 I := I - 1; 683 684 else 685 TA (J) := SA (Length (Source)); 686 Source.Last := Source.Last - 1; 687 end if; 688 689 J := J - 1; 690 end loop; 691 end; 692 end Merge; 693 694 ---------- 695 -- Sort -- 696 ---------- 697 698 procedure Sort (Container : in out Vector) 699 is 700 procedure Sort is 701 new Generic_Array_Sort 702 (Index_Type => Count_Type, 703 Element_Type => Element_Type, 704 Array_Type => Elements_Array, 705 "<" => "<"); 706 707 begin 708 if Container.Last <= Index_Type'First then 709 return; 710 end if; 711 712 if Container.Lock > 0 then 713 raise Program_Error with 714 "attempt to tamper with cursors (vector is locked)"; 715 end if; 716 717 Sort (Container.Elements (1 .. Length (Container))); 718 end Sort; 719 720 end Generic_Sorting; 721 722 ----------------- 723 -- Get_Element -- 724 ----------------- 725 726 function Get_Element 727 (Container : Vector; 728 Position : Count_Type) return Element_Type 729 is 730 begin 731 return Container.Elements (Position); 732 end Get_Element; 733 734 ----------------- 735 -- Has_Element -- 736 ----------------- 737 738 function Has_Element 739 (Container : Vector; 740 Position : Cursor) return Boolean 741 is 742 begin 743 if not Position.Valid then 744 return False; 745 else 746 return Position.Index <= Last_Index (Container); 747 end if; 748 end Has_Element; 749 750 ------------ 751 -- Insert -- 752 ------------ 753 754 procedure Insert 755 (Container : in out Vector; 756 Before : Extended_Index; 757 New_Item : Element_Type; 758 Count : Count_Type := 1) 759 is 760 N : constant Int := Count_Type'Pos (Count); 761 762 First : constant Int := Int (Index_Type'First); 763 New_Last_As_Int : Int'Base; 764 New_Last : Index_Type; 765 New_Length : UInt; 766 Max_Length : constant UInt := UInt (Container.Capacity); 767 768 begin 769 if Before < Index_Type'First then 770 raise Constraint_Error with 771 "Before index is out of range (too small)"; 772 end if; 773 774 if Before > Container.Last 775 and then Before > Container.Last + 1 776 then 777 raise Constraint_Error with 778 "Before index is out of range (too large)"; 779 end if; 780 781 if Count = 0 then 782 return; 783 end if; 784 785 declare 786 Old_Last_As_Int : constant Int := Int (Container.Last); 787 788 begin 789 if Old_Last_As_Int > Int'Last - N then 790 raise Constraint_Error with "new length is out of range"; 791 end if; 792 793 New_Last_As_Int := Old_Last_As_Int + N; 794 795 if New_Last_As_Int > Int (Index_Type'Last) then 796 raise Constraint_Error with "new length is out of range"; 797 end if; 798 799 New_Length := UInt (New_Last_As_Int - First + Int'(1)); 800 801 if New_Length > Max_Length then 802 raise Constraint_Error with "new length is out of range"; 803 end if; 804 805 New_Last := Index_Type (New_Last_As_Int); 806 807 -- Resolve issue of capacity vs. max index ??? 808 end; 809 810 if Container.Busy > 0 then 811 raise Program_Error with 812 "attempt to tamper with elements (vector is busy)"; 813 end if; 814 815 declare 816 EA : Elements_Array renames Container.Elements; 817 818 BB : constant Int'Base := Int (Before) - Int (No_Index); 819 B : constant Count_Type := Count_Type (BB); 820 821 LL : constant Int'Base := New_Last_As_Int - Int (No_Index); 822 L : constant Count_Type := Count_Type (LL); 823 824 begin 825 if Before <= Container.Last then 826 declare 827 II : constant Int'Base := BB + N; 828 I : constant Count_Type := Count_Type (II); 829 begin 830 EA (I .. L) := EA (B .. Length (Container)); 831 EA (B .. I - 1) := (others => New_Item); 832 end; 833 834 else 835 EA (B .. L) := (others => New_Item); 836 end if; 837 end; 838 839 Container.Last := New_Last; 840 end Insert; 841 842 procedure Insert 843 (Container : in out Vector; 844 Before : Extended_Index; 845 New_Item : Vector) 846 is 847 N : constant Count_Type := Length (New_Item); 848 849 begin 850 if Before < Index_Type'First then 851 raise Constraint_Error with 852 "Before index is out of range (too small)"; 853 end if; 854 855 if Before > Container.Last 856 and then Before > Container.Last + 1 857 then 858 raise Constraint_Error with 859 "Before index is out of range (too large)"; 860 end if; 861 862 if N = 0 then 863 return; 864 end if; 865 866 Insert_Space (Container, Before, Count => N); 867 868 declare 869 Dst_Last_As_Int : constant Int'Base := 870 Int (Before) + Int (N) - 1 - Int (No_Index); 871 872 Dst_Last : constant Count_Type := Count_Type (Dst_Last_As_Int); 873 874 BB : constant Int'Base := Int (Before) - Int (No_Index); 875 B : constant Count_Type := Count_Type (BB); 876 877 begin 878 if Container'Address /= New_Item'Address then 879 Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N); 880 return; 881 end if; 882 883 declare 884 Src : Elements_Array renames Container.Elements (1 .. B - 1); 885 886 Index_As_Int : constant Int'Base := BB + Src'Length - 1; 887 888 Index : constant Count_Type := Count_Type (Index_As_Int); 889 890 Dst : Elements_Array renames Container.Elements (B .. Index); 891 892 begin 893 Dst := Src; 894 end; 895 896 if Dst_Last = Length (Container) then 897 return; 898 end if; 899 900 declare 901 Src : Elements_Array renames 902 Container.Elements (Dst_Last + 1 .. Length (Container)); 903 904 Index_As_Int : constant Int'Base := 905 Dst_Last_As_Int - Src'Length + 1; 906 907 Index : constant Count_Type := Count_Type (Index_As_Int); 908 909 Dst : Elements_Array renames 910 Container.Elements (Index .. Dst_Last); 911 912 begin 913 Dst := Src; 914 end; 915 end; 916 end Insert; 917 918 procedure Insert 919 (Container : in out Vector; 920 Before : Cursor; 921 New_Item : Vector) 922 is 923 Index : Index_Type'Base; 924 925 begin 926 if Is_Empty (New_Item) then 927 return; 928 end if; 929 930 if not Before.Valid 931 or else Before.Index > Container.Last 932 then 933 if Container.Last = Index_Type'Last then 934 raise Constraint_Error with 935 "vector is already at its maximum length"; 936 end if; 937 938 Index := Container.Last + 1; 939 940 else 941 Index := Before.Index; 942 end if; 943 944 Insert (Container, Index, New_Item); 945 end Insert; 946 947 procedure Insert 948 (Container : in out Vector; 949 Before : Cursor; 950 New_Item : Vector; 951 Position : out Cursor) 952 is 953 Index : Index_Type'Base; 954 955 begin 956 if Is_Empty (New_Item) then 957 if not Before.Valid 958 or else Before.Index > Container.Last 959 then 960 Position := No_Element; 961 else 962 Position := (True, Before.Index); 963 end if; 964 965 return; 966 end if; 967 968 if not Before.Valid 969 or else Before.Index > Container.Last 970 then 971 if Container.Last = Index_Type'Last then 972 raise Constraint_Error with 973 "vector is already at its maximum length"; 974 end if; 975 976 Index := Container.Last + 1; 977 978 else 979 Index := Before.Index; 980 end if; 981 982 Insert (Container, Index, New_Item); 983 984 Position := Cursor'(True, Index); 985 end Insert; 986 987 procedure Insert 988 (Container : in out Vector; 989 Before : Cursor; 990 New_Item : Element_Type; 991 Count : Count_Type := 1) 992 is 993 Index : Index_Type'Base; 994 995 begin 996 if Count = 0 then 997 return; 998 end if; 999 1000 if not Before.Valid 1001 or else Before.Index > Container.Last 1002 then 1003 if Container.Last = Index_Type'Last then 1004 raise Constraint_Error with 1005 "vector is already at its maximum length"; 1006 end if; 1007 1008 Index := Container.Last + 1; 1009 1010 else 1011 Index := Before.Index; 1012 end if; 1013 1014 Insert (Container, Index, New_Item, Count); 1015 end Insert; 1016 1017 procedure Insert 1018 (Container : in out Vector; 1019 Before : Cursor; 1020 New_Item : Element_Type; 1021 Position : out Cursor; 1022 Count : Count_Type := 1) 1023 is 1024 Index : Index_Type'Base; 1025 1026 begin 1027 if Count = 0 then 1028 if not Before.Valid 1029 or else Before.Index > Container.Last 1030 then 1031 Position := No_Element; 1032 else 1033 Position := (True, Before.Index); 1034 end if; 1035 1036 return; 1037 end if; 1038 1039 if not Before.Valid 1040 or else Before.Index > Container.Last 1041 then 1042 if Container.Last = Index_Type'Last then 1043 raise Constraint_Error with 1044 "vector is already at its maximum length"; 1045 end if; 1046 1047 Index := Container.Last + 1; 1048 1049 else 1050 Index := Before.Index; 1051 end if; 1052 1053 Insert (Container, Index, New_Item, Count); 1054 1055 Position := Cursor'(True, Index); 1056 end Insert; 1057 1058 procedure Insert 1059 (Container : in out Vector; 1060 Before : Extended_Index; 1061 Count : Count_Type := 1) 1062 is 1063 New_Item : Element_Type; -- Default-initialized value 1064 pragma Warnings (Off, New_Item); 1065 1066 begin 1067 Insert (Container, Before, New_Item, Count); 1068 end Insert; 1069 1070 procedure Insert 1071 (Container : in out Vector; 1072 Before : Cursor; 1073 Position : out Cursor; 1074 Count : Count_Type := 1) 1075 is 1076 New_Item : Element_Type; -- Default-initialized value 1077 pragma Warnings (Off, New_Item); 1078 begin 1079 Insert (Container, Before, New_Item, Position, Count); 1080 end Insert; 1081 1082 ------------------ 1083 -- Insert_Space -- 1084 ------------------ 1085 1086 procedure Insert_Space 1087 (Container : in out Vector; 1088 Before : Extended_Index; 1089 Count : Count_Type := 1) 1090 is 1091 N : constant Int := Count_Type'Pos (Count); 1092 1093 First : constant Int := Int (Index_Type'First); 1094 New_Last_As_Int : Int'Base; 1095 New_Last : Index_Type; 1096 New_Length : UInt; 1097 Max_Length : constant UInt := UInt (Count_Type'Last); 1098 1099 begin 1100 if Before < Index_Type'First then 1101 raise Constraint_Error with 1102 "Before index is out of range (too small)"; 1103 end if; 1104 1105 if Before > Container.Last 1106 and then Before > Container.Last + 1 1107 then 1108 raise Constraint_Error with 1109 "Before index is out of range (too large)"; 1110 end if; 1111 1112 if Count = 0 then 1113 return; 1114 end if; 1115 1116 declare 1117 Old_Last_As_Int : constant Int := Int (Container.Last); 1118 1119 begin 1120 if Old_Last_As_Int > Int'Last - N then 1121 raise Constraint_Error with "new length is out of range"; 1122 end if; 1123 1124 New_Last_As_Int := Old_Last_As_Int + N; 1125 1126 if New_Last_As_Int > Int (Index_Type'Last) then 1127 raise Constraint_Error with "new length is out of range"; 1128 end if; 1129 1130 New_Length := UInt (New_Last_As_Int - First + Int'(1)); 1131 1132 if New_Length > Max_Length then 1133 raise Constraint_Error with "new length is out of range"; 1134 end if; 1135 1136 New_Last := Index_Type (New_Last_As_Int); 1137 1138 -- Resolve issue of capacity vs. max index ??? 1139 end; 1140 1141 if Container.Busy > 0 then 1142 raise Program_Error with 1143 "attempt to tamper with elements (vector is busy)"; 1144 end if; 1145 1146 declare 1147 EA : Elements_Array renames Container.Elements; 1148 1149 BB : constant Int'Base := Int (Before) - Int (No_Index); 1150 B : constant Count_Type := Count_Type (BB); 1151 1152 LL : constant Int'Base := New_Last_As_Int - Int (No_Index); 1153 L : constant Count_Type := Count_Type (LL); 1154 1155 begin 1156 if Before <= Container.Last then 1157 declare 1158 II : constant Int'Base := BB + N; 1159 I : constant Count_Type := Count_Type (II); 1160 begin 1161 EA (I .. L) := EA (B .. Length (Container)); 1162 end; 1163 end if; 1164 end; 1165 1166 Container.Last := New_Last; 1167 end Insert_Space; 1168 1169 procedure Insert_Space 1170 (Container : in out Vector; 1171 Before : Cursor; 1172 Position : out Cursor; 1173 Count : Count_Type := 1) 1174 is 1175 Index : Index_Type'Base; 1176 1177 begin 1178 if Count = 0 then 1179 if not Before.Valid 1180 or else Before.Index > Container.Last 1181 then 1182 Position := No_Element; 1183 else 1184 Position := (True, Before.Index); 1185 end if; 1186 1187 return; 1188 end if; 1189 1190 if not Before.Valid 1191 or else Before.Index > Container.Last 1192 then 1193 if Container.Last = Index_Type'Last then 1194 raise Constraint_Error with 1195 "vector is already at its maximum length"; 1196 end if; 1197 1198 Index := Container.Last + 1; 1199 1200 else 1201 Index := Before.Index; 1202 end if; 1203 1204 Insert_Space (Container, Index, Count => Count); 1205 1206 Position := Cursor'(True, Index); 1207 end Insert_Space; 1208 1209 -------------- 1210 -- Is_Empty -- 1211 -------------- 1212 1213 function Is_Empty (Container : Vector) return Boolean is 1214 begin 1215 return Last_Index (Container) < Index_Type'First; 1216 end Is_Empty; 1217 1218 ------------- 1219 -- Iterate -- 1220 ------------- 1221 1222 procedure Iterate 1223 (Container : Vector; 1224 Process : 1225 not null access procedure (Container : Vector; Position : Cursor)) 1226 is 1227 V : Vector renames Container'Unrestricted_Access.all; 1228 B : Natural renames V.Busy; 1229 1230 begin 1231 B := B + 1; 1232 1233 begin 1234 for Indx in Index_Type'First .. Last_Index (Container) loop 1235 Process (Container, Cursor'(True, Indx)); 1236 end loop; 1237 exception 1238 when others => 1239 B := B - 1; 1240 raise; 1241 end; 1242 1243 B := B - 1; 1244 end Iterate; 1245 1246 ---------- 1247 -- Last -- 1248 ---------- 1249 1250 function Last (Container : Vector) return Cursor is 1251 begin 1252 if Is_Empty (Container) then 1253 return No_Element; 1254 end if; 1255 1256 return (True, Last_Index (Container)); 1257 end Last; 1258 1259 ------------------ 1260 -- Last_Element -- 1261 ------------------ 1262 1263 function Last_Element (Container : Vector) return Element_Type is 1264 begin 1265 if Is_Empty (Container) then 1266 raise Constraint_Error with "Container is empty"; 1267 end if; 1268 1269 return Get_Element (Container, Length (Container)); 1270 end Last_Element; 1271 1272 ---------------- 1273 -- Last_Index -- 1274 ---------------- 1275 1276 function Last_Index (Container : Vector) return Extended_Index is 1277 begin 1278 return Container.Last; 1279 end Last_Index; 1280 1281 ------------ 1282 -- Length -- 1283 ------------ 1284 1285 function Length (Container : Vector) return Capacity_Subtype is 1286 L : constant Int := Int (Last_Index (Container)); 1287 F : constant Int := Int (Index_Type'First); 1288 N : constant Int'Base := L - F + 1; 1289 1290 begin 1291 return Capacity_Subtype (N); 1292 end Length; 1293 1294 ---------- 1295 -- Left -- 1296 ---------- 1297 1298 function Left (Container : Vector; Position : Cursor) return Vector is 1299 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); 1300 1301 begin 1302 if Position = No_Element then 1303 return C; 1304 end if; 1305 1306 if not Has_Element (Container, Position) then 1307 raise Constraint_Error; 1308 end if; 1309 1310 while C.Last /= Position.Index - 1 loop 1311 Delete_Last (C); 1312 end loop; 1313 return C; 1314 end Left; 1315 1316 ---------- 1317 -- Move -- 1318 ---------- 1319 1320 procedure Move 1321 (Target : in out Vector; 1322 Source : in out Vector) 1323 is 1324 N : constant Count_Type := Length (Source); 1325 1326 begin 1327 if Target'Address = Source'Address then 1328 return; 1329 end if; 1330 1331 if Target.Busy > 0 then 1332 raise Program_Error with 1333 "attempt to tamper with elements (Target is busy)"; 1334 end if; 1335 1336 if Source.Busy > 0 then 1337 raise Program_Error with 1338 "attempt to tamper with elements (Source is busy)"; 1339 end if; 1340 1341 if N > Target.Capacity then 1342 raise Constraint_Error with -- correct exception here??? 1343 "length of Source is greater than capacity of Target"; 1344 end if; 1345 1346 -- We could also write this as a loop, and incrementally 1347 -- copy elements from source to target. 1348 1349 Target.Last := No_Index; -- in case array assignment files 1350 Target.Elements (1 .. N) := Source.Elements (1 .. N); 1351 1352 Target.Last := Source.Last; 1353 Source.Last := No_Index; 1354 end Move; 1355 1356 ---------- 1357 -- Next -- 1358 ---------- 1359 1360 function Next (Container : Vector; Position : Cursor) return Cursor is 1361 begin 1362 if not Position.Valid then 1363 return No_Element; 1364 end if; 1365 1366 if Position.Index < Last_Index (Container) then 1367 return (True, Position.Index + 1); 1368 end if; 1369 1370 return No_Element; 1371 end Next; 1372 1373 ---------- 1374 -- Next -- 1375 ---------- 1376 1377 procedure Next (Container : Vector; Position : in out Cursor) is 1378 begin 1379 if not Position.Valid then 1380 return; 1381 end if; 1382 1383 if Position.Index < Last_Index (Container) then 1384 Position.Index := Position.Index + 1; 1385 else 1386 Position := No_Element; 1387 end if; 1388 end Next; 1389 1390 ------------- 1391 -- Prepend -- 1392 ------------- 1393 1394 procedure Prepend (Container : in out Vector; New_Item : Vector) is 1395 begin 1396 Insert (Container, Index_Type'First, New_Item); 1397 end Prepend; 1398 1399 procedure Prepend 1400 (Container : in out Vector; 1401 New_Item : Element_Type; 1402 Count : Count_Type := 1) 1403 is 1404 begin 1405 Insert (Container, 1406 Index_Type'First, 1407 New_Item, 1408 Count); 1409 end Prepend; 1410 1411 -------------- 1412 -- Previous -- 1413 -------------- 1414 1415 procedure Previous (Container : Vector; Position : in out Cursor) is 1416 begin 1417 if not Position.Valid then 1418 return; 1419 end if; 1420 1421 if Position.Index > Index_Type'First and 1422 Position.Index <= Last_Index (Container) then 1423 Position.Index := Position.Index - 1; 1424 else 1425 Position := No_Element; 1426 end if; 1427 end Previous; 1428 1429 function Previous (Container : Vector; Position : Cursor) return Cursor is 1430 begin 1431 if not Position.Valid then 1432 return No_Element; 1433 end if; 1434 1435 if Position.Index > Index_Type'First and 1436 Position.Index <= Last_Index (Container) then 1437 return (True, Position.Index - 1); 1438 end if; 1439 1440 return No_Element; 1441 end Previous; 1442 1443 ------------------- 1444 -- Query_Element -- 1445 ------------------- 1446 1447 procedure Query_Element 1448 (Container : Vector; 1449 Index : Index_Type; 1450 Process : not null access procedure (Element : Element_Type)) 1451 is 1452 V : Vector renames Container'Unrestricted_Access.all; 1453 B : Natural renames V.Busy; 1454 L : Natural renames V.Lock; 1455 1456 begin 1457 if Index > Last_Index (Container) then 1458 raise Constraint_Error with "Index is out of range"; 1459 end if; 1460 1461 B := B + 1; 1462 L := L + 1; 1463 1464 declare 1465 II : constant Int'Base := Int (Index) - Int (No_Index); 1466 I : constant Count_Type := Count_Type (II); 1467 1468 begin 1469 Process (Get_Element (V, I)); 1470 exception 1471 when others => 1472 L := L - 1; 1473 B := B - 1; 1474 raise; 1475 end; 1476 1477 L := L - 1; 1478 B := B - 1; 1479 end Query_Element; 1480 1481 procedure Query_Element 1482 (Container : Vector; 1483 Position : Cursor; 1484 Process : not null access procedure (Element : Element_Type)) 1485 is 1486 begin 1487 if not Position.Valid then 1488 raise Constraint_Error with "Position cursor has no element"; 1489 end if; 1490 1491 Query_Element (Container, Position.Index, Process); 1492 end Query_Element; 1493 1494 ---------- 1495 -- Read -- 1496 ---------- 1497 1498 procedure Read 1499 (Stream : not null access Root_Stream_Type'Class; 1500 Container : out Vector) 1501 is 1502 Length : Count_Type'Base; 1503 Last : Index_Type'Base := No_Index; 1504 1505 begin 1506 Clear (Container); 1507 1508 Count_Type'Base'Read (Stream, Length); 1509 1510 if Length < 0 then 1511 raise Program_Error with "stream appears to be corrupt"; 1512 end if; 1513 1514 if Length > Container.Capacity then 1515 raise Storage_Error with "not enough capacity"; -- ??? 1516 end if; 1517 1518 for J in Count_Type range 1 .. Length loop 1519 Last := Last + 1; 1520 Element_Type'Read (Stream, Container.Elements (J)); 1521 Container.Last := Last; 1522 end loop; 1523 end Read; 1524 1525 procedure Read 1526 (Stream : not null access Root_Stream_Type'Class; 1527 Position : out Cursor) 1528 is 1529 begin 1530 raise Program_Error with "attempt to stream vector cursor"; 1531 end Read; 1532 1533 --------------------- 1534 -- Replace_Element -- 1535 --------------------- 1536 1537 procedure Replace_Element 1538 (Container : in out Vector; 1539 Index : Index_Type; 1540 New_Item : Element_Type) 1541 is 1542 begin 1543 if Index > Container.Last then 1544 raise Constraint_Error with "Index is out of range"; 1545 end if; 1546 1547 if Container.Lock > 0 then 1548 raise Program_Error with 1549 "attempt to tamper with cursors (vector is locked)"; 1550 end if; 1551 1552 declare 1553 II : constant Int'Base := Int (Index) - Int (No_Index); 1554 I : constant Count_Type := Count_Type (II); 1555 1556 begin 1557 Container.Elements (I) := New_Item; 1558 end; 1559 end Replace_Element; 1560 1561 procedure Replace_Element 1562 (Container : in out Vector; 1563 Position : Cursor; 1564 New_Item : Element_Type) 1565 is 1566 begin 1567 if not Position.Valid then 1568 raise Constraint_Error with "Position cursor has no element"; 1569 end if; 1570 1571 if Position.Index > Container.Last then 1572 raise Constraint_Error with "Position cursor is out of range"; 1573 end if; 1574 1575 if Container.Lock > 0 then 1576 raise Program_Error with 1577 "attempt to tamper with cursors (vector is locked)"; 1578 end if; 1579 1580 declare 1581 II : constant Int'Base := Int (Position.Index) - Int (No_Index); 1582 I : constant Count_Type := Count_Type (II); 1583 begin 1584 Container.Elements (I) := New_Item; 1585 end; 1586 end Replace_Element; 1587 1588 ---------------------- 1589 -- Reserve_Capacity -- 1590 ---------------------- 1591 1592 procedure Reserve_Capacity 1593 (Container : in out Vector; 1594 Capacity : Capacity_Subtype) 1595 is 1596 begin 1597 if Capacity > Container.Capacity then 1598 raise Constraint_Error; -- ??? 1599 end if; 1600 end Reserve_Capacity; 1601 1602 ---------------------- 1603 -- Reverse_Elements -- 1604 ---------------------- 1605 1606 procedure Reverse_Elements (Container : in out Vector) is 1607 begin 1608 if Length (Container) <= 1 then 1609 return; 1610 end if; 1611 1612 if Container.Lock > 0 then 1613 raise Program_Error with 1614 "attempt to tamper with cursors (vector is locked)"; 1615 end if; 1616 1617 declare 1618 I, J : Count_Type; 1619 E : Elements_Array renames Container.Elements; 1620 1621 begin 1622 I := 1; 1623 J := Length (Container); 1624 while I < J loop 1625 declare 1626 EI : constant Element_Type := E (I); 1627 begin 1628 E (I) := E (J); 1629 E (J) := EI; 1630 end; 1631 1632 I := I + 1; 1633 J := J - 1; 1634 end loop; 1635 end; 1636 end Reverse_Elements; 1637 1638 ------------------ 1639 -- Reverse_Find -- 1640 ------------------ 1641 1642 function Reverse_Find 1643 (Container : Vector; 1644 Item : Element_Type; 1645 Position : Cursor := No_Element) return Cursor 1646 is 1647 Last : Index_Type'Base; 1648 K : Count_Type; 1649 1650 begin 1651 if not Position.Valid 1652 or else Position.Index > Last_Index (Container) 1653 then 1654 Last := Last_Index (Container); 1655 else 1656 Last := Position.Index; 1657 end if; 1658 1659 K := Count_Type (Int (Last) - Int (No_Index)); 1660 for Indx in reverse Index_Type'First .. Last loop 1661 if Get_Element (Container, K) = Item then 1662 return (True, Indx); 1663 end if; 1664 1665 K := K - 1; 1666 end loop; 1667 1668 return No_Element; 1669 end Reverse_Find; 1670 1671 ------------------------ 1672 -- Reverse_Find_Index -- 1673 ------------------------ 1674 1675 function Reverse_Find_Index 1676 (Container : Vector; 1677 Item : Element_Type; 1678 Index : Index_Type := Index_Type'Last) return Extended_Index 1679 is 1680 Last : Index_Type'Base; 1681 K : Count_Type; 1682 1683 begin 1684 if Index > Last_Index (Container) then 1685 Last := Last_Index (Container); 1686 else 1687 Last := Index; 1688 end if; 1689 1690 K := Count_Type (Int (Last) - Int (No_Index)); 1691 for Indx in reverse Index_Type'First .. Last loop 1692 if Get_Element (Container, K) = Item then 1693 return Indx; 1694 end if; 1695 1696 K := K - 1; 1697 end loop; 1698 1699 return No_Index; 1700 end Reverse_Find_Index; 1701 1702 --------------------- 1703 -- Reverse_Iterate -- 1704 --------------------- 1705 1706 procedure Reverse_Iterate 1707 (Container : Vector; 1708 Process : not null access procedure (Container : Vector; 1709 Position : Cursor)) 1710 is 1711 V : Vector renames Container'Unrestricted_Access.all; 1712 B : Natural renames V.Busy; 1713 1714 begin 1715 B := B + 1; 1716 1717 begin 1718 for Indx in reverse Index_Type'First .. Last_Index (Container) loop 1719 Process (Container, Cursor'(True, Indx)); 1720 end loop; 1721 exception 1722 when others => 1723 B := B - 1; 1724 raise; 1725 end; 1726 1727 B := B - 1; 1728 end Reverse_Iterate; 1729 1730 ----------- 1731 -- Right -- 1732 ----------- 1733 1734 function Right (Container : Vector; Position : Cursor) return Vector is 1735 C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); 1736 1737 begin 1738 if Position = No_Element then 1739 Clear (C); 1740 return C; 1741 end if; 1742 1743 if not Has_Element (Container, Position) then 1744 raise Constraint_Error; 1745 end if; 1746 1747 while C.Last /= Container.Last - Position.Index + 1 loop 1748 Delete_First (C); 1749 end loop; 1750 1751 return C; 1752 end Right; 1753 1754 ---------------- 1755 -- Set_Length -- 1756 ---------------- 1757 1758 procedure Set_Length 1759 (Container : in out Vector; 1760 Length : Capacity_Subtype) 1761 is 1762 begin 1763 if Length = Formal_Vectors.Length (Container) then 1764 return; 1765 end if; 1766 1767 if Container.Busy > 0 then 1768 raise Program_Error with 1769 "attempt to tamper with elements (vector is busy)"; 1770 end if; 1771 1772 if Length > Container.Capacity then 1773 raise Constraint_Error; -- ??? 1774 end if; 1775 1776 declare 1777 Last_As_Int : constant Int'Base := 1778 Int (Index_Type'First) + Int (Length) - 1; 1779 begin 1780 Container.Last := Index_Type'Base (Last_As_Int); 1781 end; 1782 end Set_Length; 1783 1784 ---------- 1785 -- Swap -- 1786 ---------- 1787 1788 procedure Swap (Container : in out Vector; I, J : Index_Type) is 1789 begin 1790 if I > Container.Last then 1791 raise Constraint_Error with "I index is out of range"; 1792 end if; 1793 1794 if J > Container.Last then 1795 raise Constraint_Error with "J index is out of range"; 1796 end if; 1797 1798 if I = J then 1799 return; 1800 end if; 1801 1802 if Container.Lock > 0 then 1803 raise Program_Error with 1804 "attempt to tamper with cursors (vector is locked)"; 1805 end if; 1806 1807 declare 1808 II : constant Int'Base := Int (I) - Int (No_Index); 1809 JJ : constant Int'Base := Int (J) - Int (No_Index); 1810 1811 EI : Element_Type renames Container.Elements (Count_Type (II)); 1812 EJ : Element_Type renames Container.Elements (Count_Type (JJ)); 1813 1814 EI_Copy : constant Element_Type := EI; 1815 1816 begin 1817 EI := EJ; 1818 EJ := EI_Copy; 1819 end; 1820 end Swap; 1821 1822 procedure Swap (Container : in out Vector; I, J : Cursor) is 1823 begin 1824 if not I.Valid then 1825 raise Constraint_Error with "I cursor has no element"; 1826 end if; 1827 1828 if not J.Valid then 1829 raise Constraint_Error with "J cursor has no element"; 1830 end if; 1831 1832 Swap (Container, I.Index, J.Index); 1833 end Swap; 1834 1835 --------------- 1836 -- To_Cursor -- 1837 --------------- 1838 1839 function To_Cursor 1840 (Container : Vector; 1841 Index : Extended_Index) return Cursor 1842 is 1843 begin 1844 if Index not in Index_Type'First .. Last_Index (Container) then 1845 return No_Element; 1846 end if; 1847 1848 return Cursor'(True, Index); 1849 end To_Cursor; 1850 1851 -------------- 1852 -- To_Index -- 1853 -------------- 1854 1855 function To_Index (Position : Cursor) return Extended_Index is 1856 begin 1857 if not Position.Valid then 1858 return No_Index; 1859 end if; 1860 1861 return Position.Index; 1862 end To_Index; 1863 1864 --------------- 1865 -- To_Vector -- 1866 --------------- 1867 1868 function To_Vector (Length : Capacity_Subtype) return Vector is 1869 begin 1870 if Length = 0 then 1871 return Empty_Vector; 1872 end if; 1873 1874 declare 1875 First : constant Int := Int (Index_Type'First); 1876 Last_As_Int : constant Int'Base := First + Int (Length) - 1; 1877 Last : Index_Type; 1878 1879 begin 1880 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then 1881 raise Constraint_Error with "Length is out of range"; -- ??? 1882 end if; 1883 1884 Last := Index_Type (Last_As_Int); 1885 1886 return (Length, (others => <>), Last => Last, 1887 others => <>); 1888 end; 1889 end To_Vector; 1890 1891 function To_Vector 1892 (New_Item : Element_Type; 1893 Length : Capacity_Subtype) return Vector 1894 is 1895 begin 1896 if Length = 0 then 1897 return Empty_Vector; 1898 end if; 1899 1900 declare 1901 First : constant Int := Int (Index_Type'First); 1902 Last_As_Int : constant Int'Base := First + Int (Length) - 1; 1903 Last : Index_Type; 1904 1905 begin 1906 if Last_As_Int > Index_Type'Pos (Index_Type'Last) then 1907 raise Constraint_Error with "Length is out of range"; -- ??? 1908 end if; 1909 1910 Last := Index_Type (Last_As_Int); 1911 1912 return (Length, (others => New_Item), Last => Last, 1913 others => <>); 1914 end; 1915 end To_Vector; 1916 1917 -------------------- 1918 -- Update_Element -- 1919 -------------------- 1920 1921 procedure Update_Element 1922 (Container : in out Vector; 1923 Index : Index_Type; 1924 Process : not null access procedure (Element : in out Element_Type)) 1925 is 1926 B : Natural renames Container.Busy; 1927 L : Natural renames Container.Lock; 1928 1929 begin 1930 if Index > Container.Last then 1931 raise Constraint_Error with "Index is out of range"; 1932 end if; 1933 1934 B := B + 1; 1935 L := L + 1; 1936 1937 declare 1938 II : constant Int'Base := Int (Index) - Int (No_Index); 1939 I : constant Count_Type := Count_Type (II); 1940 1941 begin 1942 Process (Container.Elements (I)); 1943 exception 1944 when others => 1945 L := L - 1; 1946 B := B - 1; 1947 raise; 1948 end; 1949 1950 L := L - 1; 1951 B := B - 1; 1952 end Update_Element; 1953 1954 procedure Update_Element 1955 (Container : in out Vector; 1956 Position : Cursor; 1957 Process : not null access procedure (Element : in out Element_Type)) 1958 is 1959 begin 1960 if not Position.Valid then 1961 raise Constraint_Error with "Position cursor has no element"; 1962 end if; 1963 1964 Update_Element (Container, Position.Index, Process); 1965 end Update_Element; 1966 1967 ----------- 1968 -- Write -- 1969 ----------- 1970 1971 procedure Write 1972 (Stream : not null access Root_Stream_Type'Class; 1973 Container : Vector) 1974 is 1975 begin 1976 Count_Type'Base'Write (Stream, Length (Container)); 1977 1978 for J in 1 .. Length (Container) loop 1979 Element_Type'Write (Stream, Container.Elements (J)); 1980 end loop; 1981 end Write; 1982 1983 procedure Write 1984 (Stream : not null access Root_Stream_Type'Class; 1985 Position : Cursor) 1986 is 1987 begin 1988 raise Program_Error with "attempt to stream vector cursor"; 1989 end Write; 1990 1991end Ada.Containers.Formal_Vectors; 1992