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