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