1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-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-- This unit was originally developed by Matthew J Heaney. -- 28------------------------------------------------------------------------------ 29 30with Ada.Unchecked_Deallocation; 31 32with System; use type System.Address; 33 34package body Ada.Containers.Doubly_Linked_Lists is 35 36 type Iterator is new Limited_Controlled and 37 List_Iterator_Interfaces.Reversible_Iterator with 38 record 39 Container : List_Access; 40 Node : Node_Access; 41 end record; 42 43 overriding procedure Finalize (Object : in out Iterator); 44 45 overriding function First (Object : Iterator) return Cursor; 46 overriding function Last (Object : Iterator) return Cursor; 47 48 overriding function Next 49 (Object : Iterator; 50 Position : Cursor) return Cursor; 51 52 overriding function Previous 53 (Object : Iterator; 54 Position : Cursor) return Cursor; 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 procedure Free (X : in out Node_Access); 61 62 procedure Insert_Internal 63 (Container : in out List; 64 Before : Node_Access; 65 New_Node : Node_Access); 66 67 function Vet (Position : Cursor) return Boolean; 68 -- Checks invariants of the cursor and its designated container, as a 69 -- simple way of detecting dangling references (see operation Free for a 70 -- description of the detection mechanism), returning True if all checks 71 -- pass. Invocations of Vet are used here as the argument of pragma Assert, 72 -- so the checks are performed only when assertions are enabled. 73 74 --------- 75 -- "=" -- 76 --------- 77 78 function "=" (Left, Right : List) return Boolean is 79 L : Node_Access := Left.First; 80 R : Node_Access := Right.First; 81 82 begin 83 if Left'Address = Right'Address then 84 return True; 85 end if; 86 87 if Left.Length /= Right.Length then 88 return False; 89 end if; 90 91 for J in 1 .. Left.Length loop 92 if L.Element /= R.Element then 93 return False; 94 end if; 95 96 L := L.Next; 97 R := R.Next; 98 end loop; 99 100 return True; 101 end "="; 102 103 ------------ 104 -- Adjust -- 105 ------------ 106 107 procedure Adjust (Container : in out List) is 108 Src : Node_Access := Container.First; 109 110 begin 111 if Src = null then 112 pragma Assert (Container.Last = null); 113 pragma Assert (Container.Length = 0); 114 pragma Assert (Container.Busy = 0); 115 pragma Assert (Container.Lock = 0); 116 return; 117 end if; 118 119 pragma Assert (Container.First.Prev = null); 120 pragma Assert (Container.Last.Next = null); 121 pragma Assert (Container.Length > 0); 122 123 Container.First := null; 124 Container.Last := null; 125 Container.Length := 0; 126 Container.Busy := 0; 127 Container.Lock := 0; 128 129 Container.First := new Node_Type'(Src.Element, null, null); 130 Container.Last := Container.First; 131 Container.Length := 1; 132 133 Src := Src.Next; 134 while Src /= null loop 135 Container.Last.Next := new Node_Type'(Element => Src.Element, 136 Prev => Container.Last, 137 Next => null); 138 Container.Last := Container.Last.Next; 139 Container.Length := Container.Length + 1; 140 141 Src := Src.Next; 142 end loop; 143 end Adjust; 144 145 procedure Adjust (Control : in out Reference_Control_Type) is 146 begin 147 if Control.Container /= null then 148 declare 149 C : List renames Control.Container.all; 150 B : Natural renames C.Busy; 151 L : Natural renames C.Lock; 152 begin 153 B := B + 1; 154 L := L + 1; 155 end; 156 end if; 157 end Adjust; 158 159 ------------ 160 -- Append -- 161 ------------ 162 163 procedure Append 164 (Container : in out List; 165 New_Item : Element_Type; 166 Count : Count_Type := 1) 167 is 168 begin 169 Insert (Container, No_Element, New_Item, Count); 170 end Append; 171 172 ------------ 173 -- Assign -- 174 ------------ 175 176 procedure Assign (Target : in out List; Source : List) is 177 Node : Node_Access; 178 179 begin 180 if Target'Address = Source'Address then 181 return; 182 end if; 183 184 Target.Clear; 185 186 Node := Source.First; 187 while Node /= null loop 188 Target.Append (Node.Element); 189 Node := Node.Next; 190 end loop; 191 end Assign; 192 193 ----------- 194 -- Clear -- 195 ----------- 196 197 procedure Clear (Container : in out List) is 198 X : Node_Access; 199 200 begin 201 if Container.Length = 0 then 202 pragma Assert (Container.First = null); 203 pragma Assert (Container.Last = null); 204 pragma Assert (Container.Busy = 0); 205 pragma Assert (Container.Lock = 0); 206 return; 207 end if; 208 209 pragma Assert (Container.First.Prev = null); 210 pragma Assert (Container.Last.Next = null); 211 212 if Container.Busy > 0 then 213 raise Program_Error with 214 "attempt to tamper with cursors (list is busy)"; 215 end if; 216 217 while Container.Length > 1 loop 218 X := Container.First; 219 pragma Assert (X.Next.Prev = Container.First); 220 221 Container.First := X.Next; 222 Container.First.Prev := null; 223 224 Container.Length := Container.Length - 1; 225 226 Free (X); 227 end loop; 228 229 X := Container.First; 230 pragma Assert (X = Container.Last); 231 232 Container.First := null; 233 Container.Last := null; 234 Container.Length := 0; 235 236 pragma Warnings (Off); 237 Free (X); 238 pragma Warnings (On); 239 end Clear; 240 241 ------------------------ 242 -- Constant_Reference -- 243 ------------------------ 244 245 function Constant_Reference 246 (Container : aliased List; 247 Position : Cursor) return Constant_Reference_Type 248 is 249 begin 250 if Position.Container = null then 251 raise Constraint_Error with "Position cursor has no element"; 252 end if; 253 254 if Position.Container /= Container'Unrestricted_Access then 255 raise Program_Error with 256 "Position cursor designates wrong container"; 257 end if; 258 259 pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); 260 261 declare 262 C : List renames Position.Container.all; 263 B : Natural renames C.Busy; 264 L : Natural renames C.Lock; 265 begin 266 return R : constant Constant_Reference_Type := 267 (Element => Position.Node.Element'Access, 268 Control => (Controlled with Container'Unrestricted_Access)) 269 do 270 B := B + 1; 271 L := L + 1; 272 end return; 273 end; 274 end Constant_Reference; 275 276 -------------- 277 -- Contains -- 278 -------------- 279 280 function Contains 281 (Container : List; 282 Item : Element_Type) return Boolean 283 is 284 begin 285 return Find (Container, Item) /= No_Element; 286 end Contains; 287 288 ---------- 289 -- Copy -- 290 ---------- 291 292 function Copy (Source : List) return List is 293 begin 294 return Target : List do 295 Target.Assign (Source); 296 end return; 297 end Copy; 298 299 ------------ 300 -- Delete -- 301 ------------ 302 303 procedure Delete 304 (Container : in out List; 305 Position : in out Cursor; 306 Count : Count_Type := 1) 307 is 308 X : Node_Access; 309 310 begin 311 if Position.Node = null then 312 raise Constraint_Error with 313 "Position cursor has no element"; 314 end if; 315 316 if Position.Container /= Container'Unrestricted_Access then 317 raise Program_Error with 318 "Position cursor designates wrong container"; 319 end if; 320 321 pragma Assert (Vet (Position), "bad cursor in Delete"); 322 323 if Position.Node = Container.First then 324 Delete_First (Container, Count); 325 Position := No_Element; -- Post-York behavior 326 return; 327 end if; 328 329 if Count = 0 then 330 Position := No_Element; -- Post-York behavior 331 return; 332 end if; 333 334 if Container.Busy > 0 then 335 raise Program_Error with 336 "attempt to tamper with cursors (list is busy)"; 337 end if; 338 339 for Index in 1 .. Count loop 340 X := Position.Node; 341 Container.Length := Container.Length - 1; 342 343 if X = Container.Last then 344 Position := No_Element; 345 346 Container.Last := X.Prev; 347 Container.Last.Next := null; 348 349 Free (X); 350 return; 351 end if; 352 353 Position.Node := X.Next; 354 355 X.Next.Prev := X.Prev; 356 X.Prev.Next := X.Next; 357 358 Free (X); 359 end loop; 360 361 Position := No_Element; -- Post-York behavior 362 end Delete; 363 364 ------------------ 365 -- Delete_First -- 366 ------------------ 367 368 procedure Delete_First 369 (Container : in out List; 370 Count : Count_Type := 1) 371 is 372 X : Node_Access; 373 374 begin 375 if Count >= Container.Length then 376 Clear (Container); 377 return; 378 end if; 379 380 if Count = 0 then 381 return; 382 end if; 383 384 if Container.Busy > 0 then 385 raise Program_Error with 386 "attempt to tamper with cursors (list is busy)"; 387 end if; 388 389 for I in 1 .. Count loop 390 X := Container.First; 391 pragma Assert (X.Next.Prev = Container.First); 392 393 Container.First := X.Next; 394 Container.First.Prev := null; 395 396 Container.Length := Container.Length - 1; 397 398 Free (X); 399 end loop; 400 end Delete_First; 401 402 ----------------- 403 -- Delete_Last -- 404 ----------------- 405 406 procedure Delete_Last 407 (Container : in out List; 408 Count : Count_Type := 1) 409 is 410 X : Node_Access; 411 412 begin 413 if Count >= Container.Length then 414 Clear (Container); 415 return; 416 end if; 417 418 if Count = 0 then 419 return; 420 end if; 421 422 if Container.Busy > 0 then 423 raise Program_Error with 424 "attempt to tamper with cursors (list is busy)"; 425 end if; 426 427 for I in 1 .. Count loop 428 X := Container.Last; 429 pragma Assert (X.Prev.Next = Container.Last); 430 431 Container.Last := X.Prev; 432 Container.Last.Next := null; 433 434 Container.Length := Container.Length - 1; 435 436 Free (X); 437 end loop; 438 end Delete_Last; 439 440 ------------- 441 -- Element -- 442 ------------- 443 444 function Element (Position : Cursor) return Element_Type is 445 begin 446 if Position.Node = null then 447 raise Constraint_Error with 448 "Position cursor has no element"; 449 end if; 450 451 pragma Assert (Vet (Position), "bad cursor in Element"); 452 453 return Position.Node.Element; 454 end Element; 455 456 -------------- 457 -- Finalize -- 458 -------------- 459 460 procedure Finalize (Object : in out Iterator) is 461 begin 462 if Object.Container /= null then 463 declare 464 B : Natural renames Object.Container.all.Busy; 465 begin 466 B := B - 1; 467 end; 468 end if; 469 end Finalize; 470 471 procedure Finalize (Control : in out Reference_Control_Type) is 472 begin 473 if Control.Container /= null then 474 declare 475 C : List renames Control.Container.all; 476 B : Natural renames C.Busy; 477 L : Natural renames C.Lock; 478 begin 479 B := B - 1; 480 L := L - 1; 481 end; 482 483 Control.Container := null; 484 end if; 485 end Finalize; 486 487 ---------- 488 -- Find -- 489 ---------- 490 491 function Find 492 (Container : List; 493 Item : Element_Type; 494 Position : Cursor := No_Element) return Cursor 495 is 496 Node : Node_Access := Position.Node; 497 498 begin 499 if Node = null then 500 Node := Container.First; 501 502 else 503 if Position.Container /= Container'Unrestricted_Access then 504 raise Program_Error with 505 "Position cursor designates wrong container"; 506 end if; 507 508 pragma Assert (Vet (Position), "bad cursor in Find"); 509 end if; 510 511 while Node /= null loop 512 if Node.Element = Item then 513 return Cursor'(Container'Unrestricted_Access, Node); 514 end if; 515 516 Node := Node.Next; 517 end loop; 518 519 return No_Element; 520 end Find; 521 522 ----------- 523 -- First -- 524 ----------- 525 526 function First (Container : List) return Cursor is 527 begin 528 if Container.First = null then 529 return No_Element; 530 end if; 531 532 return Cursor'(Container'Unrestricted_Access, Container.First); 533 end First; 534 535 function First (Object : Iterator) return Cursor is 536 begin 537 -- The value of the iterator object's Node component influences the 538 -- behavior of the First (and Last) selector function. 539 540 -- When the Node component is null, this means the iterator object was 541 -- constructed without a start expression, in which case the (forward) 542 -- iteration starts from the (logical) beginning of the entire sequence 543 -- of items (corresponding to Container.First, for a forward iterator). 544 545 -- Otherwise, this is iteration over a partial sequence of items. When 546 -- the Node component is non-null, the iterator object was constructed 547 -- with a start expression, that specifies the position from which the 548 -- (forward) partial iteration begins. 549 550 if Object.Node = null then 551 return Doubly_Linked_Lists.First (Object.Container.all); 552 else 553 return Cursor'(Object.Container, Object.Node); 554 end if; 555 end First; 556 557 ------------------- 558 -- First_Element -- 559 ------------------- 560 561 function First_Element (Container : List) return Element_Type is 562 begin 563 if Container.First = null then 564 raise Constraint_Error with "list is empty"; 565 end if; 566 567 return Container.First.Element; 568 end First_Element; 569 570 ---------- 571 -- Free -- 572 ---------- 573 574 procedure Free (X : in out Node_Access) is 575 procedure Deallocate is 576 new Ada.Unchecked_Deallocation (Node_Type, Node_Access); 577 begin 578 -- While a node is in use, as an active link in a list, its Previous and 579 -- Next components must be null, or designate a different node; this is 580 -- a node invariant. Before actually deallocating the node, we set both 581 -- access value components of the node to point to the node itself, thus 582 -- falsifying the node invariant. Subprogram Vet inspects the value of 583 -- the node components when interrogating the node, in order to detect 584 -- whether the cursor's node access value is dangling. 585 586 -- Note that we have no guarantee that the storage for the node isn't 587 -- modified when it is deallocated, but there are other tests that Vet 588 -- does if node invariants appear to be satisifed. However, in practice 589 -- this simple test works well enough, detecting dangling references 590 -- immediately, without needing further interrogation. 591 592 X.Prev := X; 593 X.Next := X; 594 595 Deallocate (X); 596 end Free; 597 598 --------------------- 599 -- Generic_Sorting -- 600 --------------------- 601 602 package body Generic_Sorting is 603 604 --------------- 605 -- Is_Sorted -- 606 --------------- 607 608 function Is_Sorted (Container : List) return Boolean is 609 Node : Node_Access := Container.First; 610 611 begin 612 for I in 2 .. Container.Length loop 613 if Node.Next.Element < Node.Element then 614 return False; 615 end if; 616 617 Node := Node.Next; 618 end loop; 619 620 return True; 621 end Is_Sorted; 622 623 ----------- 624 -- Merge -- 625 ----------- 626 627 procedure Merge 628 (Target : in out List; 629 Source : in out List) 630 is 631 LI, RI : Cursor; 632 633 begin 634 635 -- The semantics of Merge changed slightly per AI05-0021. It was 636 -- originally the case that if Target and Source denoted the same 637 -- container object, then the GNAT implementation of Merge did 638 -- nothing. However, it was argued that RM05 did not precisely 639 -- specify the semantics for this corner case. The decision of the 640 -- ARG was that if Target and Source denote the same non-empty 641 -- container object, then Program_Error is raised. 642 643 if Source.Is_Empty then 644 return; 645 end if; 646 647 if Target'Address = Source'Address then 648 raise Program_Error with 649 "Target and Source denote same non-empty container"; 650 end if; 651 652 if Target.Busy > 0 then 653 raise Program_Error with 654 "attempt to tamper with cursors of Target (list is busy)"; 655 end if; 656 657 if Source.Busy > 0 then 658 raise Program_Error with 659 "attempt to tamper with cursors of Source (list is busy)"; 660 end if; 661 662 LI := First (Target); 663 RI := First (Source); 664 while RI.Node /= null loop 665 pragma Assert (RI.Node.Next = null 666 or else not (RI.Node.Next.Element < 667 RI.Node.Element)); 668 669 if LI.Node = null then 670 Splice (Target, No_Element, Source); 671 return; 672 end if; 673 674 pragma Assert (LI.Node.Next = null 675 or else not (LI.Node.Next.Element < 676 LI.Node.Element)); 677 678 if RI.Node.Element < LI.Node.Element then 679 declare 680 RJ : Cursor := RI; 681 pragma Warnings (Off, RJ); 682 begin 683 RI.Node := RI.Node.Next; 684 Splice (Target, LI, Source, RJ); 685 end; 686 687 else 688 LI.Node := LI.Node.Next; 689 end if; 690 end loop; 691 end Merge; 692 693 ---------- 694 -- Sort -- 695 ---------- 696 697 procedure Sort (Container : in out List) is 698 699 procedure Partition (Pivot : Node_Access; Back : Node_Access); 700 701 procedure Sort (Front, Back : Node_Access); 702 703 --------------- 704 -- Partition -- 705 --------------- 706 707 procedure Partition (Pivot : Node_Access; Back : Node_Access) is 708 Node : Node_Access := Pivot.Next; 709 710 begin 711 while Node /= Back loop 712 if Node.Element < Pivot.Element then 713 declare 714 Prev : constant Node_Access := Node.Prev; 715 Next : constant Node_Access := Node.Next; 716 717 begin 718 Prev.Next := Next; 719 720 if Next = null then 721 Container.Last := Prev; 722 else 723 Next.Prev := Prev; 724 end if; 725 726 Node.Next := Pivot; 727 Node.Prev := Pivot.Prev; 728 729 Pivot.Prev := Node; 730 731 if Node.Prev = null then 732 Container.First := Node; 733 else 734 Node.Prev.Next := Node; 735 end if; 736 737 Node := Next; 738 end; 739 740 else 741 Node := Node.Next; 742 end if; 743 end loop; 744 end Partition; 745 746 ---------- 747 -- Sort -- 748 ---------- 749 750 procedure Sort (Front, Back : Node_Access) is 751 Pivot : constant Node_Access := 752 (if Front = null then Container.First else Front.Next); 753 begin 754 if Pivot /= Back then 755 Partition (Pivot, Back); 756 Sort (Front, Pivot); 757 Sort (Pivot, Back); 758 end if; 759 end Sort; 760 761 -- Start of processing for Sort 762 763 begin 764 if Container.Length <= 1 then 765 return; 766 end if; 767 768 pragma Assert (Container.First.Prev = null); 769 pragma Assert (Container.Last.Next = null); 770 771 if Container.Busy > 0 then 772 raise Program_Error with 773 "attempt to tamper with cursors (list is busy)"; 774 end if; 775 776 Sort (Front => null, Back => null); 777 778 pragma Assert (Container.First.Prev = null); 779 pragma Assert (Container.Last.Next = null); 780 end Sort; 781 782 end Generic_Sorting; 783 784 ----------------- 785 -- Has_Element -- 786 ----------------- 787 788 function Has_Element (Position : Cursor) return Boolean is 789 begin 790 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 791 return Position.Node /= null; 792 end Has_Element; 793 794 ------------ 795 -- Insert -- 796 ------------ 797 798 procedure Insert 799 (Container : in out List; 800 Before : Cursor; 801 New_Item : Element_Type; 802 Position : out Cursor; 803 Count : Count_Type := 1) 804 is 805 New_Node : Node_Access; 806 807 begin 808 if Before.Container /= null then 809 if Before.Container /= Container'Unrestricted_Access then 810 raise Program_Error with 811 "Before cursor designates wrong list"; 812 end if; 813 814 pragma Assert (Vet (Before), "bad cursor in Insert"); 815 end if; 816 817 if Count = 0 then 818 Position := Before; 819 return; 820 end if; 821 822 if Container.Length > Count_Type'Last - Count then 823 raise Constraint_Error with "new length exceeds maximum"; 824 end if; 825 826 if Container.Busy > 0 then 827 raise Program_Error with 828 "attempt to tamper with cursors (list is busy)"; 829 end if; 830 831 New_Node := new Node_Type'(New_Item, null, null); 832 Insert_Internal (Container, Before.Node, New_Node); 833 834 Position := Cursor'(Container'Unchecked_Access, New_Node); 835 836 for J in Count_Type'(2) .. Count loop 837 New_Node := new Node_Type'(New_Item, null, null); 838 Insert_Internal (Container, Before.Node, New_Node); 839 end loop; 840 end Insert; 841 842 procedure Insert 843 (Container : in out List; 844 Before : Cursor; 845 New_Item : Element_Type; 846 Count : Count_Type := 1) 847 is 848 Position : Cursor; 849 pragma Unreferenced (Position); 850 begin 851 Insert (Container, Before, New_Item, Position, Count); 852 end Insert; 853 854 procedure Insert 855 (Container : in out List; 856 Before : Cursor; 857 Position : out Cursor; 858 Count : Count_Type := 1) 859 is 860 New_Node : Node_Access; 861 862 begin 863 if Before.Container /= null then 864 if Before.Container /= Container'Unrestricted_Access then 865 raise Program_Error with 866 "Before cursor designates wrong list"; 867 end if; 868 869 pragma Assert (Vet (Before), "bad cursor in Insert"); 870 end if; 871 872 if Count = 0 then 873 Position := Before; 874 return; 875 end if; 876 877 if Container.Length > Count_Type'Last - Count then 878 raise Constraint_Error with "new length exceeds maximum"; 879 end if; 880 881 if Container.Busy > 0 then 882 raise Program_Error with 883 "attempt to tamper with cursors (list is busy)"; 884 end if; 885 886 New_Node := new Node_Type; 887 Insert_Internal (Container, Before.Node, New_Node); 888 889 Position := Cursor'(Container'Unchecked_Access, New_Node); 890 891 for J in Count_Type'(2) .. Count loop 892 New_Node := new Node_Type; 893 Insert_Internal (Container, Before.Node, New_Node); 894 end loop; 895 end Insert; 896 897 --------------------- 898 -- Insert_Internal -- 899 --------------------- 900 901 procedure Insert_Internal 902 (Container : in out List; 903 Before : Node_Access; 904 New_Node : Node_Access) 905 is 906 begin 907 if Container.Length = 0 then 908 pragma Assert (Before = null); 909 pragma Assert (Container.First = null); 910 pragma Assert (Container.Last = null); 911 912 Container.First := New_Node; 913 Container.Last := New_Node; 914 915 elsif Before = null then 916 pragma Assert (Container.Last.Next = null); 917 918 Container.Last.Next := New_Node; 919 New_Node.Prev := Container.Last; 920 921 Container.Last := New_Node; 922 923 elsif Before = Container.First then 924 pragma Assert (Container.First.Prev = null); 925 926 Container.First.Prev := New_Node; 927 New_Node.Next := Container.First; 928 929 Container.First := New_Node; 930 931 else 932 pragma Assert (Container.First.Prev = null); 933 pragma Assert (Container.Last.Next = null); 934 935 New_Node.Next := Before; 936 New_Node.Prev := Before.Prev; 937 938 Before.Prev.Next := New_Node; 939 Before.Prev := New_Node; 940 end if; 941 942 Container.Length := Container.Length + 1; 943 end Insert_Internal; 944 945 -------------- 946 -- Is_Empty -- 947 -------------- 948 949 function Is_Empty (Container : List) return Boolean is 950 begin 951 return Container.Length = 0; 952 end Is_Empty; 953 954 ------------- 955 -- Iterate -- 956 ------------- 957 958 procedure Iterate 959 (Container : List; 960 Process : not null access procedure (Position : Cursor)) 961 is 962 B : Natural renames Container'Unrestricted_Access.all.Busy; 963 Node : Node_Access := Container.First; 964 965 begin 966 B := B + 1; 967 968 begin 969 while Node /= null loop 970 Process (Cursor'(Container'Unrestricted_Access, Node)); 971 Node := Node.Next; 972 end loop; 973 exception 974 when others => 975 B := B - 1; 976 raise; 977 end; 978 979 B := B - 1; 980 end Iterate; 981 982 function Iterate (Container : List) 983 return List_Iterator_Interfaces.Reversible_Iterator'Class 984 is 985 B : Natural renames Container'Unrestricted_Access.all.Busy; 986 987 begin 988 -- The value of the Node component influences the behavior of the First 989 -- and Last selector functions of the iterator object. When the Node 990 -- component is null (as is the case here), this means the iterator 991 -- object was constructed without a start expression. This is a 992 -- complete iterator, meaning that the iteration starts from the 993 -- (logical) beginning of the sequence of items. 994 995 -- Note: For a forward iterator, Container.First is the beginning, and 996 -- for a reverse iterator, Container.Last is the beginning. 997 998 return It : constant Iterator := 999 Iterator'(Limited_Controlled with 1000 Container => Container'Unrestricted_Access, 1001 Node => null) 1002 do 1003 B := B + 1; 1004 end return; 1005 end Iterate; 1006 1007 function Iterate (Container : List; Start : Cursor) 1008 return List_Iterator_Interfaces.Reversible_Iterator'Class 1009 is 1010 B : Natural renames Container'Unrestricted_Access.all.Busy; 1011 1012 begin 1013 -- It was formerly the case that when Start = No_Element, the partial 1014 -- iterator was defined to behave the same as for a complete iterator, 1015 -- and iterate over the entire sequence of items. However, those 1016 -- semantics were unintuitive and arguably error-prone (it is too easy 1017 -- to accidentally create an endless loop), and so they were changed, 1018 -- per the ARG meeting in Denver on 2011/11. However, there was no 1019 -- consensus about what positive meaning this corner case should have, 1020 -- and so it was decided to simply raise an exception. This does imply, 1021 -- however, that it is not possible to use a partial iterator to specify 1022 -- an empty sequence of items. 1023 1024 if Start = No_Element then 1025 raise Constraint_Error with 1026 "Start position for iterator equals No_Element"; 1027 end if; 1028 1029 if Start.Container /= Container'Unrestricted_Access then 1030 raise Program_Error with 1031 "Start cursor of Iterate designates wrong list"; 1032 end if; 1033 1034 pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); 1035 1036 -- The value of the Node component influences the behavior of the First 1037 -- and Last selector functions of the iterator object. When the Node 1038 -- component is non-null (as is the case here), it means that this 1039 -- is a partial iteration, over a subset of the complete sequence of 1040 -- items. The iterator object was constructed with a start expression, 1041 -- indicating the position from which the iteration begins. Note that 1042 -- the start position has the same value irrespective of whether this 1043 -- is a forward or reverse iteration. 1044 1045 return It : constant Iterator := 1046 Iterator'(Limited_Controlled with 1047 Container => Container'Unrestricted_Access, 1048 Node => Start.Node) 1049 do 1050 B := B + 1; 1051 end return; 1052 end Iterate; 1053 1054 ---------- 1055 -- Last -- 1056 ---------- 1057 1058 function Last (Container : List) return Cursor is 1059 begin 1060 if Container.Last = null then 1061 return No_Element; 1062 end if; 1063 1064 return Cursor'(Container'Unrestricted_Access, Container.Last); 1065 end Last; 1066 1067 function Last (Object : Iterator) return Cursor is 1068 begin 1069 -- The value of the iterator object's Node component influences the 1070 -- behavior of the Last (and First) selector function. 1071 1072 -- When the Node component is null, this means the iterator object was 1073 -- constructed without a start expression, in which case the (reverse) 1074 -- iteration starts from the (logical) beginning of the entire sequence 1075 -- (corresponding to Container.Last, for a reverse iterator). 1076 1077 -- Otherwise, this is iteration over a partial sequence of items. When 1078 -- the Node component is non-null, the iterator object was constructed 1079 -- with a start expression, that specifies the position from which the 1080 -- (reverse) partial iteration begins. 1081 1082 if Object.Node = null then 1083 return Doubly_Linked_Lists.Last (Object.Container.all); 1084 else 1085 return Cursor'(Object.Container, Object.Node); 1086 end if; 1087 end Last; 1088 1089 ------------------ 1090 -- Last_Element -- 1091 ------------------ 1092 1093 function Last_Element (Container : List) return Element_Type is 1094 begin 1095 if Container.Last = null then 1096 raise Constraint_Error with "list is empty"; 1097 end if; 1098 1099 return Container.Last.Element; 1100 end Last_Element; 1101 1102 ------------ 1103 -- Length -- 1104 ------------ 1105 1106 function Length (Container : List) return Count_Type is 1107 begin 1108 return Container.Length; 1109 end Length; 1110 1111 ---------- 1112 -- Move -- 1113 ---------- 1114 1115 procedure Move 1116 (Target : in out List; 1117 Source : in out List) 1118 is 1119 begin 1120 if Target'Address = Source'Address then 1121 return; 1122 end if; 1123 1124 if Source.Busy > 0 then 1125 raise Program_Error with 1126 "attempt to tamper with cursors of Source (list is busy)"; 1127 end if; 1128 1129 Clear (Target); 1130 1131 Target.First := Source.First; 1132 Source.First := null; 1133 1134 Target.Last := Source.Last; 1135 Source.Last := null; 1136 1137 Target.Length := Source.Length; 1138 Source.Length := 0; 1139 end Move; 1140 1141 ---------- 1142 -- Next -- 1143 ---------- 1144 1145 procedure Next (Position : in out Cursor) is 1146 begin 1147 Position := Next (Position); 1148 end Next; 1149 1150 function Next (Position : Cursor) return Cursor is 1151 begin 1152 if Position.Node = null then 1153 return No_Element; 1154 end if; 1155 1156 pragma Assert (Vet (Position), "bad cursor in Next"); 1157 1158 declare 1159 Next_Node : constant Node_Access := Position.Node.Next; 1160 1161 begin 1162 if Next_Node = null then 1163 return No_Element; 1164 end if; 1165 1166 return Cursor'(Position.Container, Next_Node); 1167 end; 1168 end Next; 1169 1170 function Next 1171 (Object : Iterator; 1172 Position : Cursor) return Cursor 1173 is 1174 begin 1175 if Position.Container = null then 1176 return No_Element; 1177 end if; 1178 1179 if Position.Container /= Object.Container then 1180 raise Program_Error with 1181 "Position cursor of Next designates wrong list"; 1182 end if; 1183 1184 return Next (Position); 1185 end Next; 1186 1187 ------------- 1188 -- Prepend -- 1189 ------------- 1190 1191 procedure Prepend 1192 (Container : in out List; 1193 New_Item : Element_Type; 1194 Count : Count_Type := 1) 1195 is 1196 begin 1197 Insert (Container, First (Container), New_Item, Count); 1198 end Prepend; 1199 1200 -------------- 1201 -- Previous -- 1202 -------------- 1203 1204 procedure Previous (Position : in out Cursor) is 1205 begin 1206 Position := Previous (Position); 1207 end Previous; 1208 1209 function Previous (Position : Cursor) return Cursor is 1210 begin 1211 if Position.Node = null then 1212 return No_Element; 1213 end if; 1214 1215 pragma Assert (Vet (Position), "bad cursor in Previous"); 1216 1217 declare 1218 Prev_Node : constant Node_Access := Position.Node.Prev; 1219 1220 begin 1221 if Prev_Node = null then 1222 return No_Element; 1223 end if; 1224 1225 return Cursor'(Position.Container, Prev_Node); 1226 end; 1227 end Previous; 1228 1229 function Previous 1230 (Object : Iterator; 1231 Position : Cursor) return Cursor 1232 is 1233 begin 1234 if Position.Container = null then 1235 return No_Element; 1236 end if; 1237 1238 if Position.Container /= Object.Container then 1239 raise Program_Error with 1240 "Position cursor of Previous designates wrong list"; 1241 end if; 1242 1243 return Previous (Position); 1244 end Previous; 1245 1246 ------------------- 1247 -- Query_Element -- 1248 ------------------- 1249 1250 procedure Query_Element 1251 (Position : Cursor; 1252 Process : not null access procedure (Element : Element_Type)) 1253 is 1254 begin 1255 if Position.Node = null then 1256 raise Constraint_Error with 1257 "Position cursor has no element"; 1258 end if; 1259 1260 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 1261 1262 declare 1263 C : List renames Position.Container.all'Unrestricted_Access.all; 1264 B : Natural renames C.Busy; 1265 L : Natural renames C.Lock; 1266 1267 begin 1268 B := B + 1; 1269 L := L + 1; 1270 1271 begin 1272 Process (Position.Node.Element); 1273 exception 1274 when others => 1275 L := L - 1; 1276 B := B - 1; 1277 raise; 1278 end; 1279 1280 L := L - 1; 1281 B := B - 1; 1282 end; 1283 end Query_Element; 1284 1285 ---------- 1286 -- Read -- 1287 ---------- 1288 1289 procedure Read 1290 (Stream : not null access Root_Stream_Type'Class; 1291 Item : out List) 1292 is 1293 N : Count_Type'Base; 1294 X : Node_Access; 1295 1296 begin 1297 Clear (Item); 1298 Count_Type'Base'Read (Stream, N); 1299 1300 if N = 0 then 1301 return; 1302 end if; 1303 1304 X := new Node_Type; 1305 1306 begin 1307 Element_Type'Read (Stream, X.Element); 1308 exception 1309 when others => 1310 Free (X); 1311 raise; 1312 end; 1313 1314 Item.First := X; 1315 Item.Last := X; 1316 1317 loop 1318 Item.Length := Item.Length + 1; 1319 exit when Item.Length = N; 1320 1321 X := new Node_Type; 1322 1323 begin 1324 Element_Type'Read (Stream, X.Element); 1325 exception 1326 when others => 1327 Free (X); 1328 raise; 1329 end; 1330 1331 X.Prev := Item.Last; 1332 Item.Last.Next := X; 1333 Item.Last := X; 1334 end loop; 1335 end Read; 1336 1337 procedure Read 1338 (Stream : not null access Root_Stream_Type'Class; 1339 Item : out Cursor) 1340 is 1341 begin 1342 raise Program_Error with "attempt to stream list cursor"; 1343 end Read; 1344 1345 procedure Read 1346 (Stream : not null access Root_Stream_Type'Class; 1347 Item : out Reference_Type) 1348 is 1349 begin 1350 raise Program_Error with "attempt to stream reference"; 1351 end Read; 1352 1353 procedure Read 1354 (Stream : not null access Root_Stream_Type'Class; 1355 Item : out Constant_Reference_Type) 1356 is 1357 begin 1358 raise Program_Error with "attempt to stream reference"; 1359 end Read; 1360 1361 --------------- 1362 -- Reference -- 1363 --------------- 1364 1365 function Reference 1366 (Container : aliased in out List; 1367 Position : Cursor) return Reference_Type 1368 is 1369 begin 1370 if Position.Container = null then 1371 raise Constraint_Error with "Position cursor has no element"; 1372 end if; 1373 1374 if Position.Container /= Container'Unchecked_Access then 1375 raise Program_Error with 1376 "Position cursor designates wrong container"; 1377 end if; 1378 1379 pragma Assert (Vet (Position), "bad cursor in function Reference"); 1380 1381 declare 1382 C : List renames Position.Container.all; 1383 B : Natural renames C.Busy; 1384 L : Natural renames C.Lock; 1385 begin 1386 return R : constant Reference_Type := 1387 (Element => Position.Node.Element'Access, 1388 Control => (Controlled with Position.Container)) 1389 do 1390 B := B + 1; 1391 L := L + 1; 1392 end return; 1393 end; 1394 end Reference; 1395 1396 --------------------- 1397 -- Replace_Element -- 1398 --------------------- 1399 1400 procedure Replace_Element 1401 (Container : in out List; 1402 Position : Cursor; 1403 New_Item : Element_Type) 1404 is 1405 begin 1406 if Position.Container = null then 1407 raise Constraint_Error with "Position cursor has no element"; 1408 end if; 1409 1410 if Position.Container /= Container'Unchecked_Access then 1411 raise Program_Error with 1412 "Position cursor designates wrong container"; 1413 end if; 1414 1415 if Container.Lock > 0 then 1416 raise Program_Error with 1417 "attempt to tamper with elements (list is locked)"; 1418 end if; 1419 1420 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1421 1422 Position.Node.Element := New_Item; 1423 end Replace_Element; 1424 1425 ---------------------- 1426 -- Reverse_Elements -- 1427 ---------------------- 1428 1429 procedure Reverse_Elements (Container : in out List) is 1430 I : Node_Access := Container.First; 1431 J : Node_Access := Container.Last; 1432 1433 procedure Swap (L, R : Node_Access); 1434 1435 ---------- 1436 -- Swap -- 1437 ---------- 1438 1439 procedure Swap (L, R : Node_Access) is 1440 LN : constant Node_Access := L.Next; 1441 LP : constant Node_Access := L.Prev; 1442 1443 RN : constant Node_Access := R.Next; 1444 RP : constant Node_Access := R.Prev; 1445 1446 begin 1447 if LP /= null then 1448 LP.Next := R; 1449 end if; 1450 1451 if RN /= null then 1452 RN.Prev := L; 1453 end if; 1454 1455 L.Next := RN; 1456 R.Prev := LP; 1457 1458 if LN = R then 1459 pragma Assert (RP = L); 1460 1461 L.Prev := R; 1462 R.Next := L; 1463 1464 else 1465 L.Prev := RP; 1466 RP.Next := L; 1467 1468 R.Next := LN; 1469 LN.Prev := R; 1470 end if; 1471 end Swap; 1472 1473 -- Start of processing for Reverse_Elements 1474 1475 begin 1476 if Container.Length <= 1 then 1477 return; 1478 end if; 1479 1480 pragma Assert (Container.First.Prev = null); 1481 pragma Assert (Container.Last.Next = null); 1482 1483 if Container.Busy > 0 then 1484 raise Program_Error with 1485 "attempt to tamper with cursors (list is busy)"; 1486 end if; 1487 1488 Container.First := J; 1489 Container.Last := I; 1490 loop 1491 Swap (L => I, R => J); 1492 1493 J := J.Next; 1494 exit when I = J; 1495 1496 I := I.Prev; 1497 exit when I = J; 1498 1499 Swap (L => J, R => I); 1500 1501 I := I.Next; 1502 exit when I = J; 1503 1504 J := J.Prev; 1505 exit when I = J; 1506 end loop; 1507 1508 pragma Assert (Container.First.Prev = null); 1509 pragma Assert (Container.Last.Next = null); 1510 end Reverse_Elements; 1511 1512 ------------------ 1513 -- Reverse_Find -- 1514 ------------------ 1515 1516 function Reverse_Find 1517 (Container : List; 1518 Item : Element_Type; 1519 Position : Cursor := No_Element) return Cursor 1520 is 1521 Node : Node_Access := Position.Node; 1522 1523 begin 1524 if Node = null then 1525 Node := Container.Last; 1526 1527 else 1528 if Position.Container /= Container'Unrestricted_Access then 1529 raise Program_Error with 1530 "Position cursor designates wrong container"; 1531 end if; 1532 1533 pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); 1534 end if; 1535 1536 while Node /= null loop 1537 if Node.Element = Item then 1538 return Cursor'(Container'Unrestricted_Access, Node); 1539 end if; 1540 1541 Node := Node.Prev; 1542 end loop; 1543 1544 return No_Element; 1545 end Reverse_Find; 1546 1547 --------------------- 1548 -- Reverse_Iterate -- 1549 --------------------- 1550 1551 procedure Reverse_Iterate 1552 (Container : List; 1553 Process : not null access procedure (Position : Cursor)) 1554 is 1555 C : List renames Container'Unrestricted_Access.all; 1556 B : Natural renames C.Busy; 1557 1558 Node : Node_Access := Container.Last; 1559 1560 begin 1561 B := B + 1; 1562 1563 begin 1564 while Node /= null loop 1565 Process (Cursor'(Container'Unrestricted_Access, Node)); 1566 Node := Node.Prev; 1567 end loop; 1568 1569 exception 1570 when others => 1571 B := B - 1; 1572 raise; 1573 end; 1574 1575 B := B - 1; 1576 end Reverse_Iterate; 1577 1578 ------------ 1579 -- Splice -- 1580 ------------ 1581 1582 procedure Splice 1583 (Target : in out List; 1584 Before : Cursor; 1585 Source : in out List) 1586 is 1587 begin 1588 if Before.Container /= null then 1589 if Before.Container /= Target'Unrestricted_Access then 1590 raise Program_Error with 1591 "Before cursor designates wrong container"; 1592 end if; 1593 1594 pragma Assert (Vet (Before), "bad cursor in Splice"); 1595 end if; 1596 1597 if Target'Address = Source'Address 1598 or else Source.Length = 0 1599 then 1600 return; 1601 end if; 1602 1603 pragma Assert (Source.First.Prev = null); 1604 pragma Assert (Source.Last.Next = null); 1605 1606 if Target.Length > Count_Type'Last - Source.Length then 1607 raise Constraint_Error with "new length exceeds maximum"; 1608 end if; 1609 1610 if Target.Busy > 0 then 1611 raise Program_Error with 1612 "attempt to tamper with cursors of Target (list is busy)"; 1613 end if; 1614 1615 if Source.Busy > 0 then 1616 raise Program_Error with 1617 "attempt to tamper with cursors of Source (list is busy)"; 1618 end if; 1619 1620 if Target.Length = 0 then 1621 pragma Assert (Target.First = null); 1622 pragma Assert (Target.Last = null); 1623 pragma Assert (Before = No_Element); 1624 1625 Target.First := Source.First; 1626 Target.Last := Source.Last; 1627 1628 elsif Before.Node = null then 1629 pragma Assert (Target.Last.Next = null); 1630 1631 Target.Last.Next := Source.First; 1632 Source.First.Prev := Target.Last; 1633 1634 Target.Last := Source.Last; 1635 1636 elsif Before.Node = Target.First then 1637 pragma Assert (Target.First.Prev = null); 1638 1639 Source.Last.Next := Target.First; 1640 Target.First.Prev := Source.Last; 1641 1642 Target.First := Source.First; 1643 1644 else 1645 pragma Assert (Target.Length >= 2); 1646 1647 Before.Node.Prev.Next := Source.First; 1648 Source.First.Prev := Before.Node.Prev; 1649 1650 Before.Node.Prev := Source.Last; 1651 Source.Last.Next := Before.Node; 1652 end if; 1653 1654 Source.First := null; 1655 Source.Last := null; 1656 1657 Target.Length := Target.Length + Source.Length; 1658 Source.Length := 0; 1659 end Splice; 1660 1661 procedure Splice 1662 (Container : in out List; 1663 Before : Cursor; 1664 Position : Cursor) 1665 is 1666 begin 1667 if Before.Container /= null then 1668 if Before.Container /= Container'Unchecked_Access then 1669 raise Program_Error with 1670 "Before cursor designates wrong container"; 1671 end if; 1672 1673 pragma Assert (Vet (Before), "bad Before cursor in Splice"); 1674 end if; 1675 1676 if Position.Node = null then 1677 raise Constraint_Error with "Position cursor has no element"; 1678 end if; 1679 1680 if Position.Container /= Container'Unrestricted_Access then 1681 raise Program_Error with 1682 "Position cursor designates wrong container"; 1683 end if; 1684 1685 pragma Assert (Vet (Position), "bad Position cursor in Splice"); 1686 1687 if Position.Node = Before.Node 1688 or else Position.Node.Next = Before.Node 1689 then 1690 return; 1691 end if; 1692 1693 pragma Assert (Container.Length >= 2); 1694 1695 if Container.Busy > 0 then 1696 raise Program_Error with 1697 "attempt to tamper with cursors (list is busy)"; 1698 end if; 1699 1700 if Before.Node = null then 1701 pragma Assert (Position.Node /= Container.Last); 1702 1703 if Position.Node = Container.First then 1704 Container.First := Position.Node.Next; 1705 Container.First.Prev := null; 1706 else 1707 Position.Node.Prev.Next := Position.Node.Next; 1708 Position.Node.Next.Prev := Position.Node.Prev; 1709 end if; 1710 1711 Container.Last.Next := Position.Node; 1712 Position.Node.Prev := Container.Last; 1713 1714 Container.Last := Position.Node; 1715 Container.Last.Next := null; 1716 1717 return; 1718 end if; 1719 1720 if Before.Node = Container.First then 1721 pragma Assert (Position.Node /= Container.First); 1722 1723 if Position.Node = Container.Last then 1724 Container.Last := Position.Node.Prev; 1725 Container.Last.Next := null; 1726 else 1727 Position.Node.Prev.Next := Position.Node.Next; 1728 Position.Node.Next.Prev := Position.Node.Prev; 1729 end if; 1730 1731 Container.First.Prev := Position.Node; 1732 Position.Node.Next := Container.First; 1733 1734 Container.First := Position.Node; 1735 Container.First.Prev := null; 1736 1737 return; 1738 end if; 1739 1740 if Position.Node = Container.First then 1741 Container.First := Position.Node.Next; 1742 Container.First.Prev := null; 1743 1744 elsif Position.Node = Container.Last then 1745 Container.Last := Position.Node.Prev; 1746 Container.Last.Next := null; 1747 1748 else 1749 Position.Node.Prev.Next := Position.Node.Next; 1750 Position.Node.Next.Prev := Position.Node.Prev; 1751 end if; 1752 1753 Before.Node.Prev.Next := Position.Node; 1754 Position.Node.Prev := Before.Node.Prev; 1755 1756 Before.Node.Prev := Position.Node; 1757 Position.Node.Next := Before.Node; 1758 1759 pragma Assert (Container.First.Prev = null); 1760 pragma Assert (Container.Last.Next = null); 1761 end Splice; 1762 1763 procedure Splice 1764 (Target : in out List; 1765 Before : Cursor; 1766 Source : in out List; 1767 Position : in out Cursor) 1768 is 1769 begin 1770 if Target'Address = Source'Address then 1771 Splice (Target, Before, Position); 1772 return; 1773 end if; 1774 1775 if Before.Container /= null then 1776 if Before.Container /= Target'Unrestricted_Access then 1777 raise Program_Error with 1778 "Before cursor designates wrong container"; 1779 end if; 1780 1781 pragma Assert (Vet (Before), "bad Before cursor in Splice"); 1782 end if; 1783 1784 if Position.Node = null then 1785 raise Constraint_Error with "Position cursor has no element"; 1786 end if; 1787 1788 if Position.Container /= Source'Unrestricted_Access then 1789 raise Program_Error with 1790 "Position cursor designates wrong container"; 1791 end if; 1792 1793 pragma Assert (Vet (Position), "bad Position cursor in Splice"); 1794 1795 if Target.Length = Count_Type'Last then 1796 raise Constraint_Error with "Target is full"; 1797 end if; 1798 1799 if Target.Busy > 0 then 1800 raise Program_Error with 1801 "attempt to tamper with cursors of Target (list is busy)"; 1802 end if; 1803 1804 if Source.Busy > 0 then 1805 raise Program_Error with 1806 "attempt to tamper with cursors of Source (list is busy)"; 1807 end if; 1808 1809 if Position.Node = Source.First then 1810 Source.First := Position.Node.Next; 1811 1812 if Position.Node = Source.Last then 1813 pragma Assert (Source.First = null); 1814 pragma Assert (Source.Length = 1); 1815 Source.Last := null; 1816 1817 else 1818 Source.First.Prev := null; 1819 end if; 1820 1821 elsif Position.Node = Source.Last then 1822 pragma Assert (Source.Length >= 2); 1823 Source.Last := Position.Node.Prev; 1824 Source.Last.Next := null; 1825 1826 else 1827 pragma Assert (Source.Length >= 3); 1828 Position.Node.Prev.Next := Position.Node.Next; 1829 Position.Node.Next.Prev := Position.Node.Prev; 1830 end if; 1831 1832 if Target.Length = 0 then 1833 pragma Assert (Target.First = null); 1834 pragma Assert (Target.Last = null); 1835 pragma Assert (Before = No_Element); 1836 1837 Target.First := Position.Node; 1838 Target.Last := Position.Node; 1839 1840 Target.First.Prev := null; 1841 Target.Last.Next := null; 1842 1843 elsif Before.Node = null then 1844 pragma Assert (Target.Last.Next = null); 1845 Target.Last.Next := Position.Node; 1846 Position.Node.Prev := Target.Last; 1847 1848 Target.Last := Position.Node; 1849 Target.Last.Next := null; 1850 1851 elsif Before.Node = Target.First then 1852 pragma Assert (Target.First.Prev = null); 1853 Target.First.Prev := Position.Node; 1854 Position.Node.Next := Target.First; 1855 1856 Target.First := Position.Node; 1857 Target.First.Prev := null; 1858 1859 else 1860 pragma Assert (Target.Length >= 2); 1861 Before.Node.Prev.Next := Position.Node; 1862 Position.Node.Prev := Before.Node.Prev; 1863 1864 Before.Node.Prev := Position.Node; 1865 Position.Node.Next := Before.Node; 1866 end if; 1867 1868 Target.Length := Target.Length + 1; 1869 Source.Length := Source.Length - 1; 1870 1871 Position.Container := Target'Unchecked_Access; 1872 end Splice; 1873 1874 ---------- 1875 -- Swap -- 1876 ---------- 1877 1878 procedure Swap 1879 (Container : in out List; 1880 I, J : Cursor) 1881 is 1882 begin 1883 if I.Node = null then 1884 raise Constraint_Error with "I cursor has no element"; 1885 end if; 1886 1887 if J.Node = null then 1888 raise Constraint_Error with "J cursor has no element"; 1889 end if; 1890 1891 if I.Container /= Container'Unchecked_Access then 1892 raise Program_Error with "I cursor designates wrong container"; 1893 end if; 1894 1895 if J.Container /= Container'Unchecked_Access then 1896 raise Program_Error with "J cursor designates wrong container"; 1897 end if; 1898 1899 if I.Node = J.Node then 1900 return; 1901 end if; 1902 1903 if Container.Lock > 0 then 1904 raise Program_Error with 1905 "attempt to tamper with elements (list is locked)"; 1906 end if; 1907 1908 pragma Assert (Vet (I), "bad I cursor in Swap"); 1909 pragma Assert (Vet (J), "bad J cursor in Swap"); 1910 1911 declare 1912 EI : Element_Type renames I.Node.Element; 1913 EJ : Element_Type renames J.Node.Element; 1914 1915 EI_Copy : constant Element_Type := EI; 1916 1917 begin 1918 EI := EJ; 1919 EJ := EI_Copy; 1920 end; 1921 end Swap; 1922 1923 ---------------- 1924 -- Swap_Links -- 1925 ---------------- 1926 1927 procedure Swap_Links 1928 (Container : in out List; 1929 I, J : Cursor) 1930 is 1931 begin 1932 if I.Node = null then 1933 raise Constraint_Error with "I cursor has no element"; 1934 end if; 1935 1936 if J.Node = null then 1937 raise Constraint_Error with "J cursor has no element"; 1938 end if; 1939 1940 if I.Container /= Container'Unrestricted_Access then 1941 raise Program_Error with "I cursor designates wrong container"; 1942 end if; 1943 1944 if J.Container /= Container'Unrestricted_Access then 1945 raise Program_Error with "J cursor designates wrong container"; 1946 end if; 1947 1948 if I.Node = J.Node then 1949 return; 1950 end if; 1951 1952 if Container.Busy > 0 then 1953 raise Program_Error with 1954 "attempt to tamper with cursors (list is busy)"; 1955 end if; 1956 1957 pragma Assert (Vet (I), "bad I cursor in Swap_Links"); 1958 pragma Assert (Vet (J), "bad J cursor in Swap_Links"); 1959 1960 declare 1961 I_Next : constant Cursor := Next (I); 1962 1963 begin 1964 if I_Next = J then 1965 Splice (Container, Before => I, Position => J); 1966 1967 else 1968 declare 1969 J_Next : constant Cursor := Next (J); 1970 1971 begin 1972 if J_Next = I then 1973 Splice (Container, Before => J, Position => I); 1974 1975 else 1976 pragma Assert (Container.Length >= 3); 1977 1978 Splice (Container, Before => I_Next, Position => J); 1979 Splice (Container, Before => J_Next, Position => I); 1980 end if; 1981 end; 1982 end if; 1983 end; 1984 end Swap_Links; 1985 1986 -------------------- 1987 -- Update_Element -- 1988 -------------------- 1989 1990 procedure Update_Element 1991 (Container : in out List; 1992 Position : Cursor; 1993 Process : not null access procedure (Element : in out Element_Type)) 1994 is 1995 begin 1996 if Position.Node = null then 1997 raise Constraint_Error with "Position cursor has no element"; 1998 end if; 1999 2000 if Position.Container /= Container'Unchecked_Access then 2001 raise Program_Error with 2002 "Position cursor designates wrong container"; 2003 end if; 2004 2005 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 2006 2007 declare 2008 B : Natural renames Container.Busy; 2009 L : Natural renames Container.Lock; 2010 2011 begin 2012 B := B + 1; 2013 L := L + 1; 2014 2015 begin 2016 Process (Position.Node.Element); 2017 exception 2018 when others => 2019 L := L - 1; 2020 B := B - 1; 2021 raise; 2022 end; 2023 2024 L := L - 1; 2025 B := B - 1; 2026 end; 2027 end Update_Element; 2028 2029 --------- 2030 -- Vet -- 2031 --------- 2032 2033 function Vet (Position : Cursor) return Boolean is 2034 begin 2035 if Position.Node = null then 2036 return Position.Container = null; 2037 end if; 2038 2039 if Position.Container = null then 2040 return False; 2041 end if; 2042 2043 -- An invariant of a node is that its Previous and Next components can 2044 -- be null, or designate a different node. Operation Free sets the 2045 -- access value components of the node to designate the node itself 2046 -- before actually deallocating the node, thus deliberately violating 2047 -- the node invariant. This gives us a simple way to detect a dangling 2048 -- reference to a node. 2049 2050 if Position.Node.Next = Position.Node then 2051 return False; 2052 end if; 2053 2054 if Position.Node.Prev = Position.Node then 2055 return False; 2056 end if; 2057 2058 -- In practice the tests above will detect most instances of a dangling 2059 -- reference. If we get here, it means that the invariants of the 2060 -- designated node are satisfied (they at least appear to be satisfied), 2061 -- so we perform some more tests, to determine whether invariants of the 2062 -- designated list are satisfied too. 2063 2064 declare 2065 L : List renames Position.Container.all; 2066 2067 begin 2068 if L.Length = 0 then 2069 return False; 2070 end if; 2071 2072 if L.First = null then 2073 return False; 2074 end if; 2075 2076 if L.Last = null then 2077 return False; 2078 end if; 2079 2080 if L.First.Prev /= null then 2081 return False; 2082 end if; 2083 2084 if L.Last.Next /= null then 2085 return False; 2086 end if; 2087 2088 if Position.Node.Prev = null and then Position.Node /= L.First then 2089 return False; 2090 end if; 2091 2092 pragma Assert 2093 (Position.Node.Prev /= null 2094 or else Position.Node = L.First); 2095 2096 if Position.Node.Next = null and then Position.Node /= L.Last then 2097 return False; 2098 end if; 2099 2100 pragma Assert 2101 (Position.Node.Next /= null 2102 or else Position.Node = L.Last); 2103 2104 if L.Length = 1 then 2105 return L.First = L.Last; 2106 end if; 2107 2108 if L.First = L.Last then 2109 return False; 2110 end if; 2111 2112 if L.First.Next = null then 2113 return False; 2114 end if; 2115 2116 if L.Last.Prev = null then 2117 return False; 2118 end if; 2119 2120 if L.First.Next.Prev /= L.First then 2121 return False; 2122 end if; 2123 2124 if L.Last.Prev.Next /= L.Last then 2125 return False; 2126 end if; 2127 2128 if L.Length = 2 then 2129 if L.First.Next /= L.Last then 2130 return False; 2131 elsif L.Last.Prev /= L.First then 2132 return False; 2133 else 2134 return True; 2135 end if; 2136 end if; 2137 2138 if L.First.Next = L.Last then 2139 return False; 2140 end if; 2141 2142 if L.Last.Prev = L.First then 2143 return False; 2144 end if; 2145 2146 -- Eliminate earlier possibility 2147 2148 if Position.Node = L.First then 2149 return True; 2150 end if; 2151 2152 pragma Assert (Position.Node.Prev /= null); 2153 2154 -- Eliminate earlier possibility 2155 2156 if Position.Node = L.Last then 2157 return True; 2158 end if; 2159 2160 pragma Assert (Position.Node.Next /= null); 2161 2162 if Position.Node.Next.Prev /= Position.Node then 2163 return False; 2164 end if; 2165 2166 if Position.Node.Prev.Next /= Position.Node then 2167 return False; 2168 end if; 2169 2170 if L.Length = 3 then 2171 if L.First.Next /= Position.Node then 2172 return False; 2173 elsif L.Last.Prev /= Position.Node then 2174 return False; 2175 end if; 2176 end if; 2177 2178 return True; 2179 end; 2180 end Vet; 2181 2182 ----------- 2183 -- Write -- 2184 ----------- 2185 2186 procedure Write 2187 (Stream : not null access Root_Stream_Type'Class; 2188 Item : List) 2189 is 2190 Node : Node_Access; 2191 2192 begin 2193 Count_Type'Base'Write (Stream, Item.Length); 2194 2195 Node := Item.First; 2196 while Node /= null loop 2197 Element_Type'Write (Stream, Node.Element); 2198 Node := Node.Next; 2199 end loop; 2200 end Write; 2201 2202 procedure Write 2203 (Stream : not null access Root_Stream_Type'Class; 2204 Item : Cursor) 2205 is 2206 begin 2207 raise Program_Error with "attempt to stream list cursor"; 2208 end Write; 2209 2210 procedure Write 2211 (Stream : not null access Root_Stream_Type'Class; 2212 Item : Reference_Type) 2213 is 2214 begin 2215 raise Program_Error with "attempt to stream reference"; 2216 end Write; 2217 2218 procedure Write 2219 (Stream : not null access Root_Stream_Type'Class; 2220 Item : Constant_Reference_Type) 2221 is 2222 begin 2223 raise Program_Error with "attempt to stream reference"; 2224 end Write; 2225 2226end Ada.Containers.Doubly_Linked_Lists; 2227