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