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-2010, 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          E := First (List);
 748
 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    -- p --
 992    -------
 993
 994    function p (U : Union_Id) return Node_Or_Entity_Id is
 995    begin
 996       if U in Node_Range then
 997          return Parent (Node_Or_Entity_Id (U));
 998       elsif U in List_Range then
 999          return Parent (List_Id (U));
1000       else
1001          return 99_999_999;
1002       end if;
1003    end p;
1004
1005    ------------
1006    -- Parent --
1007    ------------
1008
1009    function Parent (List : List_Id) return Node_Or_Entity_Id is
1010    begin
1011       pragma Assert (List <= Lists.Last);
1012       return Lists.Table (List).Parent;
1013    end Parent;
1014
1015    ----------
1016    -- Pick --
1017    ----------
1018
1019    function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is
1020       Elmt : Node_Or_Entity_Id;
1021
1022    begin
1023       Elmt := First (List);
1024       for J in 1 .. Index - 1 loop
1025          Elmt := Next (Elmt);
1026       end loop;
1027
1028       return Elmt;
1029    end Pick;
1030
1031    -------------
1032    -- Prepend --
1033    -------------
1034
1035    procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is
1036       F : constant Node_Or_Entity_Id := First (To);
1037
1038       procedure Prepend_Debug;
1039       pragma Inline (Prepend_Debug);
1040       --  Output debug information if Debug_Flag_N set
1041
1042       -------------------
1043       -- Prepend_Debug --
1044       -------------------
1045
1046       procedure Prepend_Debug is
1047       begin
1048          if Debug_Flag_N then
1049             Write_Str ("Prepend node ");
1050             Write_Int (Int (Node));
1051             Write_Str (" to list ");
1052             Write_Int (Int (To));
1053             Write_Eol;
1054          end if;
1055       end Prepend_Debug;
1056
1057    --  Start of processing for Prepend_Debug
1058
1059    begin
1060       pragma Assert (not Is_List_Member (Node));
1061
1062       if Node = Error then
1063          return;
1064       end if;
1065
1066       pragma Debug (Prepend_Debug);
1067
1068       if No (F) then
1069          Set_Last (To, Node);
1070       else
1071          Set_Prev (F, Node);
1072       end if;
1073
1074       Set_First (To, Node);
1075
1076       Nodes.Table (Node).In_List := True;
1077
1078       Set_Next      (Node, F);
1079       Set_Prev      (Node, Empty);
1080       Set_List_Link (Node, To);
1081    end Prepend;
1082
1083    ------------------
1084    -- Prepend_List --
1085    ------------------
1086
1087    procedure Prepend_List (List : List_Id; To : List_Id) is
1088
1089       procedure Prepend_List_Debug;
1090       pragma Inline (Prepend_List_Debug);
1091       --  Output debug information if Debug_Flag_N set
1092
1093       ------------------------
1094       -- Prepend_List_Debug --
1095       ------------------------
1096
1097       procedure Prepend_List_Debug is
1098       begin
1099          if Debug_Flag_N then
1100             Write_Str ("Prepend list ");
1101             Write_Int (Int (List));
1102             Write_Str (" to list ");
1103             Write_Int (Int (To));
1104             Write_Eol;
1105          end if;
1106       end Prepend_List_Debug;
1107
1108    --  Start of processing for Prepend_List
1109
1110    begin
1111       if Is_Empty_List (List) then
1112          return;
1113
1114       else
1115          declare
1116             F : constant Node_Or_Entity_Id := First (To);
1117             L : constant Node_Or_Entity_Id := Last (List);
1118             N : Node_Or_Entity_Id;
1119
1120          begin
1121             pragma Debug (Prepend_List_Debug);
1122
1123             N := L;
1124             loop
1125                Set_List_Link (N, To);
1126                N := Prev (N);
1127                exit when No (N);
1128             end loop;
1129
1130             if No (F) then
1131                Set_Last (To, L);
1132             else
1133                Set_Next (L, F);
1134             end if;
1135
1136             Set_Prev (F, L);
1137             Set_First (To, First (List));
1138
1139             Set_First (List, Empty);
1140             Set_Last  (List, Empty);
1141          end;
1142       end if;
1143    end Prepend_List;
1144
1145    ---------------------
1146    -- Prepend_List_To --
1147    ---------------------
1148
1149    procedure Prepend_List_To (To : List_Id; List : List_Id) is
1150    begin
1151       Prepend_List (List, To);
1152    end Prepend_List_To;
1153
1154    ----------------
1155    -- Prepend_To --
1156    ----------------
1157
1158    procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is
1159    begin
1160       Prepend (Node, To);
1161    end Prepend_To;
1162
1163    -------------
1164    -- Present --
1165    -------------
1166
1167    function Present (List : List_Id) return Boolean is
1168    begin
1169       return List /= No_List;
1170    end Present;
1171
1172    ----------
1173    -- Prev --
1174    ----------
1175
1176    function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
1177    begin
1178       pragma Assert (Is_List_Member (Node));
1179       return Prev_Node.Table (Node);
1180    end Prev;
1181
1182    procedure Prev (Node : in out Node_Or_Entity_Id) is
1183    begin
1184       Node := Prev (Node);
1185    end Prev;
1186
1187    -----------------------
1188    -- Prev_Node_Address --
1189    -----------------------
1190
1191    function Prev_Node_Address return System.Address is
1192    begin
1193       return Prev_Node.Table (First_Node_Id)'Address;
1194    end Prev_Node_Address;
1195
1196    ---------------------
1197    -- Prev_Non_Pragma --
1198    ---------------------
1199
1200    function Prev_Non_Pragma
1201      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1202    is
1203       N : Node_Or_Entity_Id;
1204
1205    begin
1206       N := Node;
1207       loop
1208          N := Prev (N);
1209          exit when Nkind (N) /= N_Pragma;
1210       end loop;
1211
1212       return N;
1213    end Prev_Non_Pragma;
1214
1215    procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is
1216    begin
1217       Node := Prev_Non_Pragma (Node);
1218    end Prev_Non_Pragma;
1219
1220    ------------
1221    -- Remove --
1222    ------------
1223
1224    procedure Remove (Node : Node_Or_Entity_Id) is
1225       Lst : constant List_Id           := List_Containing (Node);
1226       Prv : constant Node_Or_Entity_Id := Prev (Node);
1227       Nxt : constant Node_Or_Entity_Id := Next (Node);
1228
1229       procedure Remove_Debug;
1230       pragma Inline (Remove_Debug);
1231       --  Output debug information if Debug_Flag_N set
1232
1233       ------------------
1234       -- Remove_Debug --
1235       ------------------
1236
1237       procedure Remove_Debug is
1238       begin
1239          if Debug_Flag_N then
1240             Write_Str ("Remove node ");
1241             Write_Int (Int (Node));
1242             Write_Eol;
1243          end if;
1244       end Remove_Debug;
1245
1246    --  Start of processing for Remove
1247
1248    begin
1249       pragma Debug (Remove_Debug);
1250
1251       if No (Prv) then
1252          Set_First (Lst, Nxt);
1253       else
1254          Set_Next (Prv, Nxt);
1255       end if;
1256
1257       if No (Nxt) then
1258          Set_Last (Lst, Prv);
1259       else
1260          Set_Prev (Nxt, Prv);
1261       end if;
1262
1263       Nodes.Table (Node).In_List := False;
1264       Set_Parent (Node, Empty);
1265    end Remove;
1266
1267    -----------------
1268    -- Remove_Head --
1269    -----------------
1270
1271    function Remove_Head (List : List_Id) return Node_Or_Entity_Id is
1272       Frst : constant Node_Or_Entity_Id := First (List);
1273
1274       procedure Remove_Head_Debug;
1275       pragma Inline (Remove_Head_Debug);
1276       --  Output debug information if Debug_Flag_N set
1277
1278       -----------------------
1279       -- Remove_Head_Debug --
1280       -----------------------
1281
1282       procedure Remove_Head_Debug is
1283       begin
1284          if Debug_Flag_N then
1285             Write_Str ("Remove head of list ");
1286             Write_Int (Int (List));
1287             Write_Eol;
1288          end if;
1289       end Remove_Head_Debug;
1290
1291    --  Start of processing for Remove_Head
1292
1293    begin
1294       pragma Debug (Remove_Head_Debug);
1295
1296       if Frst = Empty then
1297          return Empty;
1298
1299       else
1300          declare
1301             Nxt : constant Node_Or_Entity_Id := Next (Frst);
1302
1303          begin
1304             Set_First (List, Nxt);
1305
1306             if No (Nxt) then
1307                Set_Last (List, Empty);
1308             else
1309                Set_Prev (Nxt, Empty);
1310             end if;
1311
1312             Nodes.Table (Frst).In_List := False;
1313             Set_Parent (Frst, Empty);
1314             return Frst;
1315          end;
1316       end if;
1317    end Remove_Head;
1318
1319    -----------------
1320    -- Remove_Next --
1321    -----------------
1322
1323    function Remove_Next
1324      (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
1325    is
1326       Nxt : constant Node_Or_Entity_Id := Next (Node);
1327
1328       procedure Remove_Next_Debug;
1329       pragma Inline (Remove_Next_Debug);
1330       --  Output debug information if Debug_Flag_N set
1331
1332       -----------------------
1333       -- Remove_Next_Debug --
1334       -----------------------
1335
1336       procedure Remove_Next_Debug is
1337       begin
1338          if Debug_Flag_N then
1339             Write_Str ("Remove next node after ");
1340             Write_Int (Int (Node));
1341             Write_Eol;
1342          end if;
1343       end Remove_Next_Debug;
1344
1345    --  Start of processing for Remove_Next
1346
1347    begin
1348       if Present (Nxt) then
1349          declare
1350             Nxt2 : constant Node_Or_Entity_Id := Next (Nxt);
1351             LC   : constant List_Id           := List_Containing (Node);
1352
1353          begin
1354             pragma Debug (Remove_Next_Debug);
1355             Set_Next (Node, Nxt2);
1356
1357             if No (Nxt2) then
1358                Set_Last (LC, Node);
1359             else
1360                Set_Prev (Nxt2, Node);
1361             end if;
1362
1363             Nodes.Table (Nxt).In_List := False;
1364             Set_Parent (Nxt, Empty);
1365          end;
1366       end if;
1367
1368       return Nxt;
1369    end Remove_Next;
1370
1371    ---------------
1372    -- Set_First --
1373    ---------------
1374
1375    procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
1376    begin
1377       Lists.Table (List).First := To;
1378    end Set_First;
1379
1380    --------------
1381    -- Set_Last --
1382    --------------
1383
1384    procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
1385    begin
1386       Lists.Table (List).Last := To;
1387    end Set_Last;
1388
1389    -------------------
1390    -- Set_List_Link --
1391    -------------------
1392
1393    procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
1394    begin
1395       Nodes.Table (Node).Link := Union_Id (To);
1396    end Set_List_Link;
1397
1398    --------------
1399    -- Set_Next --
1400    --------------
1401
1402    procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1403    begin
1404       Next_Node.Table (Node) := To;
1405    end Set_Next;
1406
1407    ----------------
1408    -- Set_Parent --
1409    ----------------
1410
1411    procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
1412    begin
1413       pragma Assert (List <= Lists.Last);
1414       Lists.Table (List).Parent := Node;
1415    end Set_Parent;
1416
1417    --------------
1418    -- Set_Prev --
1419    --------------
1420
1421    procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
1422    begin
1423       Prev_Node.Table (Node) := To;
1424    end Set_Prev;
1425
1426    ---------------
1427    -- Tree_Read --
1428    ---------------
1429
1430    procedure Tree_Read is
1431    begin
1432       Lists.Tree_Read;
1433       Next_Node.Tree_Read;
1434       Prev_Node.Tree_Read;
1435    end Tree_Read;
1436
1437    ----------------
1438    -- Tree_Write --
1439    ----------------
1440
1441    procedure Tree_Write is
1442    begin
1443       Lists.Tree_Write;
1444       Next_Node.Tree_Write;
1445       Prev_Node.Tree_Write;
1446    end Tree_Write;
1447
1448    ------------
1449    -- Unlock --
1450    ------------
1451
1452    procedure Unlock is
1453    begin
1454       Lists.Locked := False;
1455       Prev_Node.Locked := False;
1456       Next_Node.Locked := False;
1457    end Unlock;
1458
1459 end Nlists;