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-2016, 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.Orig_Nodes_Initial,
  96       Table_Increment      => Alloc.Orig_Nodes_Increment,
  97       Release_Threshold    => Alloc.Orig_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.Orig_Nodes_Initial,
 105       Table_Increment      => Alloc.Orig_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.Locked := True;
 725       Lists.Release;
 726
 727       Prev_Node.Locked := True;
 728       Next_Node.Locked := True;
 729
 730       Prev_Node.Release;
 731       Next_Node.Release;
 732    end Lock;
 733
 734    ----------------
 735    -- Lock_Lists --
 736    ----------------
 737
 738    procedure Lock_Lists is
 739    begin
 740       pragma Assert (not Locked);
 741       Locked := True;
 742    end Lock_Lists;
 743
 744    -------------------
 745    -- New_Copy_List --
 746    -------------------
 747
 748    function New_Copy_List (List : List_Id) return List_Id is
 749       NL : List_Id;
 750       E  : Node_Or_Entity_Id;
 751
 752    begin
 753       if List = No_List then
 754          return No_List;
 755
 756       else
 757          NL := New_List;
 758          E := First (List);
 759
 760          while Present (E) loop
 761             Append (New_Copy (E), NL);
 762             E := Next (E);
 763          end loop;
 764
 765          return NL;
 766       end if;
 767    end New_Copy_List;
 768
 769    ----------------------------
 770    -- New_Copy_List_Original --
 771    ----------------------------
 772
 773    function New_Copy_List_Original (List : List_Id) return List_Id is
 774       NL : List_Id;
 775       E  : Node_Or_Entity_Id;
 776
 777    begin
 778       if List = No_List then
 779          return No_List;
 780
 781       else
 782          NL := New_List;
 783
 784          E := First (List);
 785          while Present (E) loop
 786             if Comes_From_Source (E) then
 787                Append (New_Copy (E), NL);
 788             end if;
 789
 790             E := Next (E);
 791          end loop;
 792
 793          return NL;
 794       end if;
 795    end New_Copy_List_Original;
 796
 797    --------------
 798    -- New_List --
 799    --------------
 800
 801    function New_List return List_Id is
 802
 803       procedure New_List_Debug;
 804       pragma Inline (New_List_Debug);
 805       --  Output debugging information if Debug_Flag_N is set
 806
 807       --------------------
 808       -- New_List_Debug --
 809       --------------------
 810
 811       procedure New_List_Debug is
 812       begin
 813          if Debug_Flag_N then
 814             Write_Str ("Allocate new list, returned ID = ");
 815             Write_Int (Int (Lists.Last));
 816             Write_Eol;
 817          end if;
 818       end New_List_Debug;
 819
 820    --  Start of processing for New_List
 821
 822    begin
 823       Lists.Increment_Last;
 824
 825       declare
 826          List : constant List_Id := Lists.Last;
 827
 828       begin
 829          Set_Parent (List, Empty);
 830          Set_First  (List, Empty);
 831          Set_Last   (List, Empty);
 832
 833          pragma Debug (New_List_Debug);
 834          return (List);
 835       end;
 836    end New_List;
 837
 838    --  Since the one argument case is common, we optimize to build the right
 839    --  list directly, rather than first building an empty list and then doing
 840    --  the insertion, which results in some unnecessary work.
 841
 842    function New_List (Node : Node_Or_Entity_Id) return List_Id is
 843
 844       procedure New_List_Debug;
 845       pragma Inline (New_List_Debug);
 846       --  Output debugging information if Debug_Flag_N is set
 847
 848       --------------------
 849       -- New_List_Debug --
 850       --------------------
 851
 852       procedure New_List_Debug is
 853       begin
 854          if Debug_Flag_N then
 855             Write_Str ("Allocate new list, returned ID = ");
 856             Write_Int (Int (Lists.Last));
 857             Write_Eol;
 858          end if;
 859       end New_List_Debug;
 860
 861    --  Start of processing for New_List
 862
 863    begin
 864       if Node = Error then
 865          return New_List;
 866
 867       else
 868          pragma Assert (not Is_List_Member (Node));
 869
 870          Lists.Increment_Last;
 871
 872          declare
 873             List : constant List_Id := Lists.Last;
 874
 875          begin
 876             Set_Parent (List, Empty);
 877             Set_First  (List, Node);
 878             Set_Last   (List, Node);
 879
 880             Nodes.Table (Node).In_List := True;
 881             Set_List_Link (Node, List);
 882             Set_Prev (Node, Empty);
 883             Set_Next (Node, Empty);
 884             pragma Debug (New_List_Debug);
 885             return List;
 886          end;
 887       end if;
 888    end New_List;
 889
 890    function New_List
 891      (Node1 : Node_Or_Entity_Id;
 892       Node2 : Node_Or_Entity_Id) return List_Id
 893    is
 894       L : constant List_Id := New_List (Node1);
 895    begin
 896       Append (Node2, L);
 897       return L;
 898    end New_List;
 899
 900    function New_List
 901      (Node1 : Node_Or_Entity_Id;
 902       Node2 : Node_Or_Entity_Id;
 903       Node3 : Node_Or_Entity_Id) return List_Id
 904    is
 905       L : constant List_Id := New_List (Node1);
 906    begin
 907       Append (Node2, L);
 908       Append (Node3, 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) return List_Id
 917    is
 918       L : constant List_Id := New_List (Node1);
 919    begin
 920       Append (Node2, L);
 921       Append (Node3, L);
 922       Append (Node4, L);
 923       return L;
 924    end New_List;
 925
 926    function New_List
 927      (Node1 : Node_Or_Entity_Id;
 928       Node2 : Node_Or_Entity_Id;
 929       Node3 : Node_Or_Entity_Id;
 930       Node4 : Node_Or_Entity_Id;
 931       Node5 : Node_Or_Entity_Id) return List_Id
 932    is
 933       L : constant List_Id := New_List (Node1);
 934    begin
 935       Append (Node2, L);
 936       Append (Node3, L);
 937       Append (Node4, L);
 938       Append (Node5, L);
 939       return L;
 940    end New_List;
 941
 942    function New_List
 943      (Node1 : Node_Or_Entity_Id;
 944       Node2 : Node_Or_Entity_Id;
 945       Node3 : Node_Or_Entity_Id;
 946       Node4 : Node_Or_Entity_Id;
 947       Node5 : Node_Or_Entity_Id;
 948       Node6 : Node_Or_Entity_Id) return List_Id
 949    is
 950       L : constant List_Id := New_List (Node1);
 951    begin
 952       Append (Node2, L);
 953       Append (Node3, L);
 954       Append (Node4, L);
 955       Append (Node5, L);
 956       Append (Node6, L);
 957       return L;
 958    end New_List;
 959
 960    ----------
 961    -- Next --
 962    ----------
 963
 964    function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
 965    begin
 966       pragma Assert (Is_List_Member (Node));
 967       return Next_Node.Table (Node);
 968    end Next;
 969
 970    procedure Next (Node : in out Node_Or_Entity_Id) is
 971    begin
 972       Node := Next (Node);
 973    end Next;
 974
 975    -----------------------
 976    -- Next_Node_Address --
 977    -----------------------
 978
 979    function Next_Node_Address return System.Address is
 980    begin
 981       return Next_Node.Table (First_Node_Id)'Address;
 982    end Next_Node_Address;
 983
 984    ---------------------
 985    -- Next_Non_Pragma --
 986    ---------------------
 987
 988    function Next_Non_Pragma
 989      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
 990    is
 991       N : Node_Or_Entity_Id;
 992
 993    begin
 994       N := Node;
 995       loop
 996          N := Next (N);
 997          exit when not Nkind_In (N, N_Pragma, N_Null_Statement);
 998       end loop;
 999
1000       return N;
1001    end Next_Non_Pragma;
1002
1003    procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id) is
1004    begin
1005       Node := Next_Non_Pragma (Node);
1006    end Next_Non_Pragma;
1007
1008    --------
1009    -- No --
1010    --------
1011
1012    function No (List : List_Id) return Boolean is
1013    begin
1014       return List = No_List;
1015    end No;
1016
1017    ---------------
1018    -- Num_Lists --
1019    ---------------
1020
1021    function Num_Lists return Nat is
1022    begin
1023       return Int (Lists.Last) - Int (Lists.First) + 1;
1024    end Num_Lists;
1025
1026    ------------
1027    -- Parent --
1028    ------------
1029
1030    function Parent (List : List_Id) return Node_Or_Entity_Id is
1031    begin
1032       pragma Assert (List <= Lists.Last);
1033       return Lists.Table (List).Parent;
1034    end Parent;
1035
1036    ----------
1037    -- Pick --
1038    ----------
1039
1040    function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is
1041       Elmt : Node_Or_Entity_Id;
1042
1043    begin
1044       Elmt := First (List);
1045       for J in 1 .. Index - 1 loop
1046          Elmt := Next (Elmt);
1047       end loop;
1048
1049       return Elmt;
1050    end Pick;
1051
1052    -------------
1053    -- Prepend --
1054    -------------
1055
1056    procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is
1057       F : constant Node_Or_Entity_Id := First (To);
1058
1059       procedure Prepend_Debug;
1060       pragma Inline (Prepend_Debug);
1061       --  Output debug information if Debug_Flag_N set
1062
1063       -------------------
1064       -- Prepend_Debug --
1065       -------------------
1066
1067       procedure Prepend_Debug is
1068       begin
1069          if Debug_Flag_N then
1070             Write_Str ("Prepend node ");
1071             Write_Int (Int (Node));
1072             Write_Str (" to list ");
1073             Write_Int (Int (To));
1074             Write_Eol;
1075          end if;
1076       end Prepend_Debug;
1077
1078    --  Start of processing for Prepend_Debug
1079
1080    begin
1081       pragma Assert (not Is_List_Member (Node));
1082
1083       if Node = Error then
1084          return;
1085       end if;
1086
1087       pragma Debug (Prepend_Debug);
1088
1089       if No (F) then
1090          Set_Last (To, Node);
1091       else
1092          Set_Prev (F, Node);
1093       end if;
1094
1095       Set_First (To, Node);
1096
1097       Nodes.Table (Node).In_List := True;
1098
1099       Set_Next      (Node, F);
1100       Set_Prev      (Node, Empty);
1101       Set_List_Link (Node, To);
1102    end Prepend;
1103
1104    ------------------
1105    -- Prepend_List --
1106    ------------------
1107
1108    procedure Prepend_List (List : List_Id; To : List_Id) is
1109
1110       procedure Prepend_List_Debug;
1111       pragma Inline (Prepend_List_Debug);
1112       --  Output debug information if Debug_Flag_N set
1113
1114       ------------------------
1115       -- Prepend_List_Debug --
1116       ------------------------
1117
1118       procedure Prepend_List_Debug is
1119       begin
1120          if Debug_Flag_N then
1121             Write_Str ("Prepend list ");
1122             Write_Int (Int (List));
1123             Write_Str (" to list ");
1124             Write_Int (Int (To));
1125             Write_Eol;
1126          end if;
1127       end Prepend_List_Debug;
1128
1129    --  Start of processing for Prepend_List
1130
1131    begin
1132       if Is_Empty_List (List) then
1133          return;
1134
1135       else
1136          declare
1137             F : constant Node_Or_Entity_Id := First (To);
1138             L : constant Node_Or_Entity_Id := Last (List);
1139             N : Node_Or_Entity_Id;
1140
1141          begin
1142             pragma Debug (Prepend_List_Debug);
1143
1144             N := L;
1145             loop
1146                Set_List_Link (N, To);
1147                N := Prev (N);
1148                exit when No (N);
1149             end loop;
1150
1151             if No (F) then
1152                Set_Last (To, L);
1153             else
1154                Set_Next (L, F);
1155             end if;
1156
1157             Set_Prev (F, L);
1158             Set_First (To, First (List));
1159
1160             Set_First (List, Empty);
1161             Set_Last  (List, Empty);
1162          end;
1163       end if;
1164    end Prepend_List;
1165
1166    ---------------------
1167    -- Prepend_List_To --
1168    ---------------------
1169
1170    procedure Prepend_List_To (To : List_Id; List : List_Id) is
1171    begin
1172       Prepend_List (List, To);
1173    end Prepend_List_To;
1174
1175    -----------------
1176    -- Prepend_New --
1177    -----------------
1178
1179    procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
1180    begin
1181       if No (To) then
1182          To := New_List;
1183       end if;
1184
1185       Prepend (Node, To);
1186    end Prepend_New;
1187
1188    --------------------
1189    -- Prepend_New_To --
1190    --------------------
1191
1192    procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
1193    begin
1194       Prepend_New (Node, To);
1195    end Prepend_New_To;
1196
1197    ----------------
1198    -- Prepend_To --
1199    ----------------
1200
1201    procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is
1202    begin
1203       Prepend (Node, To);
1204    end Prepend_To;
1205
1206    -------------
1207    -- Present --
1208    -------------
1209
1210    function Present (List : List_Id) return Boolean is
1211    begin
1212       return List /= No_List;
1213    end Present;
1214
1215    ----------
1216    -- Prev --
1217    ----------
1218
1219    function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
1220    begin
1221       pragma Assert (Is_List_Member (Node));
1222       return Prev_Node.Table (Node);
1223    end Prev;
1224
1225    procedure Prev (Node : in out Node_Or_Entity_Id) is
1226    begin
1227       Node := Prev (Node);
1228    end Prev;
1229
1230    -----------------------
1231    -- Prev_Node_Address --
1232    -----------------------
1233
1234    function Prev_Node_Address return System.Address is
1235    begin
1236       return Prev_Node.Table (First_Node_Id)'Address;
1237    end Prev_Node_Address;
1238
1239    ---------------------
1240    -- Prev_Non_Pragma --
1241    ---------------------
1242
1243    function Prev_Non_Pragma
1244      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1245    is
1246       N : Node_Or_Entity_Id;
1247
1248    begin
1249       N := Node;
1250       loop
1251          N := Prev (N);
1252          exit when Nkind (N) /= N_Pragma;
1253       end loop;
1254
1255       return N;
1256    end Prev_Non_Pragma;
1257
1258    procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is
1259    begin
1260       Node := Prev_Non_Pragma (Node);
1261    end Prev_Non_Pragma;
1262
1263    ------------
1264    -- Remove --
1265    ------------
1266
1267    procedure Remove (Node : Node_Or_Entity_Id) is
1268       Lst : constant List_Id           := List_Containing (Node);
1269       Prv : constant Node_Or_Entity_Id := Prev (Node);
1270       Nxt : constant Node_Or_Entity_Id := Next (Node);
1271
1272       procedure Remove_Debug;
1273       pragma Inline (Remove_Debug);
1274       --  Output debug information if Debug_Flag_N set
1275
1276       ------------------
1277       -- Remove_Debug --
1278       ------------------
1279
1280       procedure Remove_Debug is
1281       begin
1282          if Debug_Flag_N then
1283             Write_Str ("Remove node ");
1284             Write_Int (Int (Node));
1285             Write_Eol;
1286          end if;
1287       end Remove_Debug;
1288
1289    --  Start of processing for Remove
1290
1291    begin
1292       pragma Debug (Remove_Debug);
1293
1294       if No (Prv) then
1295          Set_First (Lst, Nxt);
1296       else
1297          Set_Next (Prv, Nxt);
1298       end if;
1299
1300       if No (Nxt) then
1301          Set_Last (Lst, Prv);
1302       else
1303          Set_Prev (Nxt, Prv);
1304       end if;
1305
1306       Nodes.Table (Node).In_List := False;
1307       Set_Parent (Node, Empty);
1308    end Remove;
1309
1310    -----------------
1311    -- Remove_Head --
1312    -----------------
1313
1314    function Remove_Head (List : List_Id) return Node_Or_Entity_Id is
1315       Frst : constant Node_Or_Entity_Id := First (List);
1316
1317       procedure Remove_Head_Debug;
1318       pragma Inline (Remove_Head_Debug);
1319       --  Output debug information if Debug_Flag_N set
1320
1321       -----------------------
1322       -- Remove_Head_Debug --
1323       -----------------------
1324
1325       procedure Remove_Head_Debug is
1326       begin
1327          if Debug_Flag_N then
1328             Write_Str ("Remove head of list ");
1329             Write_Int (Int (List));
1330             Write_Eol;
1331          end if;
1332       end Remove_Head_Debug;
1333
1334    --  Start of processing for Remove_Head
1335
1336    begin
1337       pragma Debug (Remove_Head_Debug);
1338
1339       if Frst = Empty then
1340          return Empty;
1341
1342       else
1343          declare
1344             Nxt : constant Node_Or_Entity_Id := Next (Frst);
1345
1346          begin
1347             Set_First (List, Nxt);
1348
1349             if No (Nxt) then
1350                Set_Last (List, Empty);
1351             else
1352                Set_Prev (Nxt, Empty);
1353             end if;
1354
1355             Nodes.Table (Frst).In_List := False;
1356             Set_Parent (Frst, Empty);
1357             return Frst;
1358          end;
1359       end if;
1360    end Remove_Head;
1361
1362    -----------------
1363    -- Remove_Next --
1364    -----------------
1365
1366    function Remove_Next
1367      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1368    is
1369       Nxt : constant Node_Or_Entity_Id := Next (Node);
1370
1371       procedure Remove_Next_Debug;
1372       pragma Inline (Remove_Next_Debug);
1373       --  Output debug information if Debug_Flag_N set
1374
1375       -----------------------
1376       -- Remove_Next_Debug --
1377       -----------------------
1378
1379       procedure Remove_Next_Debug is
1380       begin
1381          if Debug_Flag_N then
1382             Write_Str ("Remove next node after ");
1383             Write_Int (Int (Node));
1384             Write_Eol;
1385          end if;
1386       end Remove_Next_Debug;
1387
1388    --  Start of processing for Remove_Next
1389
1390    begin
1391       if Present (Nxt) then
1392          declare
1393             Nxt2 : constant Node_Or_Entity_Id := Next (Nxt);
1394             LC   : constant List_Id           := List_Containing (Node);
1395
1396          begin
1397             pragma Debug (Remove_Next_Debug);
1398             Set_Next (Node, Nxt2);
1399
1400             if No (Nxt2) then
1401                Set_Last (LC, Node);
1402             else
1403                Set_Prev (Nxt2, Node);
1404             end if;
1405
1406             Nodes.Table (Nxt).In_List := False;
1407             Set_Parent (Nxt, Empty);
1408          end;
1409       end if;
1410
1411       return Nxt;
1412    end Remove_Next;
1413
1414    ---------------
1415    -- Set_First --
1416    ---------------
1417
1418    procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
1419    begin
1420       pragma Assert (not Locked);
1421       Lists.Table (List).First := To;
1422    end Set_First;
1423
1424    --------------
1425    -- Set_Last --
1426    --------------
1427
1428    procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
1429    begin
1430       pragma Assert (not Locked);
1431       Lists.Table (List).Last := To;
1432    end Set_Last;
1433
1434    -------------------
1435    -- Set_List_Link --
1436    -------------------
1437
1438    procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
1439    begin
1440       pragma Assert (not Locked);
1441       Nodes.Table (Node).Link := Union_Id (To);
1442    end Set_List_Link;
1443
1444    --------------
1445    -- Set_Next --
1446    --------------
1447
1448    procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1449    begin
1450       pragma Assert (not Locked);
1451       Next_Node.Table (Node) := To;
1452    end Set_Next;
1453
1454    ----------------
1455    -- Set_Parent --
1456    ----------------
1457
1458    procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
1459    begin
1460       pragma Assert (not Locked);
1461       pragma Assert (List <= Lists.Last);
1462       Lists.Table (List).Parent := Node;
1463    end Set_Parent;
1464
1465    --------------
1466    -- Set_Prev --
1467    --------------
1468
1469    procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1470    begin
1471       pragma Assert (not Locked);
1472       Prev_Node.Table (Node) := To;
1473    end Set_Prev;
1474
1475    ---------------
1476    -- Tree_Read --
1477    ---------------
1478
1479    procedure Tree_Read is
1480    begin
1481       pragma Assert (not Locked);
1482       Lists.Tree_Read;
1483       Next_Node.Tree_Read;
1484       Prev_Node.Tree_Read;
1485    end Tree_Read;
1486
1487    ----------------
1488    -- Tree_Write --
1489    ----------------
1490
1491    procedure Tree_Write is
1492    begin
1493       Lists.Tree_Write;
1494       Next_Node.Tree_Write;
1495       Prev_Node.Tree_Write;
1496    end Tree_Write;
1497
1498    ------------
1499    -- Unlock --
1500    ------------
1501
1502    procedure Unlock is
1503    begin
1504       Lists.Locked := False;
1505       Prev_Node.Locked := False;
1506       Next_Node.Locked := False;
1507    end Unlock;
1508
1509    ------------------
1510    -- Unlock_Lists --
1511    ------------------
1512
1513    procedure Unlock_Lists is
1514    begin
1515       pragma Assert (Locked);
1516       Locked := False;
1517    end Unlock_Lists;
1518
1519 end Nlists;