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