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