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