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