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