gcc/ada/nlists.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               N L I S T S                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-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 --  WARNING: There is a C version of this package. Any changes to this source
  33 --  file must be properly reflected in the corresponding C header a-nlists.h
  34
  35 with Alloc;
  36 with Atree;  use Atree;
  37 with Debug;  use Debug;
  38 with Output; use Output;
  39 with Sinfo;  use Sinfo;
  40 with Table;
  41
  42 package body Nlists is
  43    Locked : Boolean := False;
  44    --  Compiling with assertions enabled, list contents modifications are
  45    --  permitted only when this switch is set to False; compiling without
  46    --  assertions this lock has no effect.
  47
  48    use Atree_Private_Part;
  49    --  Get access to Nodes table
  50
  51    ----------------------------------
  52    -- Implementation of Node Lists --
  53    ----------------------------------
  54
  55    --  A node list is represented by a list header which contains
  56    --  three fields:
  57
  58    type List_Header is record
  59       First : Node_Or_Entity_Id;
  60       --  Pointer to first node in list. Empty if list is empty
  61
  62       Last : Node_Or_Entity_Id;
  63       --  Pointer to last node in list. Empty if list is empty
  64
  65       Parent : Node_Id;
  66       --  Pointer to parent of list. Empty if list has no parent
  67    end record;
  68
  69    --  The node lists are stored in a table indexed by List_Id values
  70
  71    package Lists is new Table.Table (
  72      Table_Component_Type => List_Header,
  73      Table_Index_Type     => List_Id'Base,
  74      Table_Low_Bound      => First_List_Id,
  75      Table_Initial        => Alloc.Lists_Initial,
  76      Table_Increment      => Alloc.Lists_Increment,
  77      Table_Name           => "Lists");
  78
  79    --  The nodes in the list all have the In_List flag set, and their Link
  80    --  fields (which otherwise point to the parent) contain the List_Id of
  81    --  the list header giving immediate access to the list containing the
  82    --  node, and its parent and first and last elements.
  83
  84    --  Two auxiliary tables, indexed by Node_Id values and built in parallel
  85    --  with the main nodes table and always having the same size contain the
  86    --  list link values that allow locating the previous and next node in a
  87    --  list. The entries in these tables are valid only if the In_List flag
  88    --  is set in the corresponding node. Next_Node is Empty at the end of a
  89    --  list and Prev_Node is Empty at the start of a list.
  90
  91    package Next_Node is new Table.Table (
  92       Table_Component_Type => Node_Or_Entity_Id,
  93       Table_Index_Type     => Node_Or_Entity_Id'Base,
  94       Table_Low_Bound      => First_Node_Id,
  95       Table_Initial        => Alloc.Nodes_Initial,
  96       Table_Increment      => Alloc.Nodes_Increment,
  97       Release_Threshold    => Alloc.Nodes_Release_Threshold,
  98       Table_Name           => "Next_Node");
  99
 100    package Prev_Node is new Table.Table (
 101       Table_Component_Type => Node_Or_Entity_Id,
 102       Table_Index_Type     => Node_Or_Entity_Id'Base,
 103       Table_Low_Bound      => First_Node_Id,
 104       Table_Initial        => Alloc.Nodes_Initial,
 105       Table_Increment      => Alloc.Nodes_Increment,
 106       Table_Name           => "Prev_Node");
 107
 108    -----------------------
 109    -- Local Subprograms --
 110    -----------------------
 111
 112    procedure Set_First (List : List_Id; To : Node_Or_Entity_Id);
 113    pragma Inline (Set_First);
 114    --  Sets First field of list header List to reference To
 115
 116    procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id);
 117    pragma Inline (Set_Last);
 118    --  Sets Last field of list header List to reference To
 119
 120    procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id);
 121    pragma Inline (Set_List_Link);
 122    --  Sets list link of Node to list header To
 123
 124    procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id);
 125    pragma Inline (Set_Next);
 126    --  Sets the Next_Node pointer for Node to reference To
 127
 128    procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id);
 129    pragma Inline (Set_Prev);
 130    --  Sets the Prev_Node pointer for Node to reference To
 131
 132    --------------------------
 133    -- Allocate_List_Tables --
 134    --------------------------
 135
 136    procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is
 137       Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last;
 138
 139    begin
 140       pragma Assert (N >= Old_Last);
 141       Next_Node.Set_Last (N);
 142       Prev_Node.Set_Last (N);
 143
 144       --  Make sure we have no uninitialized junk in any new entires added.
 145       --  This ensures that Tree_Gen will not write out any uninitialized junk.
 146
 147       for J in Old_Last + 1 .. N loop
 148          Next_Node.Table (J) := Empty;
 149          Prev_Node.Table (J) := Empty;
 150       end loop;
 151    end Allocate_List_Tables;
 152
 153    ------------
 154    -- Append --
 155    ------------
 156
 157    procedure Append (Node : Node_Or_Entity_Id; To : List_Id) is
 158       L : constant Node_Or_Entity_Id := Last (To);
 159
 160       procedure Append_Debug;
 161       pragma Inline (Append_Debug);
 162       --  Output debug information if Debug_Flag_N set
 163
 164       ------------------
 165       -- Append_Debug --
 166       ------------------
 167
 168       procedure Append_Debug is
 169       begin
 170          if Debug_Flag_N then
 171             Write_Str ("Append node ");
 172             Write_Int (Int (Node));
 173             Write_Str (" to list ");
 174             Write_Int (Int (To));
 175             Write_Eol;
 176          end if;
 177       end Append_Debug;
 178
 179    --  Start of processing for Append
 180
 181    begin
 182       pragma Assert (not Is_List_Member (Node));
 183
 184       if Node = Error then
 185          return;
 186       end if;
 187
 188       pragma Debug (Append_Debug);
 189
 190       if No (L) then
 191          Set_First (To, Node);
 192       else
 193          Set_Next (L, Node);
 194       end if;
 195
 196       Set_Last (To, Node);
 197
 198       Nodes.Table (Node).In_List := True;
 199
 200       Set_Next      (Node, Empty);
 201       Set_Prev      (Node, L);
 202       Set_List_Link (Node, To);
 203    end Append;
 204
 205    -----------------
 206    -- Append_List --
 207    -----------------
 208
 209    procedure Append_List (List : List_Id; To : List_Id) is
 210       procedure Append_List_Debug;
 211       pragma Inline (Append_List_Debug);
 212       --  Output debug information if Debug_Flag_N set
 213
 214       -----------------------
 215       -- Append_List_Debug --
 216       -----------------------
 217
 218       procedure Append_List_Debug is
 219       begin
 220          if Debug_Flag_N then
 221             Write_Str ("Append list ");
 222             Write_Int (Int (List));
 223             Write_Str (" to list ");
 224             Write_Int (Int (To));
 225             Write_Eol;
 226          end if;
 227       end Append_List_Debug;
 228
 229    --  Start of processing for Append_List
 230
 231    begin
 232       if Is_Empty_List (List) then
 233          return;
 234
 235       else
 236          declare
 237             L : constant Node_Or_Entity_Id := Last (To);
 238             F : constant Node_Or_Entity_Id := First (List);
 239             N : Node_Or_Entity_Id;
 240
 241          begin
 242             pragma Debug (Append_List_Debug);
 243
 244             N := F;
 245             loop
 246                Set_List_Link (N, To);
 247                N := Next (N);
 248                exit when No (N);
 249             end loop;
 250
 251             if No (L) then
 252                Set_First (To, F);
 253             else
 254                Set_Next (L, F);
 255             end if;
 256
 257             Set_Prev (F, L);
 258             Set_Last (To, Last (List));
 259
 260             Set_First (List, Empty);
 261             Set_Last  (List, Empty);
 262          end;
 263       end if;
 264    end Append_List;
 265
 266    --------------------
 267    -- Append_List_To --
 268    --------------------
 269
 270    procedure Append_List_To (To : List_Id; List : List_Id) is
 271    begin
 272       Append_List (List, To);
 273    end Append_List_To;
 274
 275    ----------------
 276    -- Append_New --
 277    ----------------
 278
 279    procedure Append_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
 280    begin
 281       if No (To) then
 282          To := New_List;
 283       end if;
 284
 285       Append (Node, To);
 286    end Append_New;
 287
 288    -------------------
 289    -- Append_New_To --
 290    -------------------
 291
 292    procedure Append_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
 293    begin
 294       Append_New (Node, To);
 295    end Append_New_To;
 296
 297    ---------------
 298    -- Append_To --
 299    ---------------
 300
 301    procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id) is
 302    begin
 303       Append (Node, To);
 304    end Append_To;
 305
 306    -----------
 307    -- First --
 308    -----------
 309
 310    function First (List : List_Id) return Node_Or_Entity_Id is
 311    begin
 312       if List = No_List then
 313          return Empty;
 314       else
 315          pragma Assert (List <= Lists.Last);
 316          return Lists.Table (List).First;
 317       end if;
 318    end First;
 319
 320    ----------------------
 321    -- First_Non_Pragma --
 322    ----------------------
 323
 324    function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is
 325       N : constant Node_Or_Entity_Id := First (List);
 326    begin
 327       if Nkind (N) /= N_Pragma
 328            and then
 329          Nkind (N) /= N_Null_Statement
 330       then
 331          return N;
 332       else
 333          return Next_Non_Pragma (N);
 334       end if;
 335    end First_Non_Pragma;
 336
 337    ----------------
 338    -- Initialize --
 339    ----------------
 340
 341    procedure Initialize is
 342       E : constant List_Id := Error_List;
 343
 344    begin
 345       Lists.Init;
 346       Next_Node.Init;
 347       Prev_Node.Init;
 348
 349       --  Allocate Error_List list header
 350
 351       Lists.Increment_Last;
 352       Set_Parent (E, Empty);
 353       Set_First  (E, Empty);
 354       Set_Last   (E, Empty);
 355    end Initialize;
 356
 357    ------------------
 358    -- In_Same_List --
 359    ------------------
 360
 361    function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean is
 362    begin
 363       return List_Containing (N1) = List_Containing (N2);
 364    end In_Same_List;
 365
 366    ------------------
 367    -- Insert_After --
 368    ------------------
 369
 370    procedure Insert_After
 371      (After : Node_Or_Entity_Id;
 372       Node  : Node_Or_Entity_Id)
 373    is
 374       procedure Insert_After_Debug;
 375       pragma Inline (Insert_After_Debug);
 376       --  Output debug information if Debug_Flag_N set
 377
 378       ------------------------
 379       -- Insert_After_Debug --
 380       ------------------------
 381
 382       procedure Insert_After_Debug is
 383       begin
 384          if Debug_Flag_N then
 385             Write_Str ("Insert node");
 386             Write_Int (Int (Node));
 387             Write_Str (" after node ");
 388             Write_Int (Int (After));
 389             Write_Eol;
 390          end if;
 391       end Insert_After_Debug;
 392
 393    --  Start of processing for Insert_After
 394
 395    begin
 396       pragma Assert
 397         (Is_List_Member (After) and then not Is_List_Member (Node));
 398
 399       if Node = Error then
 400          return;
 401       end if;
 402
 403       pragma Debug (Insert_After_Debug);
 404
 405       declare
 406          Before : constant Node_Or_Entity_Id := Next (After);
 407          LC     : constant List_Id           := List_Containing (After);
 408
 409       begin
 410          if Present (Before) then
 411             Set_Prev (Before, Node);
 412          else
 413             Set_Last (LC, Node);
 414          end if;
 415
 416          Set_Next (After, Node);
 417
 418          Nodes.Table (Node).In_List := True;
 419
 420          Set_Prev      (Node, After);
 421          Set_Next      (Node, Before);
 422          Set_List_Link (Node, LC);
 423       end;
 424    end Insert_After;
 425
 426    -------------------
 427    -- Insert_Before --
 428    -------------------
 429
 430    procedure Insert_Before
 431      (Before : Node_Or_Entity_Id;
 432       Node   : Node_Or_Entity_Id)
 433    is
 434       procedure Insert_Before_Debug;
 435       pragma Inline (Insert_Before_Debug);
 436       --  Output debug information if Debug_Flag_N set
 437
 438       -------------------------
 439       -- Insert_Before_Debug --
 440       -------------------------
 441
 442       procedure Insert_Before_Debug is
 443       begin
 444          if Debug_Flag_N then
 445             Write_Str ("Insert node");
 446             Write_Int (Int (Node));
 447             Write_Str (" before node ");
 448             Write_Int (Int (Before));
 449             Write_Eol;
 450          end if;
 451       end Insert_Before_Debug;
 452
 453    --  Start of processing for Insert_Before
 454
 455    begin
 456       pragma Assert
 457         (Is_List_Member (Before) and then not Is_List_Member (Node));
 458
 459       if Node = Error then
 460          return;
 461       end if;
 462
 463       pragma Debug (Insert_Before_Debug);
 464
 465       declare
 466          After : constant Node_Or_Entity_Id := Prev (Before);
 467          LC    : constant List_Id           := List_Containing (Before);
 468
 469       begin
 470          if Present (After) then
 471             Set_Next (After, Node);
 472          else
 473             Set_First (LC, Node);
 474          end if;
 475
 476          Set_Prev (Before, Node);
 477
 478          Nodes.Table (Node).In_List := True;
 479
 480          Set_Prev      (Node, After);
 481          Set_Next      (Node, Before);
 482          Set_List_Link (Node, LC);
 483       end;
 484    end Insert_Before;
 485
 486    -----------------------
 487    -- Insert_List_After --
 488    -----------------------
 489
 490    procedure Insert_List_After (After : Node_Or_Entity_Id; List : List_Id) is
 491
 492       procedure Insert_List_After_Debug;
 493       pragma Inline (Insert_List_After_Debug);
 494       --  Output debug information if Debug_Flag_N set
 495
 496       -----------------------------
 497       -- Insert_List_After_Debug --
 498       -----------------------------
 499
 500       procedure Insert_List_After_Debug is
 501       begin
 502          if Debug_Flag_N then
 503             Write_Str ("Insert list ");
 504             Write_Int (Int (List));
 505             Write_Str (" after node ");
 506             Write_Int (Int (After));
 507             Write_Eol;
 508          end if;
 509       end Insert_List_After_Debug;
 510
 511    --  Start of processing for Insert_List_After
 512
 513    begin
 514       pragma Assert (Is_List_Member (After));
 515
 516       if Is_Empty_List (List) then
 517          return;
 518
 519       else
 520          declare
 521             Before : constant Node_Or_Entity_Id := Next (After);
 522             LC     : constant List_Id           := List_Containing (After);
 523             F      : constant Node_Or_Entity_Id := First (List);
 524             L      : constant Node_Or_Entity_Id := Last (List);
 525             N      : Node_Or_Entity_Id;
 526
 527          begin
 528             pragma Debug (Insert_List_After_Debug);
 529
 530             N := F;
 531             loop
 532                Set_List_Link (N, LC);
 533                exit when N = L;
 534                N := Next (N);
 535             end loop;
 536
 537             if Present (Before) then
 538                Set_Prev (Before, L);
 539             else
 540                Set_Last (LC, L);
 541             end if;
 542
 543             Set_Next (After, F);
 544             Set_Prev (F, After);
 545             Set_Next (L, Before);
 546
 547             Set_First (List, Empty);
 548             Set_Last  (List, Empty);
 549          end;
 550       end if;
 551    end Insert_List_After;
 552
 553    ------------------------
 554    -- Insert_List_Before --
 555    ------------------------
 556
 557    procedure Insert_List_Before (Before : Node_Or_Entity_Id; List : List_Id) is
 558
 559       procedure Insert_List_Before_Debug;
 560       pragma Inline (Insert_List_Before_Debug);
 561       --  Output debug information if Debug_Flag_N set
 562
 563       ------------------------------
 564       -- Insert_List_Before_Debug --
 565       ------------------------------
 566
 567       procedure Insert_List_Before_Debug is
 568       begin
 569          if Debug_Flag_N then
 570             Write_Str ("Insert list ");
 571             Write_Int (Int (List));
 572             Write_Str (" before node ");
 573             Write_Int (Int (Before));
 574             Write_Eol;
 575          end if;
 576       end Insert_List_Before_Debug;
 577
 578    --  Start of processing for Insert_List_Before
 579
 580    begin
 581       pragma Assert (Is_List_Member (Before));
 582
 583       if Is_Empty_List (List) then
 584          return;
 585
 586       else
 587          declare
 588             After : constant Node_Or_Entity_Id := Prev (Before);
 589             LC    : constant List_Id           := List_Containing (Before);
 590             F     : constant Node_Or_Entity_Id := First (List);
 591             L     : constant Node_Or_Entity_Id := Last (List);
 592             N     : Node_Or_Entity_Id;
 593
 594          begin
 595             pragma Debug (Insert_List_Before_Debug);
 596
 597             N := F;
 598             loop
 599                Set_List_Link (N, LC);
 600                exit when N = L;
 601                N := Next (N);
 602             end loop;
 603
 604             if Present (After) then
 605                Set_Next (After, F);
 606             else
 607                Set_First (LC, F);
 608             end if;
 609
 610             Set_Prev (Before, L);
 611             Set_Prev (F, After);
 612             Set_Next (L, Before);
 613
 614             Set_First (List, Empty);
 615             Set_Last  (List, Empty);
 616          end;
 617       end if;
 618    end Insert_List_Before;
 619
 620    -------------------
 621    -- Is_Empty_List --
 622    -------------------
 623
 624    function Is_Empty_List (List : List_Id) return Boolean is
 625    begin
 626       return First (List) = Empty;
 627    end Is_Empty_List;
 628
 629    --------------------
 630    -- Is_List_Member --
 631    --------------------
 632
 633    function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is
 634    begin
 635       return Nodes.Table (Node).In_List;
 636    end Is_List_Member;
 637
 638    -----------------------
 639    -- Is_Non_Empty_List --
 640    -----------------------
 641
 642    function Is_Non_Empty_List (List : List_Id) return Boolean is
 643    begin
 644       return First (List) /= Empty;
 645    end Is_Non_Empty_List;
 646
 647    ----------
 648    -- Last --
 649    ----------
 650
 651    function Last (List : List_Id) return Node_Or_Entity_Id is
 652    begin
 653       pragma Assert (List <= Lists.Last);
 654       return Lists.Table (List).Last;
 655    end Last;
 656
 657    ------------------
 658    -- Last_List_Id --
 659    ------------------
 660
 661    function Last_List_Id return List_Id is
 662    begin
 663       return Lists.Last;
 664    end Last_List_Id;
 665
 666    ---------------------
 667    -- Last_Non_Pragma --
 668    ---------------------
 669
 670    function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is
 671       N : constant Node_Or_Entity_Id := Last (List);
 672    begin
 673       if Nkind (N) /= N_Pragma then
 674          return N;
 675       else
 676          return Prev_Non_Pragma (N);
 677       end if;
 678    end Last_Non_Pragma;
 679
 680    ---------------------
 681    -- List_Containing --
 682    ---------------------
 683
 684    function List_Containing (Node : Node_Or_Entity_Id) return List_Id is
 685    begin
 686       pragma Assert (Is_List_Member (Node));
 687       return List_Id (Nodes.Table (Node).Link);
 688    end List_Containing;
 689
 690    -----------------
 691    -- List_Length --
 692    -----------------
 693
 694    function List_Length (List : List_Id) return Nat is
 695       Result : Nat;
 696       Node   : Node_Or_Entity_Id;
 697
 698    begin
 699       Result := 0;
 700       Node := First (List);
 701       while Present (Node) loop
 702          Result := Result + 1;
 703          Node := Next (Node);
 704       end loop;
 705
 706       return Result;
 707    end List_Length;
 708
 709    -------------------
 710    -- Lists_Address --
 711    -------------------
 712
 713    function Lists_Address return System.Address is
 714    begin
 715       return Lists.Table (First_List_Id)'Address;
 716    end Lists_Address;
 717
 718    ----------
 719    -- Lock --
 720    ----------
 721
 722    procedure Lock is
 723    begin
 724       Lists.Release;
 725       Lists.Locked := True;
 726       Prev_Node.Release;
 727       Prev_Node.Locked := True;
 728       Next_Node.Release;
 729       Next_Node.Locked := True;
 730    end Lock;
 731
 732    ----------------
 733    -- Lock_Lists --
 734    ----------------
 735
 736    procedure Lock_Lists is
 737    begin
 738       pragma Assert (not Locked);
 739       Locked := True;
 740    end Lock_Lists;
 741
 742    -------------------
 743    -- New_Copy_List --
 744    -------------------
 745
 746    function New_Copy_List (List : List_Id) return List_Id is
 747       NL : List_Id;
 748       E  : Node_Or_Entity_Id;
 749
 750    begin
 751       if List = No_List then
 752          return No_List;
 753
 754       else
 755          NL := New_List;
 756          E := First (List);
 757
 758          while Present (E) loop
 759             Append (New_Copy (E), NL);
 760             E := Next (E);
 761          end loop;
 762
 763          return NL;
 764       end if;
 765    end New_Copy_List;
 766
 767    ----------------------------
 768    -- New_Copy_List_Original --
 769    ----------------------------
 770
 771    function New_Copy_List_Original (List : List_Id) return List_Id is
 772       NL : List_Id;
 773       E  : Node_Or_Entity_Id;
 774
 775    begin
 776       if List = No_List then
 777          return No_List;
 778
 779       else
 780          NL := New_List;
 781
 782          E := First (List);
 783          while Present (E) loop
 784             if Comes_From_Source (E) then
 785                Append (New_Copy (E), NL);
 786             end if;
 787
 788             E := Next (E);
 789          end loop;
 790
 791          return NL;
 792       end if;
 793    end New_Copy_List_Original;
 794
 795    --------------
 796    -- New_List --
 797    --------------
 798
 799    function New_List return List_Id is
 800
 801       procedure New_List_Debug;
 802       pragma Inline (New_List_Debug);
 803       --  Output debugging information if Debug_Flag_N is set
 804
 805       --------------------
 806       -- New_List_Debug --
 807       --------------------
 808
 809       procedure New_List_Debug is
 810       begin
 811          if Debug_Flag_N then
 812             Write_Str ("Allocate new list, returned ID = ");
 813             Write_Int (Int (Lists.Last));
 814             Write_Eol;
 815          end if;
 816       end New_List_Debug;
 817
 818    --  Start of processing for New_List
 819
 820    begin
 821       Lists.Increment_Last;
 822
 823       declare
 824          List : constant List_Id := Lists.Last;
 825
 826       begin
 827          Set_Parent (List, Empty);
 828          Set_First  (List, Empty);
 829          Set_Last   (List, Empty);
 830
 831          pragma Debug (New_List_Debug);
 832          return (List);
 833       end;
 834    end New_List;
 835
 836    --  Since the one argument case is common, we optimize to build the right
 837    --  list directly, rather than first building an empty list and then doing
 838    --  the insertion, which results in some unnecessary work.
 839
 840    function New_List (Node : Node_Or_Entity_Id) return List_Id is
 841
 842       procedure New_List_Debug;
 843       pragma Inline (New_List_Debug);
 844       --  Output debugging information if Debug_Flag_N is set
 845
 846       --------------------
 847       -- New_List_Debug --
 848       --------------------
 849
 850       procedure New_List_Debug is
 851       begin
 852          if Debug_Flag_N then
 853             Write_Str ("Allocate new list, returned ID = ");
 854             Write_Int (Int (Lists.Last));
 855             Write_Eol;
 856          end if;
 857       end New_List_Debug;
 858
 859    --  Start of processing for New_List
 860
 861    begin
 862       if Node = Error then
 863          return New_List;
 864
 865       else
 866          pragma Assert (not Is_List_Member (Node));
 867
 868          Lists.Increment_Last;
 869
 870          declare
 871             List : constant List_Id := Lists.Last;
 872
 873          begin
 874             Set_Parent (List, Empty);
 875             Set_First  (List, Node);
 876             Set_Last   (List, Node);
 877
 878             Nodes.Table (Node).In_List := True;
 879             Set_List_Link (Node, List);
 880             Set_Prev (Node, Empty);
 881             Set_Next (Node, Empty);
 882             pragma Debug (New_List_Debug);
 883             return List;
 884          end;
 885       end if;
 886    end New_List;
 887
 888    function New_List
 889      (Node1 : Node_Or_Entity_Id;
 890       Node2 : Node_Or_Entity_Id) return List_Id
 891    is
 892       L : constant List_Id := New_List (Node1);
 893    begin
 894       Append (Node2, L);
 895       return L;
 896    end New_List;
 897
 898    function New_List
 899      (Node1 : Node_Or_Entity_Id;
 900       Node2 : Node_Or_Entity_Id;
 901       Node3 : Node_Or_Entity_Id) return List_Id
 902    is
 903       L : constant List_Id := New_List (Node1);
 904    begin
 905       Append (Node2, L);
 906       Append (Node3, L);
 907       return L;
 908    end New_List;
 909
 910    function New_List
 911      (Node1 : Node_Or_Entity_Id;
 912       Node2 : Node_Or_Entity_Id;
 913       Node3 : Node_Or_Entity_Id;
 914       Node4 : Node_Or_Entity_Id) return List_Id
 915    is
 916       L : constant List_Id := New_List (Node1);
 917    begin
 918       Append (Node2, L);
 919       Append (Node3, L);
 920       Append (Node4, L);
 921       return L;
 922    end New_List;
 923
 924    function New_List
 925      (Node1 : Node_Or_Entity_Id;
 926       Node2 : Node_Or_Entity_Id;
 927       Node3 : Node_Or_Entity_Id;
 928       Node4 : Node_Or_Entity_Id;
 929       Node5 : Node_Or_Entity_Id) return List_Id
 930    is
 931       L : constant List_Id := New_List (Node1);
 932    begin
 933       Append (Node2, L);
 934       Append (Node3, L);
 935       Append (Node4, L);
 936       Append (Node5, L);
 937       return L;
 938    end New_List;
 939
 940    function New_List
 941      (Node1 : Node_Or_Entity_Id;
 942       Node2 : Node_Or_Entity_Id;
 943       Node3 : Node_Or_Entity_Id;
 944       Node4 : Node_Or_Entity_Id;
 945       Node5 : Node_Or_Entity_Id;
 946       Node6 : Node_Or_Entity_Id) return List_Id
 947    is
 948       L : constant List_Id := New_List (Node1);
 949    begin
 950       Append (Node2, L);
 951       Append (Node3, L);
 952       Append (Node4, L);
 953       Append (Node5, L);
 954       Append (Node6, L);
 955       return L;
 956    end New_List;
 957
 958    ----------
 959    -- Next --
 960    ----------
 961
 962    function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
 963    begin
 964       pragma Assert (Is_List_Member (Node));
 965       return Next_Node.Table (Node);
 966    end Next;
 967
 968    procedure Next (Node : in out Node_Or_Entity_Id) is
 969    begin
 970       Node := Next (Node);
 971    end Next;
 972
 973    -----------------------
 974    -- Next_Node_Address --
 975    -----------------------
 976
 977    function Next_Node_Address return System.Address is
 978    begin
 979       return Next_Node.Table (First_Node_Id)'Address;
 980    end Next_Node_Address;
 981
 982    ---------------------
 983    -- Next_Non_Pragma --
 984    ---------------------
 985
 986    function Next_Non_Pragma
 987      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
 988    is
 989       N : Node_Or_Entity_Id;
 990
 991    begin
 992       N := Node;
 993       loop
 994          N := Next (N);
 995          exit when not Nkind_In (N, N_Pragma, N_Null_Statement);
 996       end loop;
 997
 998       return N;
 999    end Next_Non_Pragma;
1000
1001    procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id) is
1002    begin
1003       Node := Next_Non_Pragma (Node);
1004    end Next_Non_Pragma;
1005
1006    --------
1007    -- No --
1008    --------
1009
1010    function No (List : List_Id) return Boolean is
1011    begin
1012       return List = No_List;
1013    end No;
1014
1015    ---------------
1016    -- Num_Lists --
1017    ---------------
1018
1019    function Num_Lists return Nat is
1020    begin
1021       return Int (Lists.Last) - Int (Lists.First) + 1;
1022    end Num_Lists;
1023
1024    ------------
1025    -- Parent --
1026    ------------
1027
1028    function Parent (List : List_Id) return Node_Or_Entity_Id is
1029    begin
1030       pragma Assert (List <= Lists.Last);
1031       return Lists.Table (List).Parent;
1032    end Parent;
1033
1034    ----------
1035    -- Pick --
1036    ----------
1037
1038    function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is
1039       Elmt : Node_Or_Entity_Id;
1040
1041    begin
1042       Elmt := First (List);
1043       for J in 1 .. Index - 1 loop
1044          Elmt := Next (Elmt);
1045       end loop;
1046
1047       return Elmt;
1048    end Pick;
1049
1050    -------------
1051    -- Prepend --
1052    -------------
1053
1054    procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is
1055       F : constant Node_Or_Entity_Id := First (To);
1056
1057       procedure Prepend_Debug;
1058       pragma Inline (Prepend_Debug);
1059       --  Output debug information if Debug_Flag_N set
1060
1061       -------------------
1062       -- Prepend_Debug --
1063       -------------------
1064
1065       procedure Prepend_Debug is
1066       begin
1067          if Debug_Flag_N then
1068             Write_Str ("Prepend node ");
1069             Write_Int (Int (Node));
1070             Write_Str (" to list ");
1071             Write_Int (Int (To));
1072             Write_Eol;
1073          end if;
1074       end Prepend_Debug;
1075
1076    --  Start of processing for Prepend_Debug
1077
1078    begin
1079       pragma Assert (not Is_List_Member (Node));
1080
1081       if Node = Error then
1082          return;
1083       end if;
1084
1085       pragma Debug (Prepend_Debug);
1086
1087       if No (F) then
1088          Set_Last (To, Node);
1089       else
1090          Set_Prev (F, Node);
1091       end if;
1092
1093       Set_First (To, Node);
1094
1095       Nodes.Table (Node).In_List := True;
1096
1097       Set_Next      (Node, F);
1098       Set_Prev      (Node, Empty);
1099       Set_List_Link (Node, To);
1100    end Prepend;
1101
1102    ------------------
1103    -- Prepend_List --
1104    ------------------
1105
1106    procedure Prepend_List (List : List_Id; To : List_Id) is
1107
1108       procedure Prepend_List_Debug;
1109       pragma Inline (Prepend_List_Debug);
1110       --  Output debug information if Debug_Flag_N set
1111
1112       ------------------------
1113       -- Prepend_List_Debug --
1114       ------------------------
1115
1116       procedure Prepend_List_Debug is
1117       begin
1118          if Debug_Flag_N then
1119             Write_Str ("Prepend list ");
1120             Write_Int (Int (List));
1121             Write_Str (" to list ");
1122             Write_Int (Int (To));
1123             Write_Eol;
1124          end if;
1125       end Prepend_List_Debug;
1126
1127    --  Start of processing for Prepend_List
1128
1129    begin
1130       if Is_Empty_List (List) then
1131          return;
1132
1133       else
1134          declare
1135             F : constant Node_Or_Entity_Id := First (To);
1136             L : constant Node_Or_Entity_Id := Last (List);
1137             N : Node_Or_Entity_Id;
1138
1139          begin
1140             pragma Debug (Prepend_List_Debug);
1141
1142             N := L;
1143             loop
1144                Set_List_Link (N, To);
1145                N := Prev (N);
1146                exit when No (N);
1147             end loop;
1148
1149             if No (F) then
1150                Set_Last (To, L);
1151             else
1152                Set_Next (L, F);
1153             end if;
1154
1155             Set_Prev (F, L);
1156             Set_First (To, First (List));
1157
1158             Set_First (List, Empty);
1159             Set_Last  (List, Empty);
1160          end;
1161       end if;
1162    end Prepend_List;
1163
1164    ---------------------
1165    -- Prepend_List_To --
1166    ---------------------
1167
1168    procedure Prepend_List_To (To : List_Id; List : List_Id) is
1169    begin
1170       Prepend_List (List, To);
1171    end Prepend_List_To;
1172
1173    -----------------
1174    -- Prepend_New --
1175    -----------------
1176
1177    procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
1178    begin
1179       if No (To) then
1180          To := New_List;
1181       end if;
1182
1183       Prepend (Node, To);
1184    end Prepend_New;
1185
1186    --------------------
1187    -- Prepend_New_To --
1188    --------------------
1189
1190    procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
1191    begin
1192       Prepend_New (Node, To);
1193    end Prepend_New_To;
1194
1195    ----------------
1196    -- Prepend_To --
1197    ----------------
1198
1199    procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is
1200    begin
1201       Prepend (Node, To);
1202    end Prepend_To;
1203
1204    -------------
1205    -- Present --
1206    -------------
1207
1208    function Present (List : List_Id) return Boolean is
1209    begin
1210       return List /= No_List;
1211    end Present;
1212
1213    ----------
1214    -- Prev --
1215    ----------
1216
1217    function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
1218    begin
1219       pragma Assert (Is_List_Member (Node));
1220       return Prev_Node.Table (Node);
1221    end Prev;
1222
1223    procedure Prev (Node : in out Node_Or_Entity_Id) is
1224    begin
1225       Node := Prev (Node);
1226    end Prev;
1227
1228    -----------------------
1229    -- Prev_Node_Address --
1230    -----------------------
1231
1232    function Prev_Node_Address return System.Address is
1233    begin
1234       return Prev_Node.Table (First_Node_Id)'Address;
1235    end Prev_Node_Address;
1236
1237    ---------------------
1238    -- Prev_Non_Pragma --
1239    ---------------------
1240
1241    function Prev_Non_Pragma
1242      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1243    is
1244       N : Node_Or_Entity_Id;
1245
1246    begin
1247       N := Node;
1248       loop
1249          N := Prev (N);
1250          exit when Nkind (N) /= N_Pragma;
1251       end loop;
1252
1253       return N;
1254    end Prev_Non_Pragma;
1255
1256    procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is
1257    begin
1258       Node := Prev_Non_Pragma (Node);
1259    end Prev_Non_Pragma;
1260
1261    ------------
1262    -- Remove --
1263    ------------
1264
1265    procedure Remove (Node : Node_Or_Entity_Id) is
1266       Lst : constant List_Id           := List_Containing (Node);
1267       Prv : constant Node_Or_Entity_Id := Prev (Node);
1268       Nxt : constant Node_Or_Entity_Id := Next (Node);
1269
1270       procedure Remove_Debug;
1271       pragma Inline (Remove_Debug);
1272       --  Output debug information if Debug_Flag_N set
1273
1274       ------------------
1275       -- Remove_Debug --
1276       ------------------
1277
1278       procedure Remove_Debug is
1279       begin
1280          if Debug_Flag_N then
1281             Write_Str ("Remove node ");
1282             Write_Int (Int (Node));
1283             Write_Eol;
1284          end if;
1285       end Remove_Debug;
1286
1287    --  Start of processing for Remove
1288
1289    begin
1290       pragma Debug (Remove_Debug);
1291
1292       if No (Prv) then
1293          Set_First (Lst, Nxt);
1294       else
1295          Set_Next (Prv, Nxt);
1296       end if;
1297
1298       if No (Nxt) then
1299          Set_Last (Lst, Prv);
1300       else
1301          Set_Prev (Nxt, Prv);
1302       end if;
1303
1304       Nodes.Table (Node).In_List := False;
1305       Set_Parent (Node, Empty);
1306    end Remove;
1307
1308    -----------------
1309    -- Remove_Head --
1310    -----------------
1311
1312    function Remove_Head (List : List_Id) return Node_Or_Entity_Id is
1313       Frst : constant Node_Or_Entity_Id := First (List);
1314
1315       procedure Remove_Head_Debug;
1316       pragma Inline (Remove_Head_Debug);
1317       --  Output debug information if Debug_Flag_N set
1318
1319       -----------------------
1320       -- Remove_Head_Debug --
1321       -----------------------
1322
1323       procedure Remove_Head_Debug is
1324       begin
1325          if Debug_Flag_N then
1326             Write_Str ("Remove head of list ");
1327             Write_Int (Int (List));
1328             Write_Eol;
1329          end if;
1330       end Remove_Head_Debug;
1331
1332    --  Start of processing for Remove_Head
1333
1334    begin
1335       pragma Debug (Remove_Head_Debug);
1336
1337       if Frst = Empty then
1338          return Empty;
1339
1340       else
1341          declare
1342             Nxt : constant Node_Or_Entity_Id := Next (Frst);
1343
1344          begin
1345             Set_First (List, Nxt);
1346
1347             if No (Nxt) then
1348                Set_Last (List, Empty);
1349             else
1350                Set_Prev (Nxt, Empty);
1351             end if;
1352
1353             Nodes.Table (Frst).In_List := False;
1354             Set_Parent (Frst, Empty);
1355             return Frst;
1356          end;
1357       end if;
1358    end Remove_Head;
1359
1360    -----------------
1361    -- Remove_Next --
1362    -----------------
1363
1364    function Remove_Next
1365      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1366    is
1367       Nxt : constant Node_Or_Entity_Id := Next (Node);
1368
1369       procedure Remove_Next_Debug;
1370       pragma Inline (Remove_Next_Debug);
1371       --  Output debug information if Debug_Flag_N set
1372
1373       -----------------------
1374       -- Remove_Next_Debug --
1375       -----------------------
1376
1377       procedure Remove_Next_Debug is
1378       begin
1379          if Debug_Flag_N then
1380             Write_Str ("Remove next node after ");
1381             Write_Int (Int (Node));
1382             Write_Eol;
1383          end if;
1384       end Remove_Next_Debug;
1385
1386    --  Start of processing for Remove_Next
1387
1388    begin
1389       if Present (Nxt) then
1390          declare
1391             Nxt2 : constant Node_Or_Entity_Id := Next (Nxt);
1392             LC   : constant List_Id           := List_Containing (Node);
1393
1394          begin
1395             pragma Debug (Remove_Next_Debug);
1396             Set_Next (Node, Nxt2);
1397
1398             if No (Nxt2) then
1399                Set_Last (LC, Node);
1400             else
1401                Set_Prev (Nxt2, Node);
1402             end if;
1403
1404             Nodes.Table (Nxt).In_List := False;
1405             Set_Parent (Nxt, Empty);
1406          end;
1407       end if;
1408
1409       return Nxt;
1410    end Remove_Next;
1411
1412    ---------------
1413    -- Set_First --
1414    ---------------
1415
1416    procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
1417    begin
1418       pragma Assert (not Locked);
1419       Lists.Table (List).First := To;
1420    end Set_First;
1421
1422    --------------
1423    -- Set_Last --
1424    --------------
1425
1426    procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
1427    begin
1428       pragma Assert (not Locked);
1429       Lists.Table (List).Last := To;
1430    end Set_Last;
1431
1432    -------------------
1433    -- Set_List_Link --
1434    -------------------
1435
1436    procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
1437    begin
1438       pragma Assert (not Locked);
1439       Nodes.Table (Node).Link := Union_Id (To);
1440    end Set_List_Link;
1441
1442    --------------
1443    -- Set_Next --
1444    --------------
1445
1446    procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1447    begin
1448       pragma Assert (not Locked);
1449       Next_Node.Table (Node) := To;
1450    end Set_Next;
1451
1452    ----------------
1453    -- Set_Parent --
1454    ----------------
1455
1456    procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
1457    begin
1458       pragma Assert (not Locked);
1459       pragma Assert (List <= Lists.Last);
1460       Lists.Table (List).Parent := Node;
1461    end Set_Parent;
1462
1463    --------------
1464    -- Set_Prev --
1465    --------------
1466
1467    procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1468    begin
1469       pragma Assert (not Locked);
1470       Prev_Node.Table (Node) := To;
1471    end Set_Prev;
1472
1473    ---------------
1474    -- Tree_Read --
1475    ---------------
1476
1477    procedure Tree_Read is
1478    begin
1479       pragma Assert (not Locked);
1480       Lists.Tree_Read;
1481       Next_Node.Tree_Read;
1482       Prev_Node.Tree_Read;
1483    end Tree_Read;
1484
1485    ----------------
1486    -- Tree_Write --
1487    ----------------
1488
1489    procedure Tree_Write is
1490    begin
1491       Lists.Tree_Write;
1492       Next_Node.Tree_Write;
1493       Prev_Node.Tree_Write;
1494    end Tree_Write;
1495
1496    ------------
1497    -- Unlock --
1498    ------------
1499
1500    procedure Unlock is
1501    begin
1502       Lists.Locked := False;
1503       Prev_Node.Locked := False;
1504       Next_Node.Locked := False;
1505    end Unlock;
1506
1507    ------------------
1508    -- Unlock_Lists --
1509    ------------------
1510
1511    procedure Unlock_Lists is
1512    begin
1513       pragma Assert (Locked);
1514       Locked := False;
1515    end Unlock_Lists;
1516
1517 end Nlists;