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