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