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