gcc/ada/libgnat/g-lists.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                            G N A T . L I S T S                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2018-2019, 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Unchecked_Deallocation;
  33
  34 package body GNAT.Lists is
  35
  36    package body Doubly_Linked_Lists is
  37       procedure Delete_Node
  38         (L   : Doubly_Linked_List;
  39          Nod : Node_Ptr);
  40       pragma Inline (Delete_Node);
  41       --  Detach and delete node Nod from list L
  42
  43       procedure Ensure_Circular (Head : Node_Ptr);
  44       pragma Inline (Ensure_Circular);
  45       --  Ensure that dummy head Head is circular with respect to itself
  46
  47       procedure Ensure_Created (L : Doubly_Linked_List);
  48       pragma Inline (Ensure_Created);
  49       --  Verify that list L is created. Raise Not_Created if this is not the
  50       --  case.
  51
  52       procedure Ensure_Full (L : Doubly_Linked_List);
  53       pragma Inline (Ensure_Full);
  54       --  Verify that list L contains at least one element. Raise List_Empty if
  55       --  this is not the case.
  56
  57       procedure Ensure_Unlocked (L : Doubly_Linked_List);
  58       pragma Inline (Ensure_Unlocked);
  59       --  Verify that list L is unlocked. Raise Iterated if this is not the
  60       --  case.
  61
  62       function Find_Node
  63         (Head : Node_Ptr;
  64          Elem : Element_Type) return Node_Ptr;
  65       pragma Inline (Find_Node);
  66       --  Travers a list indicated by dummy head Head to determine whethe there
  67       --  exists a node with element Elem. If such a node exists, return it,
  68       --  otherwise return null;
  69
  70       procedure Free is
  71         new Ada.Unchecked_Deallocation
  72               (Doubly_Linked_List_Attributes, Doubly_Linked_List);
  73
  74       procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr);
  75
  76       procedure Insert_Between
  77         (L     : Doubly_Linked_List;
  78          Elem  : Element_Type;
  79          Left  : Node_Ptr;
  80          Right : Node_Ptr);
  81       pragma Inline (Insert_Between);
  82       --  Insert element Elem between nodes Left and Right of list L
  83
  84       function Is_Valid (Iter : Iterator) return Boolean;
  85       pragma Inline (Is_Valid);
  86       --  Determine whether iterator Iter refers to a valid element
  87
  88       function Is_Valid
  89         (Nod  : Node_Ptr;
  90          Head : Node_Ptr) return Boolean;
  91       pragma Inline (Is_Valid);
  92       --  Determine whether node Nod is non-null and does not refer to dummy
  93       --  head Head, thus making it valid.
  94
  95       procedure Lock (L : Doubly_Linked_List);
  96       pragma Inline (Lock);
  97       --  Lock all mutation functionality of list L
  98
  99       function Present (Nod : Node_Ptr) return Boolean;
 100       pragma Inline (Present);
 101       --  Determine whether node Nod exists
 102
 103       procedure Unlock (L : Doubly_Linked_List);
 104       pragma Inline (Unlock);
 105       --  Unlock all mutation functionality of list L
 106
 107       ------------
 108       -- Append --
 109       ------------
 110
 111       procedure Append
 112         (L    : Doubly_Linked_List;
 113          Elem : Element_Type)
 114       is
 115          Head : Node_Ptr;
 116
 117       begin
 118          Ensure_Created  (L);
 119          Ensure_Unlocked (L);
 120
 121          --  Ensure that the dummy head of an empty list is circular with
 122          --  respect to itself.
 123
 124          Head := L.Nodes'Access;
 125          Ensure_Circular (Head);
 126
 127          --  Append the node by inserting it between the last node and the
 128          --  dummy head.
 129
 130          Insert_Between
 131            (L     => L,
 132             Elem  => Elem,
 133             Left  => Head.Prev,
 134             Right => Head);
 135       end Append;
 136
 137       ------------
 138       -- Create --
 139       ------------
 140
 141       function Create return Doubly_Linked_List is
 142       begin
 143          return new Doubly_Linked_List_Attributes;
 144       end Create;
 145
 146       --------------
 147       -- Contains --
 148       --------------
 149
 150       function Contains
 151         (L    : Doubly_Linked_List;
 152          Elem : Element_Type) return Boolean
 153       is
 154          Head : Node_Ptr;
 155          Nod  : Node_Ptr;
 156
 157       begin
 158          Ensure_Created (L);
 159
 160          Head := L.Nodes'Access;
 161          Nod  := Find_Node (Head, Elem);
 162
 163          return Is_Valid (Nod, Head);
 164       end Contains;
 165
 166       ------------
 167       -- Delete --
 168       ------------
 169
 170       procedure Delete
 171         (L    : Doubly_Linked_List;
 172          Elem : Element_Type)
 173       is
 174          Head : Node_Ptr;
 175          Nod  : Node_Ptr;
 176
 177       begin
 178          Ensure_Created  (L);
 179          Ensure_Full     (L);
 180          Ensure_Unlocked (L);
 181
 182          Head := L.Nodes'Access;
 183          Nod  := Find_Node (Head, Elem);
 184
 185          if Is_Valid (Nod, Head) then
 186             Delete_Node (L, Nod);
 187          end if;
 188       end Delete;
 189
 190       ------------------
 191       -- Delete_First --
 192       ------------------
 193
 194       procedure Delete_First (L : Doubly_Linked_List) is
 195          Head : Node_Ptr;
 196          Nod  : Node_Ptr;
 197
 198       begin
 199          Ensure_Created  (L);
 200          Ensure_Full     (L);
 201          Ensure_Unlocked (L);
 202
 203          Head := L.Nodes'Access;
 204          Nod  := Head.Next;
 205
 206          if Is_Valid (Nod, Head) then
 207             Delete_Node (L, Nod);
 208          end if;
 209       end Delete_First;
 210
 211       -----------------
 212       -- Delete_Last --
 213       -----------------
 214
 215       procedure Delete_Last (L : Doubly_Linked_List) is
 216          Head : Node_Ptr;
 217          Nod  : Node_Ptr;
 218
 219       begin
 220          Ensure_Created  (L);
 221          Ensure_Full     (L);
 222          Ensure_Unlocked (L);
 223
 224          Head := L.Nodes'Access;
 225          Nod  := Head.Prev;
 226
 227          if Is_Valid (Nod, Head) then
 228             Delete_Node (L, Nod);
 229          end if;
 230       end Delete_Last;
 231
 232       -----------------
 233       -- Delete_Node --
 234       -----------------
 235
 236       procedure Delete_Node
 237         (L   : Doubly_Linked_List;
 238          Nod : Node_Ptr)
 239       is
 240          Ref : Node_Ptr := Nod;
 241
 242          pragma Assert (Present (Ref));
 243
 244          Next : constant Node_Ptr := Ref.Next;
 245          Prev : constant Node_Ptr := Ref.Prev;
 246
 247       begin
 248          pragma Assert (Present (L));
 249          pragma Assert (Present (Next));
 250          pragma Assert (Present (Prev));
 251
 252          Prev.Next := Next;  --  Prev ---> Next
 253          Next.Prev := Prev;  --  Prev <--> Next
 254
 255          Ref.Next := null;
 256          Ref.Prev := null;
 257
 258          L.Elements := L.Elements - 1;
 259
 260          --  Invoke the element destructor before deallocating the node
 261
 262          Destroy_Element (Nod.Elem);
 263
 264          Free (Ref);
 265       end Delete_Node;
 266
 267       -------------
 268       -- Destroy --
 269       -------------
 270
 271       procedure Destroy (L : in out Doubly_Linked_List) is
 272          Head : Node_Ptr;
 273
 274       begin
 275          Ensure_Created  (L);
 276          Ensure_Unlocked (L);
 277
 278          Head := L.Nodes'Access;
 279
 280          while Is_Valid (Head.Next, Head) loop
 281             Delete_Node (L, Head.Next);
 282          end loop;
 283
 284          Free (L);
 285       end Destroy;
 286
 287       ---------------------
 288       -- Ensure_Circular --
 289       ---------------------
 290
 291       procedure Ensure_Circular (Head : Node_Ptr) is
 292          pragma Assert (Present (Head));
 293
 294       begin
 295          if not Present (Head.Next) and then not Present (Head.Prev) then
 296             Head.Next := Head;
 297             Head.Prev := Head;
 298          end if;
 299       end Ensure_Circular;
 300
 301       --------------------
 302       -- Ensure_Created --
 303       --------------------
 304
 305       procedure Ensure_Created (L : Doubly_Linked_List) is
 306       begin
 307          if not Present (L) then
 308             raise Not_Created;
 309          end if;
 310       end Ensure_Created;
 311
 312       -----------------
 313       -- Ensure_Full --
 314       -----------------
 315
 316       procedure Ensure_Full (L : Doubly_Linked_List) is
 317       begin
 318          pragma Assert (Present (L));
 319
 320          if L.Elements = 0 then
 321             raise List_Empty;
 322          end if;
 323       end Ensure_Full;
 324
 325       ---------------------
 326       -- Ensure_Unlocked --
 327       ---------------------
 328
 329       procedure Ensure_Unlocked (L : Doubly_Linked_List) is
 330       begin
 331          pragma Assert (Present (L));
 332
 333          --  The list has at least one outstanding iterator
 334
 335          if L.Iterators > 0 then
 336             raise Iterated;
 337          end if;
 338       end Ensure_Unlocked;
 339
 340       -----------
 341       -- Equal --
 342       -----------
 343
 344       function Equal
 345         (Left  : Doubly_Linked_List;
 346          Right : Doubly_Linked_List) return Boolean
 347       is
 348          Left_Head  : Node_Ptr;
 349          Left_Nod   : Node_Ptr;
 350          Right_Head : Node_Ptr;
 351          Right_Nod  : Node_Ptr;
 352
 353       begin
 354          --  Two non-existent lists are considered equal
 355
 356          if Left = Nil and then Right = Nil then
 357             return True;
 358
 359          --  A non-existent list is never equal to an already created list
 360
 361          elsif Left = Nil or else Right = Nil then
 362             return False;
 363
 364          --  The two lists must contain the same number of elements to be equal
 365
 366          elsif Size (Left) /= Size (Right) then
 367             return False;
 368          end if;
 369
 370          --  Compare the two lists element by element
 371
 372          Left_Head  := Left.Nodes'Access;
 373          Left_Nod   := Left_Head.Next;
 374          Right_Head := Right.Nodes'Access;
 375          Right_Nod  := Right_Head.Next;
 376          while Is_Valid (Left_Nod,  Left_Head)
 377                  and then
 378                Is_Valid (Right_Nod, Right_Head)
 379          loop
 380             if Left_Nod.Elem /= Right_Nod.Elem then
 381                return False;
 382             end if;
 383
 384             Left_Nod  := Left_Nod.Next;
 385             Right_Nod := Right_Nod.Next;
 386          end loop;
 387
 388          return True;
 389       end Equal;
 390
 391       ---------------
 392       -- Find_Node --
 393       ---------------
 394
 395       function Find_Node
 396         (Head : Node_Ptr;
 397          Elem : Element_Type) return Node_Ptr
 398       is
 399          pragma Assert (Present (Head));
 400
 401          Nod : Node_Ptr;
 402
 403       begin
 404          --  Traverse the nodes of the list, looking for a matching element
 405
 406          Nod := Head.Next;
 407          while Is_Valid (Nod, Head) loop
 408             if Nod.Elem = Elem then
 409                return Nod;
 410             end if;
 411
 412             Nod := Nod.Next;
 413          end loop;
 414
 415          return null;
 416       end Find_Node;
 417
 418       -----------
 419       -- First --
 420       -----------
 421
 422       function First (L : Doubly_Linked_List) return Element_Type is
 423       begin
 424          Ensure_Created (L);
 425          Ensure_Full    (L);
 426
 427          return L.Nodes.Next.Elem;
 428       end First;
 429
 430       --------------
 431       -- Has_Next --
 432       --------------
 433
 434       function Has_Next (Iter : Iterator) return Boolean is
 435          Is_OK : constant Boolean := Is_Valid (Iter);
 436
 437       begin
 438          --  The iterator is no longer valid which indicates that it has been
 439          --  exhausted. Unlock all mutation functionality of the list because
 440          --  the iterator cannot be advanced any further.
 441
 442          if not Is_OK then
 443             Unlock (Iter.List);
 444          end if;
 445
 446          return Is_OK;
 447       end Has_Next;
 448
 449       ------------------
 450       -- Insert_After --
 451       ------------------
 452
 453       procedure Insert_After
 454         (L     : Doubly_Linked_List;
 455          After : Element_Type;
 456          Elem  : Element_Type)
 457       is
 458          Head : Node_Ptr;
 459          Nod  : Node_Ptr;
 460
 461       begin
 462          Ensure_Created  (L);
 463          Ensure_Unlocked (L);
 464
 465          Head := L.Nodes'Access;
 466          Nod  := Find_Node (Head, After);
 467
 468          if Is_Valid (Nod, Head) then
 469             Insert_Between
 470               (L     => L,
 471                Elem  => Elem,
 472                Left  => Nod,
 473                Right => Nod.Next);
 474          end if;
 475       end Insert_After;
 476
 477       -------------------
 478       -- Insert_Before --
 479       -------------------
 480
 481       procedure Insert_Before
 482         (L      : Doubly_Linked_List;
 483          Before : Element_Type;
 484          Elem   : Element_Type)
 485       is
 486          Head : Node_Ptr;
 487          Nod  : Node_Ptr;
 488
 489       begin
 490          Ensure_Created  (L);
 491          Ensure_Unlocked (L);
 492
 493          Head := L.Nodes'Access;
 494          Nod  := Find_Node (Head, Before);
 495
 496          if Is_Valid (Nod, Head) then
 497             Insert_Between
 498               (L     => L,
 499                Elem  => Elem,
 500                Left  => Nod.Prev,
 501                Right => Nod);
 502          end if;
 503       end Insert_Before;
 504
 505       --------------------
 506       -- Insert_Between --
 507       --------------------
 508
 509       procedure Insert_Between
 510         (L     : Doubly_Linked_List;
 511          Elem  : Element_Type;
 512          Left  : Node_Ptr;
 513          Right : Node_Ptr)
 514       is
 515          pragma Assert (Present (L));
 516          pragma Assert (Present (Left));
 517          pragma Assert (Present (Right));
 518
 519          Nod : constant Node_Ptr :=
 520                  new Node'(Elem => Elem,
 521                            Next => Right,  --  Left      Nod ---> Right
 522                            Prev => Left);  --  Left <--- Nod ---> Right
 523
 524       begin
 525          Left.Next  := Nod;                --  Left <--> Nod ---> Right
 526          Right.Prev := Nod;                --  Left <--> Nod <--> Right
 527
 528          L.Elements := L.Elements + 1;
 529       end Insert_Between;
 530
 531       --------------
 532       -- Is_Empty --
 533       --------------
 534
 535       function Is_Empty (L : Doubly_Linked_List) return Boolean is
 536       begin
 537          Ensure_Created (L);
 538
 539          return L.Elements = 0;
 540       end Is_Empty;
 541
 542       --------------
 543       -- Is_Valid --
 544       --------------
 545
 546       function Is_Valid (Iter : Iterator) return Boolean is
 547       begin
 548          --  The invariant of Iterate and Next ensures that the iterator always
 549          --  refers to a valid node if there exists one.
 550
 551          return Is_Valid (Iter.Curr_Nod, Iter.List.Nodes'Access);
 552       end Is_Valid;
 553
 554       --------------
 555       -- Is_Valid --
 556       --------------
 557
 558       function Is_Valid
 559         (Nod  : Node_Ptr;
 560          Head : Node_Ptr) return Boolean
 561       is
 562       begin
 563          --  A node is valid if it is non-null, and does not refer to the dummy
 564          --  head of some list.
 565
 566          return Present (Nod) and then Nod /= Head;
 567       end Is_Valid;
 568
 569       -------------
 570       -- Iterate --
 571       -------------
 572
 573       function Iterate (L : Doubly_Linked_List) return Iterator is
 574       begin
 575          Ensure_Created (L);
 576
 577          --  Lock all mutation functionality of the list while it is being
 578          --  iterated on.
 579
 580          Lock (L);
 581
 582          return (List => L, Curr_Nod => L.Nodes.Next);
 583       end Iterate;
 584
 585       ----------
 586       -- Last --
 587       ----------
 588
 589       function Last (L : Doubly_Linked_List) return Element_Type is
 590       begin
 591          Ensure_Created (L);
 592          Ensure_Full   (L);
 593
 594          return L.Nodes.Prev.Elem;
 595       end Last;
 596
 597       ----------
 598       -- Lock --
 599       ----------
 600
 601       procedure Lock (L : Doubly_Linked_List) is
 602       begin
 603          pragma Assert (Present (L));
 604
 605          --  The list may be locked multiple times if multiple iterators are
 606          --  operating over it.
 607
 608          L.Iterators := L.Iterators + 1;
 609       end Lock;
 610
 611       ----------
 612       -- Next --
 613       ----------
 614
 615       procedure Next
 616         (Iter : in out Iterator;
 617          Elem : out Element_Type)
 618       is
 619          Is_OK : constant Boolean  := Is_Valid (Iter);
 620          Saved : constant Node_Ptr := Iter.Curr_Nod;
 621
 622       begin
 623          --  The iterator is no linger valid which indicates that it has been
 624          --  exhausted. Unlock all mutation functionality of the list as the
 625          --  iterator cannot be advanced any further.
 626
 627          if not Is_OK then
 628             Unlock (Iter.List);
 629             raise Iterator_Exhausted;
 630          end if;
 631
 632          --  Advance to the next node along the list
 633
 634          Iter.Curr_Nod := Iter.Curr_Nod.Next;
 635
 636          Elem := Saved.Elem;
 637       end Next;
 638
 639       -------------
 640       -- Prepend --
 641       -------------
 642
 643       procedure Prepend
 644         (L    : Doubly_Linked_List;
 645          Elem : Element_Type)
 646       is
 647          Head : Node_Ptr;
 648
 649       begin
 650          Ensure_Created  (L);
 651          Ensure_Unlocked (L);
 652
 653          --  Ensure that the dummy head of an empty list is circular with
 654          --  respect to itself.
 655
 656          Head := L.Nodes'Access;
 657          Ensure_Circular (Head);
 658
 659          --  Append the node by inserting it between the dummy head and the
 660          --  first node.
 661
 662          Insert_Between
 663            (L     => L,
 664             Elem  => Elem,
 665             Left  => Head,
 666             Right => Head.Next);
 667       end Prepend;
 668
 669       -------------
 670       -- Present --
 671       -------------
 672
 673       function Present (L : Doubly_Linked_List) return Boolean is
 674       begin
 675          return L /= Nil;
 676       end Present;
 677
 678       -------------
 679       -- Present --
 680       -------------
 681
 682       function Present (Nod : Node_Ptr) return Boolean is
 683       begin
 684          return Nod /= null;
 685       end Present;
 686
 687       -------------
 688       -- Replace --
 689       -------------
 690
 691       procedure Replace
 692         (L        : Doubly_Linked_List;
 693          Old_Elem : Element_Type;
 694          New_Elem : Element_Type)
 695       is
 696          Head : Node_Ptr;
 697          Nod  : Node_Ptr;
 698
 699       begin
 700          Ensure_Created  (L);
 701          Ensure_Unlocked (L);
 702
 703          Head := L.Nodes'Access;
 704          Nod  := Find_Node (Head, Old_Elem);
 705
 706          if Is_Valid (Nod, Head) then
 707             Nod.Elem := New_Elem;
 708          end if;
 709       end Replace;
 710
 711       ----------
 712       -- Size --
 713       ----------
 714
 715       function Size (L : Doubly_Linked_List) return Natural is
 716       begin
 717          Ensure_Created (L);
 718
 719          return L.Elements;
 720       end Size;
 721
 722       ------------
 723       -- Unlock --
 724       ------------
 725
 726       procedure Unlock (L : Doubly_Linked_List) is
 727       begin
 728          pragma Assert (Present (L));
 729
 730          --  The list may be locked multiple times if multiple iterators are
 731          --  operating over it.
 732
 733          L.Iterators := L.Iterators - 1;
 734       end Unlock;
 735    end Doubly_Linked_Lists;
 736
 737 end GNAT.Lists;