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