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