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-2012, 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 J : Count_Type; 618 619 begin 620 if Before.Container /= null then 621 if Before.Container /= Container'Unrestricted_Access then 622 raise Program_Error; 623 end if; 624 625 pragma Assert (Vet (Before), "bad cursor in Insert"); 626 end if; 627 628 if Count = 0 then 629 Position := Before; 630 return; 631 end if; 632 633 if Container.Length > Container.Capacity - Count then 634 raise Constraint_Error; 635 end if; 636 637-- if Container.Busy > 0 then 638-- raise Program_Error; 639-- end if; 640 641 Allocate (Container, New_Item, New_Node => J); 642 Insert_Internal (Container, Before.Node, New_Node => J); 643 Position := Cursor'(Container'Unrestricted_Access, Node => J); 644 645 for Index in 2 .. Count loop 646 Allocate (Container, New_Item, New_Node => J); 647 Insert_Internal (Container, Before.Node, New_Node => J); 648 end loop; 649 end Insert; 650 651 procedure Insert 652 (Container : in out List; 653 Before : Cursor; 654 New_Item : Element_Type; 655 Count : Count_Type := 1) 656 is 657 Position : Cursor; 658 pragma Unreferenced (Position); 659 begin 660 Insert (Container, Before, New_Item, Position, Count); 661 end Insert; 662 663 procedure Insert 664 (Container : in out List; 665 Before : Cursor; 666 Position : out Cursor; 667 Count : Count_Type := 1) 668 is 669 New_Item : Element_Type; -- Do we need to reinit node ??? 670 pragma Warnings (Off, New_Item); 671 672 begin 673 Insert (Container, Before, New_Item, Position, Count); 674 end Insert; 675 676 --------------------- 677 -- Insert_Internal -- 678 --------------------- 679 680 procedure Insert_Internal 681 (Container : in out List'Class; 682 Before : Count_Type; 683 New_Node : Count_Type) 684 is 685 N : Node_Array renames Container.Nodes; 686 687 begin 688 if Container.Length = 0 then 689 pragma Assert (Before = 0); 690 pragma Assert (Container.First = 0); 691 pragma Assert (Container.Last = 0); 692 693 Container.First := New_Node; 694 Container.Last := New_Node; 695 696 N (Container.First).Prev := 0; 697 N (Container.Last).Next := 0; 698 699 elsif Before = 0 then 700 pragma Assert (N (Container.Last).Next = 0); 701 702 N (Container.Last).Next := New_Node; 703 N (New_Node).Prev := Container.Last; 704 705 Container.Last := New_Node; 706 N (Container.Last).Next := 0; 707 708 elsif Before = Container.First then 709 pragma Assert (N (Container.First).Prev = 0); 710 711 N (Container.First).Prev := New_Node; 712 N (New_Node).Next := Container.First; 713 714 Container.First := New_Node; 715 N (Container.First).Prev := 0; 716 717 else 718 pragma Assert (N (Container.First).Prev = 0); 719 pragma Assert (N (Container.Last).Next = 0); 720 721 N (New_Node).Next := Before; 722 N (New_Node).Prev := N (Before).Prev; 723 724 N (N (Before).Prev).Next := New_Node; 725 N (Before).Prev := New_Node; 726 end if; 727 728 Container.Length := Container.Length + 1; 729 end Insert_Internal; 730 731 -------------- 732 -- Is_Empty -- 733 -------------- 734 735 function Is_Empty (Container : List) return Boolean is 736 begin 737 return Container.Length = 0; 738 end Is_Empty; 739 740 ------------- 741 -- Iterate -- 742 ------------- 743 744 procedure Iterate 745 (Container : List; 746 Process : not null access procedure (Position : Cursor)) 747 is 748 C : List renames Container'Unrestricted_Access.all; 749 N : Node_Array renames C.Nodes; 750-- B : Natural renames C.Busy; 751 752 Node : Count_Type := Container.First; 753 754 Index : Count_Type := 0; 755 Index_Max : constant Count_Type := Container.Length; 756 757 begin 758 if Index_Max = 0 then 759 pragma Assert (Node = 0); 760 return; 761 end if; 762 763 loop 764 pragma Assert (Node /= 0); 765 766 Process (Cursor'(C'Unchecked_Access, Node)); 767 pragma Assert (Container.Length = Index_Max); 768 pragma Assert (N (Node).Prev /= -1); 769 770 Node := N (Node).Next; 771 Index := Index + 1; 772 773 if Index = Index_Max then 774 pragma Assert (Node = 0); 775 return; 776 end if; 777 end loop; 778 end Iterate; 779 780 ---------- 781 -- Last -- 782 ---------- 783 784 function Last (Container : List) return Cursor is 785 begin 786 if Container.Last = 0 then 787 return No_Element; 788 end if; 789 790 return Cursor'(Container'Unrestricted_Access, Container.Last); 791 end Last; 792 793 ------------------ 794 -- Last_Element -- 795 ------------------ 796 797 function Last_Element (Container : List) return Element_Type is 798 N : Node_Array renames Container.Nodes; 799 800 begin 801 if Container.Last = 0 then 802 raise Constraint_Error; 803 end if; 804 805 return N (Container.Last).Element; 806 end Last_Element; 807 808 ------------ 809 -- Length -- 810 ------------ 811 812 function Length (Container : List) return Count_Type is 813 begin 814 return Container.Length; 815 end Length; 816 817 ---------- 818 -- Next -- 819 ---------- 820 821 procedure Next (Position : in out Cursor) is 822 begin 823 Position := Next (Position); 824 end Next; 825 826 function Next (Position : Cursor) return Cursor is 827 begin 828 if Position.Node = 0 then 829 return No_Element; 830 end if; 831 832 pragma Assert (Vet (Position), "bad cursor in Next"); 833 834 declare 835 Nodes : Node_Array renames Position.Container.Nodes; 836 Node : constant Count_Type := Nodes (Position.Node).Next; 837 838 begin 839 if Node = 0 then 840 return No_Element; 841 end if; 842 843 return Cursor'(Position.Container, Node); 844 end; 845 end Next; 846 847 ------------- 848 -- Prepend -- 849 ------------- 850 851 procedure Prepend 852 (Container : in out List; 853 New_Item : Element_Type; 854 Count : Count_Type := 1) 855 is 856 begin 857 Insert (Container, First (Container), New_Item, Count); 858 end Prepend; 859 860 -------------- 861 -- Previous -- 862 -------------- 863 864 procedure Previous (Position : in out Cursor) is 865 begin 866 Position := Previous (Position); 867 end Previous; 868 869 function Previous (Position : Cursor) return Cursor is 870 begin 871 if Position.Node = 0 then 872 return No_Element; 873 end if; 874 875 pragma Assert (Vet (Position), "bad cursor in Previous"); 876 877 declare 878 Nodes : Node_Array renames Position.Container.Nodes; 879 Node : constant Count_Type := Nodes (Position.Node).Prev; 880 begin 881 if Node = 0 then 882 return No_Element; 883 end if; 884 885 return Cursor'(Position.Container, Node); 886 end; 887 end Previous; 888 889 ------------------- 890 -- Query_Element -- 891 ------------------- 892 893 procedure Query_Element 894 (Position : Cursor; 895 Process : not null access procedure (Element : Element_Type)) 896 is 897 begin 898 if Position.Node = 0 then 899 raise Constraint_Error; 900 end if; 901 902 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 903 904 declare 905 C : List renames Position.Container.all'Unrestricted_Access.all; 906 N : Node_Type renames C.Nodes (Position.Node); 907 908 begin 909 Process (N.Element); 910 pragma Assert (N.Prev >= 0); 911 end; 912 end Query_Element; 913 914 --------------------- 915 -- Replace_Element -- 916 --------------------- 917 918 procedure Replace_Element 919 (Container : in out List; 920 Position : Cursor; 921 New_Item : Element_Type) 922 is 923 begin 924 if Position.Container = null then 925 raise Constraint_Error; 926 end if; 927 928 if Position.Container /= Container'Unrestricted_Access then 929 raise Program_Error; 930 end if; 931 932-- if Container.Lock > 0 then 933-- raise Program_Error; 934-- end if; 935 936 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 937 938 declare 939 N : Node_Array renames Container.Nodes; 940 begin 941 N (Position.Node).Element := New_Item; 942 end; 943 end Replace_Element; 944 945 ---------------------- 946 -- Reverse_Elements -- 947 ---------------------- 948 949 procedure Reverse_Elements (Container : in out List) is 950 N : Node_Array renames Container.Nodes; 951 I : Count_Type := Container.First; 952 J : Count_Type := Container.Last; 953 954 procedure Swap (L, R : Count_Type); 955 956 ---------- 957 -- Swap -- 958 ---------- 959 960 procedure Swap (L, R : Count_Type) is 961 LN : constant Count_Type := N (L).Next; 962 LP : constant Count_Type := N (L).Prev; 963 964 RN : constant Count_Type := N (R).Next; 965 RP : constant Count_Type := N (R).Prev; 966 967 begin 968 if LP /= 0 then 969 N (LP).Next := R; 970 end if; 971 972 if RN /= 0 then 973 N (RN).Prev := L; 974 end if; 975 976 N (L).Next := RN; 977 N (R).Prev := LP; 978 979 if LN = R then 980 pragma Assert (RP = L); 981 982 N (L).Prev := R; 983 N (R).Next := L; 984 985 else 986 N (L).Prev := RP; 987 N (RP).Next := L; 988 989 N (R).Next := LN; 990 N (LN).Prev := R; 991 end if; 992 end Swap; 993 994 -- Start of processing for Reverse_Elements 995 996 begin 997 if Container.Length <= 1 then 998 return; 999 end if; 1000 1001 pragma Assert (N (Container.First).Prev = 0); 1002 pragma Assert (N (Container.Last).Next = 0); 1003 1004-- if Container.Busy > 0 then 1005-- raise Program_Error; 1006-- end if; 1007 1008 Container.First := J; 1009 Container.Last := I; 1010 loop 1011 Swap (L => I, R => J); 1012 1013 J := N (J).Next; 1014 exit when I = J; 1015 1016 I := N (I).Prev; 1017 exit when I = J; 1018 1019 Swap (L => J, R => I); 1020 1021 I := N (I).Next; 1022 exit when I = J; 1023 1024 J := N (J).Prev; 1025 exit when I = J; 1026 end loop; 1027 1028 pragma Assert (N (Container.First).Prev = 0); 1029 pragma Assert (N (Container.Last).Next = 0); 1030 end Reverse_Elements; 1031 1032 ------------------ 1033 -- Reverse_Find -- 1034 ------------------ 1035 1036 function Reverse_Find 1037 (Container : List; 1038 Item : Element_Type; 1039 Position : Cursor := No_Element) return Cursor 1040 is 1041 N : Node_Array renames Container.Nodes; 1042 Node : Count_Type := Position.Node; 1043 1044 begin 1045 if Node = 0 then 1046 Node := Container.Last; 1047 1048 else 1049 if Position.Container /= Container'Unrestricted_Access then 1050 raise Program_Error; 1051 end if; 1052 1053 pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); 1054 end if; 1055 1056 while Node /= 0 loop 1057 if N (Node).Element = Item then 1058 return Cursor'(Container'Unrestricted_Access, Node); 1059 end if; 1060 1061 Node := N (Node).Prev; 1062 end loop; 1063 1064 return No_Element; 1065 end Reverse_Find; 1066 1067 --------------------- 1068 -- Reverse_Iterate -- 1069 --------------------- 1070 1071 procedure Reverse_Iterate 1072 (Container : List; 1073 Process : not null access procedure (Position : Cursor)) 1074 is 1075 C : List renames Container'Unrestricted_Access.all; 1076 N : Node_Array renames C.Nodes; 1077-- B : Natural renames C.Busy; 1078 1079 Node : Count_Type := Container.Last; 1080 1081 Index : Count_Type := 0; 1082 Index_Max : constant Count_Type := Container.Length; 1083 1084 begin 1085 if Index_Max = 0 then 1086 pragma Assert (Node = 0); 1087 return; 1088 end if; 1089 1090 loop 1091 pragma Assert (Node > 0); 1092 1093 Process (Cursor'(C'Unchecked_Access, Node)); 1094 pragma Assert (Container.Length = Index_Max); 1095 pragma Assert (N (Node).Prev /= -1); 1096 1097 Node := N (Node).Prev; 1098 Index := Index + 1; 1099 1100 if Index = Index_Max then 1101 pragma Assert (Node = 0); 1102 return; 1103 end if; 1104 end loop; 1105 end Reverse_Iterate; 1106 1107 ------------ 1108 -- Splice -- 1109 ------------ 1110 1111 procedure Splice 1112 (Container : in out List; 1113 Before : Cursor; 1114 Position : in out Cursor) 1115 is 1116 N : Node_Array renames Container.Nodes; 1117 1118 begin 1119 if Before.Container /= null then 1120 if Before.Container /= Container'Unrestricted_Access then 1121 raise Program_Error; 1122 end if; 1123 1124 pragma Assert (Vet (Before), "bad Before cursor in Splice"); 1125 end if; 1126 1127 if Position.Node = 0 then 1128 raise Constraint_Error; 1129 end if; 1130 1131 if Position.Container /= Container'Unrestricted_Access then 1132 raise Program_Error; 1133 end if; 1134 1135 pragma Assert (Vet (Position), "bad Position cursor in Splice"); 1136 1137 if Position.Node = Before.Node 1138 or else N (Position.Node).Next = Before.Node 1139 then 1140 return; 1141 end if; 1142 1143 pragma Assert (Container.Length >= 2); 1144 1145-- if Container.Busy > 0 then 1146-- raise Program_Error; 1147-- end if; 1148 1149 if Before.Node = 0 then 1150 pragma Assert (Position.Node /= Container.Last); 1151 1152 if Position.Node = Container.First then 1153 Container.First := N (Position.Node).Next; 1154 N (Container.First).Prev := 0; 1155 1156 else 1157 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1158 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1159 end if; 1160 1161 N (Container.Last).Next := Position.Node; 1162 N (Position.Node).Prev := Container.Last; 1163 1164 Container.Last := Position.Node; 1165 N (Container.Last).Next := 0; 1166 1167 return; 1168 end if; 1169 1170 if Before.Node = Container.First then 1171 pragma Assert (Position.Node /= Container.First); 1172 1173 if Position.Node = Container.Last then 1174 Container.Last := N (Position.Node).Prev; 1175 N (Container.Last).Next := 0; 1176 1177 else 1178 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1179 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1180 end if; 1181 1182 N (Container.First).Prev := Position.Node; 1183 N (Position.Node).Next := Container.First; 1184 1185 Container.First := Position.Node; 1186 N (Container.First).Prev := 0; 1187 1188 return; 1189 end if; 1190 1191 if Position.Node = Container.First then 1192 Container.First := N (Position.Node).Next; 1193 N (Container.First).Prev := 0; 1194 1195 elsif Position.Node = Container.Last then 1196 Container.Last := N (Position.Node).Prev; 1197 N (Container.Last).Next := 0; 1198 1199 else 1200 N (N (Position.Node).Prev).Next := N (Position.Node).Next; 1201 N (N (Position.Node).Next).Prev := N (Position.Node).Prev; 1202 end if; 1203 1204 N (N (Before.Node).Prev).Next := Position.Node; 1205 N (Position.Node).Prev := N (Before.Node).Prev; 1206 1207 N (Before.Node).Prev := Position.Node; 1208 N (Position.Node).Next := Before.Node; 1209 1210 pragma Assert (N (Container.First).Prev = 0); 1211 pragma Assert (N (Container.Last).Next = 0); 1212 end Splice; 1213 1214 ---------- 1215 -- Swap -- 1216 ---------- 1217 1218 procedure Swap 1219 (Container : in out List; 1220 I, J : Cursor) 1221 is 1222 begin 1223 if I.Node = 0 1224 or else J.Node = 0 1225 then 1226 raise Constraint_Error; 1227 end if; 1228 1229 if I.Container /= Container'Unrestricted_Access 1230 or else J.Container /= Container'Unrestricted_Access 1231 then 1232 raise Program_Error; 1233 end if; 1234 1235 if I.Node = J.Node then 1236 return; 1237 end if; 1238 1239-- if Container.Lock > 0 then 1240-- raise Program_Error; 1241-- end if; 1242 1243 pragma Assert (Vet (I), "bad I cursor in Swap"); 1244 pragma Assert (Vet (J), "bad J cursor in Swap"); 1245 1246 declare 1247 N : Node_Array renames Container.Nodes; 1248 1249 EI : Element_Type renames N (I.Node).Element; 1250 EJ : Element_Type renames N (J.Node).Element; 1251 1252 EI_Copy : constant Element_Type := EI; 1253 1254 begin 1255 EI := EJ; 1256 EJ := EI_Copy; 1257 end; 1258 end Swap; 1259 1260 ---------------- 1261 -- Swap_Links -- 1262 ---------------- 1263 1264 procedure Swap_Links 1265 (Container : in out List; 1266 I, J : Cursor) 1267 is 1268 begin 1269 if I.Node = 0 1270 or else J.Node = 0 1271 then 1272 raise Constraint_Error; 1273 end if; 1274 1275 if I.Container /= Container'Unrestricted_Access 1276 or else I.Container /= J.Container 1277 then 1278 raise Program_Error; 1279 end if; 1280 1281 if I.Node = J.Node then 1282 return; 1283 end if; 1284 1285-- if Container.Busy > 0 then 1286-- raise Program_Error; 1287-- end if; 1288 1289 pragma Assert (Vet (I), "bad I cursor in Swap_Links"); 1290 pragma Assert (Vet (J), "bad J cursor in Swap_Links"); 1291 1292 declare 1293 I_Next : constant Cursor := Next (I); 1294 1295 J_Copy : Cursor := J; 1296 pragma Warnings (Off, J_Copy); 1297 1298 begin 1299 if I_Next = J then 1300 Splice (Container, Before => I, Position => J_Copy); 1301 1302 else 1303 declare 1304 J_Next : constant Cursor := Next (J); 1305 1306 I_Copy : Cursor := I; 1307 pragma Warnings (Off, I_Copy); 1308 1309 begin 1310 if J_Next = I then 1311 Splice (Container, Before => J, Position => I_Copy); 1312 1313 else 1314 pragma Assert (Container.Length >= 3); 1315 1316 Splice (Container, Before => I_Next, Position => J_Copy); 1317 Splice (Container, Before => J_Next, Position => I_Copy); 1318 end if; 1319 end; 1320 end if; 1321 end; 1322 end Swap_Links; 1323 1324 -------------------- 1325 -- Update_Element -- 1326 -------------------- 1327 1328 procedure Update_Element 1329 (Container : in out List; 1330 Position : Cursor; 1331 Process : not null access procedure (Element : in out Element_Type)) 1332 is 1333 begin 1334 if Position.Node = 0 then 1335 raise Constraint_Error; 1336 end if; 1337 1338 if Position.Container /= Container'Unrestricted_Access then 1339 raise Program_Error; 1340 end if; 1341 1342 pragma Assert (Vet (Position), "bad cursor in Update_Element"); 1343 1344 declare 1345 N : Node_Type renames Container.Nodes (Position.Node); 1346 1347 begin 1348 Process (N.Element); 1349 pragma Assert (N.Prev >= 0); 1350 end; 1351 end Update_Element; 1352 1353 --------- 1354 -- Vet -- 1355 --------- 1356 1357 function Vet (Position : Cursor) return Boolean is 1358 begin 1359 if Position.Node = 0 then 1360 return Position.Container = null; 1361 end if; 1362 1363 if Position.Container = null then 1364 return False; 1365 end if; 1366 1367 declare 1368 L : List renames Position.Container.all; 1369 N : Node_Array renames L.Nodes; 1370 1371 begin 1372 if L.Length = 0 then 1373 return False; 1374 end if; 1375 1376 if L.First = 0 then 1377 return False; 1378 end if; 1379 1380 if L.Last = 0 then 1381 return False; 1382 end if; 1383 1384 if Position.Node > L.Capacity then 1385 return False; 1386 end if; 1387 1388 if N (Position.Node).Prev < 0 1389 or else N (Position.Node).Prev > L.Capacity 1390 then 1391 return False; 1392 end if; 1393 1394 if N (Position.Node).Next > L.Capacity then 1395 return False; 1396 end if; 1397 1398 if N (L.First).Prev /= 0 then 1399 return False; 1400 end if; 1401 1402 if N (L.Last).Next /= 0 then 1403 return False; 1404 end if; 1405 1406 if N (Position.Node).Prev = 0 1407 and then Position.Node /= L.First 1408 then 1409 return False; 1410 end if; 1411 1412 if N (Position.Node).Next = 0 1413 and then Position.Node /= L.Last 1414 then 1415 return False; 1416 end if; 1417 1418 if L.Length = 1 then 1419 return L.First = L.Last; 1420 end if; 1421 1422 if L.First = L.Last then 1423 return False; 1424 end if; 1425 1426 if N (L.First).Next = 0 then 1427 return False; 1428 end if; 1429 1430 if N (L.Last).Prev = 0 then 1431 return False; 1432 end if; 1433 1434 if N (N (L.First).Next).Prev /= L.First then 1435 return False; 1436 end if; 1437 1438 if N (N (L.Last).Prev).Next /= L.Last then 1439 return False; 1440 end if; 1441 1442 if L.Length = 2 then 1443 if N (L.First).Next /= L.Last then 1444 return False; 1445 end if; 1446 1447 if N (L.Last).Prev /= L.First then 1448 return False; 1449 end if; 1450 1451 return True; 1452 end if; 1453 1454 if N (L.First).Next = L.Last then 1455 return False; 1456 end if; 1457 1458 if N (L.Last).Prev = L.First then 1459 return False; 1460 end if; 1461 1462 if Position.Node = L.First then 1463 return True; 1464 end if; 1465 1466 if Position.Node = L.Last then 1467 return True; 1468 end if; 1469 1470 if N (Position.Node).Next = 0 then 1471 return False; 1472 end if; 1473 1474 if N (Position.Node).Prev = 0 then 1475 return False; 1476 end if; 1477 1478 if N (N (Position.Node).Next).Prev /= Position.Node then 1479 return False; 1480 end if; 1481 1482 if N (N (Position.Node).Prev).Next /= Position.Node then 1483 return False; 1484 end if; 1485 1486 if L.Length = 3 then 1487 if N (L.First).Next /= Position.Node then 1488 return False; 1489 end if; 1490 1491 if N (L.Last).Prev /= Position.Node then 1492 return False; 1493 end if; 1494 end if; 1495 1496 return True; 1497 end; 1498 end Vet; 1499 1500end Ada.Containers.Restricted_Doubly_Linked_Lists; 1501