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