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