gcc/ada/a-cfdlli.adb

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