1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.RESTRICTED_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 System; use type System.Address; 31 32package body Ada.Containers.Restricted_Doubly_Linked_Lists is 33 34 ----------------------- 35 -- Local Subprograms -- 36 ----------------------- 37 38 procedure Allocate 39 (Container : in out List'Class; 40 New_Item : Element_Type; 41 New_Node : out Count_Type); 42 43 procedure Free 44 (Container : in out List'Class; 45 X : Count_Type); 46 47 procedure Insert_Internal 48 (Container : in out List'Class; 49 Before : Count_Type; 50 New_Node : Count_Type); 51 52 function Vet (Position : Cursor) return Boolean; 53 54 --------- 55 -- "=" -- 56 --------- 57 58 function "=" (Left, Right : List) return Boolean is 59 LN : Node_Array renames Left.Nodes; 60 RN : Node_Array renames Right.Nodes; 61 62 LI : Count_Type := Left.First; 63 RI : Count_Type := Right.First; 64 65 begin 66 if Left'Address = Right'Address then 67 return True; 68 end if; 69 70 if Left.Length /= Right.Length then 71 return False; 72 end if; 73 74 for J in 1 .. Left.Length loop 75 if LN (LI).Element /= RN (RI).Element then 76 return False; 77 end if; 78 79 LI := LN (LI).Next; 80 RI := RN (RI).Next; 81 end loop; 82 83 return True; 84 end "="; 85 86 -------------- 87 -- Allocate -- 88 -------------- 89 90 procedure Allocate 91 (Container : in out List'Class; 92 New_Item : Element_Type; 93 New_Node : out Count_Type) 94 is 95 N : Node_Array renames Container.Nodes; 96 97 begin 98 if Container.Free >= 0 then 99 New_Node := Container.Free; 100 N (New_Node).Element := New_Item; 101 Container.Free := N (New_Node).Next; 102 103 else 104 New_Node := abs Container.Free; 105 N (New_Node).Element := New_Item; 106 Container.Free := Container.Free - 1; 107 end if; 108 end Allocate; 109 110 ------------ 111 -- Append -- 112 ------------ 113 114 procedure Append 115 (Container : in out List; 116 New_Item : Element_Type; 117 Count : Count_Type := 1) 118 is 119 begin 120 Insert (Container, No_Element, New_Item, Count); 121 end Append; 122 123 ------------ 124 -- Assign -- 125 ------------ 126 127 procedure Assign (Target : in out List; Source : List) is 128 begin 129 if Target'Address = Source'Address then 130 return; 131 end if; 132 133 if Target.Capacity < Source.Length then 134 raise Constraint_Error; -- ??? 135 end if; 136 137 Clear (Target); 138 139 declare 140 N : Node_Array renames Source.Nodes; 141 J : Count_Type := Source.First; 142 143 begin 144 while J /= 0 loop 145 Append (Target, N (J).Element); 146 J := N (J).Next; 147 end loop; 148 end; 149 end Assign; 150 151 ----------- 152 -- Clear -- 153 ----------- 154 155 procedure Clear (Container : in out List) is 156 N : Node_Array renames Container.Nodes; 157 X : Count_Type; 158 159 begin 160 if Container.Length = 0 then 161 pragma Assert (Container.First = 0); 162 pragma Assert (Container.Last = 0); 163-- pragma Assert (Container.Busy = 0); 164-- pragma Assert (Container.Lock = 0); 165 return; 166 end if; 167 168 pragma Assert (Container.First >= 1); 169 pragma Assert (Container.Last >= 1); 170 pragma Assert (N (Container.First).Prev = 0); 171 pragma Assert (N (Container.Last).Next = 0); 172 173-- if Container.Busy > 0 then 174-- raise Program_Error; 175-- end if; 176 177 while Container.Length > 1 loop 178 X := Container.First; 179 180 Container.First := N (X).Next; 181 N (Container.First).Prev := 0; 182 183 Container.Length := Container.Length - 1; 184 185 Free (Container, X); 186 end loop; 187 188 X := Container.First; 189 190 Container.First := 0; 191 Container.Last := 0; 192 Container.Length := 0; 193 194 Free (Container, X); 195 end Clear; 196 197 -------------- 198 -- Contains -- 199 -------------- 200 201 function Contains 202 (Container : List; 203 Item : Element_Type) return Boolean 204 is 205 begin 206 return Find (Container, Item) /= No_Element; 207 end Contains; 208 209 ------------ 210 -- Delete -- 211 ------------ 212 213 procedure Delete 214 (Container : in out List; 215 Position : in out Cursor; 216 Count : Count_Type := 1) 217 is 218 N : Node_Array renames Container.Nodes; 219 X : Count_Type; 220 221 begin 222 if Position.Node = 0 then 223 raise Constraint_Error; 224 end if; 225 226 if Position.Container /= Container'Unrestricted_Access then 227 raise Program_Error; 228 end if; 229 230 pragma Assert (Vet (Position), "bad cursor in Delete"); 231 232 if Position.Node = Container.First then 233 Delete_First (Container, Count); 234 Position := No_Element; 235 return; 236 end if; 237 238 if Count = 0 then 239 Position := No_Element; 240 return; 241 end if; 242 243-- if Container.Busy > 0 then 244-- raise Program_Error; 245-- end if; 246 247 pragma Assert (Container.First >= 1); 248 pragma Assert (Container.Last >= 1); 249 pragma Assert (N (Container.First).Prev = 0); 250 pragma Assert (N (Container.Last).Next = 0); 251 252 for Index in 1 .. Count loop 253 pragma Assert (Container.Length >= 2); 254 255 X := Position.Node; 256 Container.Length := Container.Length - 1; 257 258 if X = Container.Last then 259 Position := No_Element; 260 261 Container.Last := N (X).Prev; 262 N (Container.Last).Next := 0; 263 264 Free (Container, X); 265 return; 266 end if; 267 268 Position.Node := N (X).Next; 269 270 N (N (X).Next).Prev := N (X).Prev; 271 N (N (X).Prev).Next := N (X).Next; 272 273 Free (Container, X); 274 end loop; 275 276 Position := No_Element; 277 end Delete; 278 279 ------------------ 280 -- Delete_First -- 281 ------------------ 282 283 procedure Delete_First 284 (Container : in out List; 285 Count : Count_Type := 1) 286 is 287 N : Node_Array renames Container.Nodes; 288 X : Count_Type; 289 290 begin 291 if Count >= Container.Length then 292 Clear (Container); 293 return; 294 end if; 295 296 if Count = 0 then 297 return; 298 end if; 299 300-- if Container.Busy > 0 then 301-- raise Program_Error; 302-- end if; 303 304 for I in 1 .. Count loop 305 X := Container.First; 306 pragma Assert (N (N (X).Next).Prev = Container.First); 307 308 Container.First := N (X).Next; 309 N (Container.First).Prev := 0; 310 311 Container.Length := Container.Length - 1; 312 313 Free (Container, X); 314 end loop; 315 end Delete_First; 316 317 ----------------- 318 -- Delete_Last -- 319 ----------------- 320 321 procedure Delete_Last 322 (Container : in out List; 323 Count : Count_Type := 1) 324 is 325 N : Node_Array renames Container.Nodes; 326 X : Count_Type; 327 328 begin 329 if Count >= Container.Length then 330 Clear (Container); 331 return; 332 end if; 333 334 if Count = 0 then 335 return; 336 end if; 337 338-- if Container.Busy > 0 then 339-- raise Program_Error; 340-- end if; 341 342 for I in 1 .. Count loop 343 X := Container.Last; 344 pragma Assert (N (N (X).Prev).Next = Container.Last); 345 346 Container.Last := N (X).Prev; 347 N (Container.Last).Next := 0; 348 349 Container.Length := Container.Length - 1; 350 351 Free (Container, X); 352 end loop; 353 end Delete_Last; 354 355 ------------- 356 -- Element -- 357 ------------- 358 359 function Element (Position : Cursor) return Element_Type is 360 begin 361 if Position.Node = 0 then 362 raise Constraint_Error; 363 end if; 364 365 pragma Assert (Vet (Position), "bad cursor in Element"); 366 367 declare 368 N : Node_Array renames Position.Container.Nodes; 369 begin 370 return N (Position.Node).Element; 371 end; 372 end Element; 373 374 ---------- 375 -- Find -- 376 ---------- 377 378 function Find 379 (Container : List; 380 Item : Element_Type; 381 Position : Cursor := No_Element) return Cursor 382 is 383 Nodes : Node_Array renames Container.Nodes; 384 Node : Count_Type := Position.Node; 385 386 begin 387 if Node = 0 then 388 Node := Container.First; 389 390 else 391 if Position.Container /= Container'Unrestricted_Access then 392 raise Program_Error; 393 end if; 394 395 pragma Assert (Vet (Position), "bad cursor in Find"); 396 end if; 397 398 while Node /= 0 loop 399 if Nodes (Node).Element = Item then 400 return Cursor'(Container'Unrestricted_Access, Node); 401 end if; 402 403 Node := Nodes (Node).Next; 404 end loop; 405 406 return No_Element; 407 end Find; 408 409 ----------- 410 -- First -- 411 ----------- 412 413 function First (Container : List) return Cursor is 414 begin 415 if Container.First = 0 then 416 return No_Element; 417 end if; 418 419 return Cursor'(Container'Unrestricted_Access, Container.First); 420 end First; 421 422 ------------------- 423 -- First_Element -- 424 ------------------- 425 426 function First_Element (Container : List) return Element_Type is 427 N : Node_Array renames Container.Nodes; 428 429 begin 430 if Container.First = 0 then 431 raise Constraint_Error; 432 end if; 433 434 return N (Container.First).Element; 435 end First_Element; 436 437 ---------- 438 -- Free -- 439 ---------- 440 441 procedure Free 442 (Container : in out List'Class; 443 X : Count_Type) 444 is 445 pragma Assert (X > 0); 446 pragma Assert (X <= Container.Capacity); 447 448 N : Node_Array renames Container.Nodes; 449 450 begin 451 N (X).Prev := -1; -- Node is deallocated (not on active list) 452 453 if Container.Free >= 0 then 454 N (X).Next := Container.Free; 455 Container.Free := X; 456 457 elsif X + 1 = abs Container.Free then 458 N (X).Next := 0; -- Not strictly necessary, but marginally safer 459 Container.Free := Container.Free + 1; 460 461 else 462 Container.Free := abs Container.Free; 463 464 if Container.Free > Container.Capacity then 465 Container.Free := 0; 466 467 else 468 for I in Container.Free .. Container.Capacity - 1 loop 469 N (I).Next := I + 1; 470 end loop; 471 472 N (Container.Capacity).Next := 0; 473 end if; 474 475 N (X).Next := Container.Free; 476 Container.Free := X; 477 end if; 478 end Free; 479 480 --------------------- 481 -- Generic_Sorting -- 482 --------------------- 483 484 package body Generic_Sorting is 485 486 --------------- 487 -- Is_Sorted -- 488 --------------- 489 490 function Is_Sorted (Container : List) return Boolean is 491 Nodes : Node_Array renames Container.Nodes; 492 Node : Count_Type := Container.First; 493 494 begin 495 for I in 2 .. Container.Length loop 496 if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then 497 return False; 498 end if; 499 500 Node := Nodes (Node).Next; 501 end loop; 502 503 return True; 504 end Is_Sorted; 505 506 ---------- 507 -- Sort -- 508 ---------- 509 510 procedure Sort (Container : in out List) is 511 N : Node_Array renames Container.Nodes; 512 513 procedure Partition (Pivot, Back : Count_Type); 514 procedure Sort (Front, Back : Count_Type); 515 516 --------------- 517 -- Partition -- 518 --------------- 519 520 procedure Partition (Pivot, Back : Count_Type) is 521 Node : Count_Type := N (Pivot).Next; 522 523 begin 524 while Node /= Back loop 525 if N (Node).Element < N (Pivot).Element then 526 declare 527 Prev : constant Count_Type := N (Node).Prev; 528 Next : constant Count_Type := N (Node).Next; 529 530 begin 531 N (Prev).Next := Next; 532 533 if Next = 0 then 534 Container.Last := Prev; 535 else 536 N (Next).Prev := Prev; 537 end if; 538 539 N (Node).Next := Pivot; 540 N (Node).Prev := N (Pivot).Prev; 541 542 N (Pivot).Prev := Node; 543 544 if N (Node).Prev = 0 then 545 Container.First := Node; 546 else 547 N (N (Node).Prev).Next := Node; 548 end if; 549 550 Node := Next; 551 end; 552 553 else 554 Node := N (Node).Next; 555 end if; 556 end loop; 557 end Partition; 558 559 ---------- 560 -- Sort -- 561 ---------- 562 563 procedure Sort (Front, Back : Count_Type) is 564 Pivot : constant Count_Type := 565 (if Front = 0 then Container.First else N (Front).Next); 566 begin 567 if Pivot /= Back then 568 Partition (Pivot, Back); 569 Sort (Front, Pivot); 570 Sort (Pivot, Back); 571 end if; 572 end Sort; 573 574 -- Start of processing for Sort 575 576 begin 577 if Container.Length <= 1 then 578 return; 579 end if; 580 581 pragma Assert (N (Container.First).Prev = 0); 582 pragma Assert (N (Container.Last).Next = 0); 583 584-- if Container.Busy > 0 then 585-- raise Program_Error; 586-- end if; 587 588 Sort (Front => 0, Back => 0); 589 590 pragma Assert (N (Container.First).Prev = 0); 591 pragma Assert (N (Container.Last).Next = 0); 592 end Sort; 593 594 end Generic_Sorting; 595 596 ----------------- 597 -- Has_Element -- 598 ----------------- 599 600 function Has_Element (Position : Cursor) return Boolean is 601 begin 602 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 603 return Position.Node /= 0; 604 end Has_Element; 605 606 ------------ 607 -- Insert -- 608 ------------ 609 610 procedure Insert 611 (Container : in out List; 612 Before : Cursor; 613 New_Item : Element_Type; 614 Position : out Cursor; 615 Count : Count_Type := 1) 616 is 617 First_Node : Count_Type; 618 New_Node : Count_Type; 619 620 begin 621 if Before.Container /= null then 622 if Before.Container /= Container'Unrestricted_Access then 623 raise Program_Error; 624 end if; 625 626 pragma Assert (Vet (Before), "bad cursor in Insert"); 627 end if; 628 629 if Count = 0 then 630 Position := Before; 631 return; 632 end if; 633 634 if Container.Length > Container.Capacity - Count then 635 raise Constraint_Error; 636 end if; 637 638-- if Container.Busy > 0 then 639-- raise Program_Error; 640-- end if; 641 642 Allocate (Container, New_Item, New_Node); 643 First_Node := New_Node; 644 Insert_Internal (Container, Before.Node, New_Node); 645 646 for Index in 2 .. Count loop 647 Allocate (Container, New_Item, New_Node); 648 Insert_Internal (Container, Before.Node, New_Node); 649 end loop; 650 651 Position := Cursor'(Container'Unrestricted_Access, First_Node); 652 end Insert; 653 654 procedure Insert 655 (Container : in out List; 656 Before : Cursor; 657 New_Item : Element_Type; 658 Count : Count_Type := 1) 659 is 660 Position : Cursor; 661 pragma Unreferenced (Position); 662 begin 663 Insert (Container, Before, New_Item, Position, Count); 664 end Insert; 665 666 procedure Insert 667 (Container : in out List; 668 Before : Cursor; 669 Position : out Cursor; 670 Count : Count_Type := 1) 671 is 672 New_Item : Element_Type; -- Do we need to reinit node ??? 673 pragma Warnings (Off, New_Item); 674 675 begin 676 Insert (Container, Before, New_Item, Position, Count); 677 end Insert; 678 679 --------------------- 680 -- Insert_Internal -- 681 --------------------- 682 683 procedure Insert_Internal 684 (Container : in out List'Class; 685 Before : Count_Type; 686 New_Node : Count_Type) 687 is 688 N : Node_Array renames Container.Nodes; 689 690 begin 691 if Container.Length = 0 then 692 pragma Assert (Before = 0); 693 pragma Assert (Container.First = 0); 694 pragma Assert (Container.Last = 0); 695 696 Container.First := New_Node; 697 Container.Last := New_Node; 698 699 N (Container.First).Prev := 0; 700 N (Container.Last).Next := 0; 701 702 elsif Before = 0 then 703 pragma Assert (N (Container.Last).Next = 0); 704 705 N (Container.Last).Next := New_Node; 706 N (New_Node).Prev := Container.Last; 707 708 Container.Last := New_Node; 709 N (Container.Last).Next := 0; 710 711 elsif Before = Container.First then 712 pragma Assert (N (Container.First).Prev = 0); 713 714 N (Container.First).Prev := New_Node; 715 N (New_Node).Next := Container.First; 716 717 Container.First := New_Node; 718 N (Container.First).Prev := 0; 719 720 else 721 pragma Assert (N (Container.First).Prev = 0); 722 pragma Assert (N (Container.Last).Next = 0); 723 724 N (New_Node).Next := Before; 725 N (New_Node).Prev := N (Before).Prev; 726 727 N (N (Before).Prev).Next := New_Node; 728 N (Before).Prev := New_Node; 729 end if; 730 731 Container.Length := Container.Length + 1; 732 end Insert_Internal; 733 734 -------------- 735 -- Is_Empty -- 736 -------------- 737 738 function Is_Empty (Container : List) return Boolean is 739 begin 740 return Container.Length = 0; 741 end Is_Empty; 742 743 ------------- 744 -- Iterate -- 745 ------------- 746 747 procedure Iterate 748 (Container : List; 749 Process : not null access procedure (Position : Cursor)) 750 is 751 C : List renames Container'Unrestricted_Access.all; 752 N : Node_Array renames C.Nodes; 753-- B : Natural renames C.Busy; 754 755 Node : Count_Type := Container.First; 756 757 Index : Count_Type := 0; 758 Index_Max : constant Count_Type := Container.Length; 759 760 begin 761 if Index_Max = 0 then 762 pragma Assert (Node = 0); 763 return; 764 end if; 765 766 loop 767 pragma Assert (Node /= 0); 768 769 Process (Cursor'(C'Unchecked_Access, Node)); 770 pragma Assert (Container.Length = Index_Max); 771 pragma Assert (N (Node).Prev /= -1); 772 773 Node := N (Node).Next; 774 Index := Index + 1; 775 776 if Index = Index_Max then 777 pragma Assert (Node = 0); 778 return; 779 end if; 780 end loop; 781 end Iterate; 782 783 ---------- 784 -- Last -- 785 ---------- 786 787 function Last (Container : List) return Cursor is 788 begin 789 if Container.Last = 0 then 790 return No_Element; 791 end if; 792 793 return Cursor'(Container'Unrestricted_Access, Container.Last); 794 end Last; 795 796 ------------------ 797 -- Last_Element -- 798 ------------------ 799 800 function Last_Element (Container : List) return Element_Type is 801 N : Node_Array renames Container.Nodes; 802 803 begin 804 if Container.Last = 0 then 805 raise Constraint_Error; 806 end if; 807 808 return N (Container.Last).Element; 809 end Last_Element; 810 811 ------------ 812 -- Length -- 813 ------------ 814 815 function Length (Container : List) return Count_Type is 816 begin 817 return Container.Length; 818 end Length; 819 820 ---------- 821 -- Next -- 822 ---------- 823 824 procedure Next (Position : in out Cursor) is 825 begin 826 Position := Next (Position); 827 end Next; 828 829 function Next (Position : Cursor) return Cursor is 830 begin 831 if Position.Node = 0 then 832 return No_Element; 833 end if; 834 835 pragma Assert (Vet (Position), "bad cursor in Next"); 836 837 declare 838 Nodes : Node_Array renames Position.Container.Nodes; 839 Node : constant Count_Type := Nodes (Position.Node).Next; 840 841 begin 842 if Node = 0 then 843 return No_Element; 844 end if; 845 846 return Cursor'(Position.Container, Node); 847 end; 848 end Next; 849 850 ------------- 851 -- Prepend -- 852 ------------- 853 854 procedure Prepend 855 (Container : in out List; 856 New_Item : Element_Type; 857 Count : Count_Type := 1) 858 is 859 begin 860 Insert (Container, First (Container), New_Item, Count); 861 end Prepend; 862 863 -------------- 864 -- Previous -- 865 -------------- 866 867 procedure Previous (Position : in out Cursor) is 868 begin 869 Position := Previous (Position); 870 end Previous; 871 872 function Previous (Position : Cursor) return Cursor is 873 begin 874 if Position.Node = 0 then 875 return No_Element; 876 end if; 877 878 pragma Assert (Vet (Position), "bad cursor in Previous"); 879 880 declare 881 Nodes : Node_Array renames Position.Container.Nodes; 882 Node : constant Count_Type := Nodes (Position.Node).Prev; 883 begin 884 if Node = 0 then 885 return No_Element; 886 end if; 887 888 return Cursor'(Position.Container, Node); 889 end; 890 end Previous; 891 892 ------------------- 893 -- Query_Element -- 894 ------------------- 895 896 procedure Query_Element 897 (Position : Cursor; 898 Process : not null access procedure (Element : Element_Type)) 899 is 900 begin 901 if Position.Node = 0 then 902 raise Constraint_Error; 903 end if; 904 905 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 906 907 declare 908 C : List renames Position.Container.all'Unrestricted_Access.all; 909 N : Node_Type renames C.Nodes (Position.Node); 910 911 begin 912 Process (N.Element); 913 pragma Assert (N.Prev >= 0); 914 end; 915 end Query_Element; 916 917 --------------------- 918 -- Replace_Element -- 919 --------------------- 920 921 procedure Replace_Element 922 (Container : in out List; 923 Position : Cursor; 924 New_Item : Element_Type) 925 is 926 begin 927 if Position.Container = null then 928 raise Constraint_Error; 929 end if; 930 931 if Position.Container /= Container'Unrestricted_Access then 932 raise Program_Error; 933 end if; 934 935-- if Container.Lock > 0 then 936-- raise Program_Error; 937-- end if; 938 939 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 940 941 declare 942 N : Node_Array renames Container.Nodes; 943 begin 944 N (Position.Node).Element := New_Item; 945 end; 946 end Replace_Element; 947 948 ---------------------- 949 -- Reverse_Elements -- 950 ---------------------- 951 952 procedure Reverse_Elements (Container : in out List) is 953 N : Node_Array renames Container.Nodes; 954 I : Count_Type := Container.First; 955 J : Count_Type := Container.Last; 956 957 procedure Swap (L, R : Count_Type); 958 959 ---------- 960 -- Swap -- 961 ---------- 962 963 procedure Swap (L, R : Count_Type) is 964 LN : constant Count_Type := N (L).Next; 965 LP : constant Count_Type := N (L).Prev; 966 967 RN : constant Count_Type := N (R).Next; 968 RP : constant Count_Type := N (R).Prev; 969 970 begin 971 if LP /= 0 then 972 N (LP).Next := R; 973 end if; 974 975 if RN /= 0 then 976 N (RN).Prev := L; 977 end if; 978 979 N (L).Next := RN; 980 N (R).Prev := LP; 981 982 if LN = R then 983 pragma Assert (RP = L); 984 985 N (L).Prev := R; 986 N (R).Next := L; 987 988 else 989 N (L).Prev := RP; 990 N (RP).Next := L; 991 992 N (R).Next := LN; 993 N (LN).Prev := R; 994 end if; 995 end Swap; 996 997 -- Start of processing for Reverse_Elements 998 999 begin 1000 if Container.Length <= 1 then 1001 return; 1002 end if; 1003 1004 pragma Assert (N (Container.First).Prev = 0); 1005 pragma Assert (N (Container.Last).Next = 0); 1006 1007-- if Container.Busy > 0 then 1008-- raise Program_Error; 1009-- end if; 1010 1011 Container.First := J; 1012 Container.Last := I; 1013 loop 1014 Swap (L => I, R => J); 1015 1016 J := N (J).Next; 1017 exit when I = J; 1018 1019 I := N (I).Prev; 1020 exit when I = J; 1021 1022 Swap (L => J, R => I); 1023 1024 I := N (I).Next; 1025 exit when I = J; 1026 1027 J := N (J).Prev; 1028 exit when I = J; 1029 end loop; 1030 1031 pragma Assert (N (Container.First).Prev = 0); 1032 pragma Assert (N (Container.Last).Next = 0); 1033 end Reverse_Elements; 1034 1035 ------------------ 1036 -- Reverse_Find -- 1037 ------------------ 1038 1039 function Reverse_Find 1040 (Container : List; 1041 Item : Element_Type; 1042 Position : Cursor := No_Element) return Cursor 1043 is 1044 N : Node_Array renames Container.Nodes; 1045 Node : Count_Type := Position.Node; 1046 1047 begin 1048 if Node = 0 then 1049 Node := Container.Last; 1050 1051 else 1052 if Position.Container /= Container'Unrestricted_Access then 1053 raise Program_Error; 1054 end if; 1055 1056 pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); 1057 end if; 1058 1059 while Node /= 0 loop 1060 if N (Node).Element = Item then 1061 return Cursor'(Container'Unrestricted_Access, Node); 1062 end if; 1063 1064 Node := N (Node).Prev; 1065 end loop; 1066 1067 return No_Element; 1068 end Reverse_Find; 1069 1070 --------------------- 1071 -- Reverse_Iterate -- 1072 --------------------- 1073 1074 procedure Reverse_Iterate 1075 (Container : List; 1076 Process : not null access procedure (Position : Cursor)) 1077 is 1078 C : List renames Container'Unrestricted_Access.all; 1079 N : Node_Array renames C.Nodes; 1080-- B : Natural renames C.Busy; 1081 1082 Node : Count_Type := Container.Last; 1083 1084 Index : Count_Type := 0; 1085 Index_Max : constant Count_Type := Container.Length; 1086 1087 begin 1088 if Index_Max = 0 then 1089 pragma Assert (Node = 0); 1090 return; 1091 end if; 1092 1093 loop 1094 pragma Assert (Node > 0); 1095 1096 Process (Cursor'(C'Unchecked_Access, Node)); 1097 pragma Assert (Container.Length = Index_Max); 1098 pragma Assert (N (Node).Prev /= -1); 1099 1100 Node := N (Node).Prev; 1101 Index := Index + 1; 1102 1103 if Index = Index_Max then 1104 pragma Assert (Node = 0); 1105 return; 1106 end if; 1107 end loop; 1108 end Reverse_Iterate; 1109 1110 ------------ 1111 -- Splice -- 1112 ------------ 1113 1114 procedure Splice 1115 (Container : in out List; 1116 Before : Cursor; 1117 Position : in out Cursor) 1118 is 1119 N : Node_Array renames Container.Nodes; 1120 1121 begin 1122 if Before.Container /= null then 1123 if Before.Container /= Container'Unrestricted_Access then 1124 raise Program_Error; 1125 end if; 1126 1127 pragma Assert (Vet (Before), "bad Before cursor in Splice"); 1128 end if; 1129 1130 if Position.Node = 0 then 1131 raise Constraint_Error; 1132 end if; 1133 1134 if Position.Container /= Container'Unrestricted_Access then 1135 raise Program_Error; 1136 end if; 1137 1138 pragma Assert (Vet (Position), "bad Position cursor in Splice"); 1139 1140 if Position.Node = Before.Node 1141 or else N (Position.Node).Next = Before.Node 1142 then 1143 return; 1144 end if; 1145 1146 pragma Assert (Container.Length >= 2); 1147 1148-- if Container.Busy > 0 then 1149-- raise Program_Error; 1150-- end if; 1151 1152 if Before.Node = 0 then 1153 pragma Assert (Position.Node /= Container.Last); 1154 1155 if Position.Node = Container.First then 1156 Container.First := N (Position.Node).Next; 1157 N (Container.First).Prev := 0; 1158 1159 else 1160 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1161 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1162 end if; 1163 1164 N (Container.Last).Next := Position.Node; 1165 N (Position.Node).Prev := Container.Last; 1166 1167 Container.Last := Position.Node; 1168 N (Container.Last).Next := 0; 1169 1170 return; 1171 end if; 1172 1173 if Before.Node = Container.First then 1174 pragma Assert (Position.Node /= Container.First); 1175 1176 if Position.Node = Container.Last then 1177 Container.Last := N (Position.Node).Prev; 1178 N (Container.Last).Next := 0; 1179 1180 else 1181 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1182 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1183 end if; 1184 1185 N (Container.First).Prev := Position.Node; 1186 N (Position.Node).Next := Container.First; 1187 1188 Container.First := Position.Node; 1189 N (Container.First).Prev := 0; 1190 1191 return; 1192 end if; 1193 1194 if Position.Node = Container.First then 1195 Container.First := N (Position.Node).Next; 1196 N (Container.First).Prev := 0; 1197 1198 elsif Position.Node = Container.Last then 1199 Container.Last := N (Position.Node).Prev; 1200 N (Container.Last).Next := 0; 1201 1202 else 1203 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1204 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1205 end if; 1206 1207 N (N (Before.Node).Prev).Next := Position.Node; 1208 N (Position.Node).Prev := N (Before.Node).Prev; 1209 1210 N (Before.Node).Prev := Position.Node; 1211 N (Position.Node).Next := Before.Node; 1212 1213 pragma Assert (N (Container.First).Prev = 0); 1214 pragma Assert (N (Container.Last).Next = 0); 1215 end Splice; 1216 1217 ---------- 1218 -- Swap -- 1219 ---------- 1220 1221 procedure Swap 1222 (Container : in out List; 1223 I, J : Cursor) 1224 is 1225 begin 1226 if I.Node = 0 1227 or else J.Node = 0 1228 then 1229 raise Constraint_Error; 1230 end if; 1231 1232 if I.Container /= Container'Unrestricted_Access 1233 or else J.Container /= Container'Unrestricted_Access 1234 then 1235 raise Program_Error; 1236 end if; 1237 1238 if I.Node = J.Node then 1239 return; 1240 end if; 1241 1242-- if Container.Lock > 0 then 1243-- raise Program_Error; 1244-- end if; 1245 1246 pragma Assert (Vet (I), "bad I cursor in Swap"); 1247 pragma Assert (Vet (J), "bad J cursor in Swap"); 1248 1249 declare 1250 N : Node_Array renames Container.Nodes; 1251 1252 EI : Element_Type renames N (I.Node).Element; 1253 EJ : Element_Type renames N (J.Node).Element; 1254 1255 EI_Copy : constant Element_Type := EI; 1256 1257 begin 1258 EI := EJ; 1259 EJ := EI_Copy; 1260 end; 1261 end Swap; 1262 1263 ---------------- 1264 -- Swap_Links -- 1265 ---------------- 1266 1267 procedure Swap_Links 1268 (Container : in out List; 1269 I, J : Cursor) 1270 is 1271 begin 1272 if I.Node = 0 1273 or else J.Node = 0 1274 then 1275 raise Constraint_Error; 1276 end if; 1277 1278 if I.Container /= Container'Unrestricted_Access 1279 or else I.Container /= J.Container 1280 then 1281 raise Program_Error; 1282 end if; 1283 1284 if I.Node = J.Node then 1285 return; 1286 end if; 1287 1288-- if Container.Busy > 0 then 1289-- raise Program_Error; 1290-- end if; 1291 1292 pragma Assert (Vet (I), "bad I cursor in Swap_Links"); 1293 pragma Assert (Vet (J), "bad J cursor in Swap_Links"); 1294 1295 declare 1296 I_Next : constant Cursor := Next (I); 1297 1298 J_Copy : Cursor := J; 1299 pragma Warnings (Off, J_Copy); 1300 1301 begin 1302 if I_Next = J then 1303 Splice (Container, Before => I, Position => J_Copy); 1304 1305 else 1306 declare 1307 J_Next : constant Cursor := Next (J); 1308 1309 I_Copy : Cursor := I; 1310 pragma Warnings (Off, I_Copy); 1311 1312 begin 1313 if J_Next = I then 1314 Splice (Container, Before => J, Position => I_Copy); 1315 1316 else 1317 pragma Assert (Container.Length >= 3); 1318 1319 Splice (Container, Before => I_Next, Position => J_Copy); 1320 Splice (Container, Before => J_Next, Position => I_Copy); 1321 end if; 1322 end; 1323 end if; 1324 end; 1325 end Swap_Links; 1326 1327 -------------------- 1328 -- Update_Element -- 1329 -------------------- 1330 1331 procedure Update_Element 1332 (Container : in out List; 1333 Position : Cursor; 1334 Process : not null access procedure (Element : in out Element_Type)) 1335 is 1336 begin 1337 if Position.Node = 0 then 1338 raise Constraint_Error; 1339 end if; 1340 1341 if Position.Container /= Container'Unrestricted_Access then 1342 raise Program_Error; 1343 end if; 1344 1345 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 1346 1347 declare 1348 N : Node_Type renames Container.Nodes (Position.Node); 1349 1350 begin 1351 Process (N.Element); 1352 pragma Assert (N.Prev >= 0); 1353 end; 1354 end Update_Element; 1355 1356 --------- 1357 -- Vet -- 1358 --------- 1359 1360 function Vet (Position : Cursor) return Boolean is 1361 begin 1362 if Position.Node = 0 then 1363 return Position.Container = null; 1364 end if; 1365 1366 if Position.Container = null then 1367 return False; 1368 end if; 1369 1370 declare 1371 L : List renames Position.Container.all; 1372 N : Node_Array renames L.Nodes; 1373 1374 begin 1375 if L.Length = 0 then 1376 return False; 1377 end if; 1378 1379 if L.First = 0 then 1380 return False; 1381 end if; 1382 1383 if L.Last = 0 then 1384 return False; 1385 end if; 1386 1387 if Position.Node > L.Capacity then 1388 return False; 1389 end if; 1390 1391 if N (Position.Node).Prev < 0 1392 or else N (Position.Node).Prev > L.Capacity 1393 then 1394 return False; 1395 end if; 1396 1397 if N (Position.Node).Next > L.Capacity then 1398 return False; 1399 end if; 1400 1401 if N (L.First).Prev /= 0 then 1402 return False; 1403 end if; 1404 1405 if N (L.Last).Next /= 0 then 1406 return False; 1407 end if; 1408 1409 if N (Position.Node).Prev = 0 1410 and then Position.Node /= L.First 1411 then 1412 return False; 1413 end if; 1414 1415 if N (Position.Node).Next = 0 1416 and then Position.Node /= L.Last 1417 then 1418 return False; 1419 end if; 1420 1421 if L.Length = 1 then 1422 return L.First = L.Last; 1423 end if; 1424 1425 if L.First = L.Last then 1426 return False; 1427 end if; 1428 1429 if N (L.First).Next = 0 then 1430 return False; 1431 end if; 1432 1433 if N (L.Last).Prev = 0 then 1434 return False; 1435 end if; 1436 1437 if N (N (L.First).Next).Prev /= L.First then 1438 return False; 1439 end if; 1440 1441 if N (N (L.Last).Prev).Next /= L.Last then 1442 return False; 1443 end if; 1444 1445 if L.Length = 2 then 1446 if N (L.First).Next /= L.Last then 1447 return False; 1448 end if; 1449 1450 if N (L.Last).Prev /= L.First then 1451 return False; 1452 end if; 1453 1454 return True; 1455 end if; 1456 1457 if N (L.First).Next = L.Last then 1458 return False; 1459 end if; 1460 1461 if N (L.Last).Prev = L.First then 1462 return False; 1463 end if; 1464 1465 if Position.Node = L.First then 1466 return True; 1467 end if; 1468 1469 if Position.Node = L.Last then 1470 return True; 1471 end if; 1472 1473 if N (Position.Node).Next = 0 then 1474 return False; 1475 end if; 1476 1477 if N (Position.Node).Prev = 0 then 1478 return False; 1479 end if; 1480 1481 if N (N (Position.Node).Next).Prev /= Position.Node then 1482 return False; 1483 end if; 1484 1485 if N (N (Position.Node).Prev).Next /= Position.Node then 1486 return False; 1487 end if; 1488 1489 if L.Length = 3 then 1490 if N (L.First).Next /= Position.Node then 1491 return False; 1492 end if; 1493 1494 if N (L.Last).Prev /= Position.Node then 1495 return False; 1496 end if; 1497 end if; 1498 1499 return True; 1500 end; 1501 end Vet; 1502 1503end Ada.Containers.Restricted_Doubly_Linked_Lists; 1504