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-2009, 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_Id;
  56       --  Pointer to first node in list. Empty if list is empty
  57
  58       Last  : Node_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_Id,
  89       Table_Index_Type     => Node_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_Id,
  97       Table_Index_Type     => Node_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_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_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_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_Id; To : Node_Id);
 120    pragma Inline (Set_Next);
 121    --  Sets the Next_Node pointer for Node to reference To
 122
 123    procedure Set_Prev (Node : Node_Id; To : Node_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_Id) is
 132       Old_Last : constant Node_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_Id; To : List_Id) is
 153       L : constant Node_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_Id := Last (To);
 234             F : constant Node_Id := First (List);
 235             N : Node_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_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_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_Id is
 299       N : constant Node_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    -- Insert_After --
 333    ------------------
 334
 335    procedure Insert_After (After : Node_Id; Node : Node_Id) is
 336
 337       procedure Insert_After_Debug;
 338       pragma Inline (Insert_After_Debug);
 339       --  Output debug information if Debug_Flag_N set
 340
 341       ------------------------
 342       -- Insert_After_Debug --
 343       ------------------------
 344
 345       procedure Insert_After_Debug is
 346       begin
 347          if Debug_Flag_N then
 348             Write_Str ("Insert node");
 349             Write_Int (Int (Node));
 350             Write_Str (" after node ");
 351             Write_Int (Int (After));
 352             Write_Eol;
 353          end if;
 354       end Insert_After_Debug;
 355
 356    --  Start of processing for Insert_After
 357
 358    begin
 359       pragma Assert
 360         (Is_List_Member (After) and then not Is_List_Member (Node));
 361
 362       if Node = Error then
 363          return;
 364       end if;
 365
 366       pragma Debug (Insert_After_Debug);
 367
 368       declare
 369          Before : constant Node_Id := Next (After);
 370          LC     : constant List_Id := List_Containing (After);
 371
 372       begin
 373          if Present (Before) then
 374             Set_Prev (Before, Node);
 375          else
 376             Set_Last (LC, Node);
 377          end if;
 378
 379          Set_Next (After, Node);
 380
 381          Nodes.Table (Node).In_List := True;
 382
 383          Set_Prev      (Node, After);
 384          Set_Next      (Node, Before);
 385          Set_List_Link (Node, LC);
 386       end;
 387    end Insert_After;
 388
 389    -------------------
 390    -- Insert_Before --
 391    -------------------
 392
 393    procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
 394
 395       procedure Insert_Before_Debug;
 396       pragma Inline (Insert_Before_Debug);
 397       --  Output debug information if Debug_Flag_N set
 398
 399       -------------------------
 400       -- Insert_Before_Debug --
 401       -------------------------
 402
 403       procedure Insert_Before_Debug is
 404       begin
 405          if Debug_Flag_N then
 406             Write_Str ("Insert node");
 407             Write_Int (Int (Node));
 408             Write_Str (" before node ");
 409             Write_Int (Int (Before));
 410             Write_Eol;
 411          end if;
 412       end Insert_Before_Debug;
 413
 414    --  Start of processing for Insert_Before
 415
 416    begin
 417       pragma Assert
 418         (Is_List_Member (Before) and then not Is_List_Member (Node));
 419
 420       if Node = Error then
 421          return;
 422       end if;
 423
 424       pragma Debug (Insert_Before_Debug);
 425
 426       declare
 427          After : constant Node_Id := Prev (Before);
 428          LC    : constant List_Id := List_Containing (Before);
 429
 430       begin
 431          if Present (After) then
 432             Set_Next (After, Node);
 433          else
 434             Set_First (LC, Node);
 435          end if;
 436
 437          Set_Prev (Before, Node);
 438
 439          Nodes.Table (Node).In_List := True;
 440
 441          Set_Prev      (Node, After);
 442          Set_Next      (Node, Before);
 443          Set_List_Link (Node, LC);
 444       end;
 445    end Insert_Before;
 446
 447    -----------------------
 448    -- Insert_List_After --
 449    -----------------------
 450
 451    procedure Insert_List_After (After : Node_Id; List : List_Id) is
 452
 453       procedure Insert_List_After_Debug;
 454       pragma Inline (Insert_List_After_Debug);
 455       --  Output debug information if Debug_Flag_N set
 456
 457       -----------------------------
 458       -- Insert_List_After_Debug --
 459       -----------------------------
 460
 461       procedure Insert_List_After_Debug is
 462       begin
 463          if Debug_Flag_N then
 464             Write_Str ("Insert list ");
 465             Write_Int (Int (List));
 466             Write_Str (" after node ");
 467             Write_Int (Int (After));
 468             Write_Eol;
 469          end if;
 470       end Insert_List_After_Debug;
 471
 472    --  Start of processing for Insert_List_After
 473
 474    begin
 475       pragma Assert (Is_List_Member (After));
 476
 477       if Is_Empty_List (List) then
 478          return;
 479
 480       else
 481          declare
 482             Before : constant Node_Id := Next (After);
 483             LC     : constant List_Id := List_Containing (After);
 484             F      : constant Node_Id := First (List);
 485             L      : constant Node_Id := Last (List);
 486             N      : Node_Id;
 487
 488          begin
 489             pragma Debug (Insert_List_After_Debug);
 490
 491             N := F;
 492             loop
 493                Set_List_Link (N, LC);
 494                exit when N = L;
 495                N := Next (N);
 496             end loop;
 497
 498             if Present (Before) then
 499                Set_Prev (Before, L);
 500             else
 501                Set_Last (LC, L);
 502             end if;
 503
 504             Set_Next (After, F);
 505             Set_Prev (F, After);
 506             Set_Next (L, Before);
 507
 508             Set_First (List, Empty);
 509             Set_Last  (List, Empty);
 510          end;
 511       end if;
 512    end Insert_List_After;
 513
 514    ------------------------
 515    -- Insert_List_Before --
 516    ------------------------
 517
 518    procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
 519
 520       procedure Insert_List_Before_Debug;
 521       pragma Inline (Insert_List_Before_Debug);
 522       --  Output debug information if Debug_Flag_N set
 523
 524       ------------------------------
 525       -- Insert_List_Before_Debug --
 526       ------------------------------
 527
 528       procedure Insert_List_Before_Debug is
 529       begin
 530          if Debug_Flag_N then
 531             Write_Str ("Insert list ");
 532             Write_Int (Int (List));
 533             Write_Str (" before node ");
 534             Write_Int (Int (Before));
 535             Write_Eol;
 536          end if;
 537       end Insert_List_Before_Debug;
 538
 539    --  Start of processing for Insert_List_Before
 540
 541    begin
 542       pragma Assert (Is_List_Member (Before));
 543
 544       if Is_Empty_List (List) then
 545          return;
 546
 547       else
 548          declare
 549             After : constant Node_Id := Prev (Before);
 550             LC    : constant List_Id := List_Containing (Before);
 551             F     : constant Node_Id := First (List);
 552             L     : constant Node_Id := Last (List);
 553             N     : Node_Id;
 554
 555          begin
 556             pragma Debug (Insert_List_Before_Debug);
 557
 558             N := F;
 559             loop
 560                Set_List_Link (N, LC);
 561                exit when N = L;
 562                N := Next (N);
 563             end loop;
 564
 565             if Present (After) then
 566                Set_Next (After, F);
 567             else
 568                Set_First (LC, F);
 569             end if;
 570
 571             Set_Prev (Before, L);
 572             Set_Prev (F, After);
 573             Set_Next (L, Before);
 574
 575             Set_First (List, Empty);
 576             Set_Last  (List, Empty);
 577          end;
 578       end if;
 579    end Insert_List_Before;
 580
 581    -------------------
 582    -- Is_Empty_List --
 583    -------------------
 584
 585    function Is_Empty_List (List : List_Id) return Boolean is
 586    begin
 587       return First (List) = Empty;
 588    end Is_Empty_List;
 589
 590    --------------------
 591    -- Is_List_Member --
 592    --------------------
 593
 594    function Is_List_Member (Node : Node_Id) return Boolean is
 595    begin
 596       return Nodes.Table (Node).In_List;
 597    end Is_List_Member;
 598
 599    -----------------------
 600    -- Is_Non_Empty_List --
 601    -----------------------
 602
 603    function Is_Non_Empty_List (List : List_Id) return Boolean is
 604    begin
 605       return First (List) /= Empty;
 606    end Is_Non_Empty_List;
 607
 608    ----------
 609    -- Last --
 610    ----------
 611
 612    function Last (List : List_Id) return Node_Id is
 613    begin
 614       pragma Assert (List <= Lists.Last);
 615       return Lists.Table (List).Last;
 616    end Last;
 617
 618    ------------------
 619    -- Last_List_Id --
 620    ------------------
 621
 622    function Last_List_Id return List_Id is
 623    begin
 624       return Lists.Last;
 625    end Last_List_Id;
 626
 627    ---------------------
 628    -- Last_Non_Pragma --
 629    ---------------------
 630
 631    function Last_Non_Pragma (List : List_Id) return Node_Id is
 632       N : constant Node_Id := Last (List);
 633    begin
 634       if Nkind (N) /= N_Pragma then
 635          return N;
 636       else
 637          return Prev_Non_Pragma (N);
 638       end if;
 639    end Last_Non_Pragma;
 640
 641    ---------------------
 642    -- List_Containing --
 643    ---------------------
 644
 645    function List_Containing (Node : Node_Id) return List_Id is
 646    begin
 647       pragma Assert (Is_List_Member (Node));
 648       return List_Id (Nodes.Table (Node).Link);
 649    end List_Containing;
 650
 651    -----------------
 652    -- List_Length --
 653    -----------------
 654
 655    function List_Length (List : List_Id) return Nat is
 656       Result : Nat;
 657       Node   : Node_Id;
 658
 659    begin
 660       Result := 0;
 661       Node := First (List);
 662       while Present (Node) loop
 663          Result := Result + 1;
 664          Node := Next (Node);
 665       end loop;
 666
 667       return Result;
 668    end List_Length;
 669
 670    -------------------
 671    -- Lists_Address --
 672    -------------------
 673
 674    function Lists_Address return System.Address is
 675    begin
 676       return Lists.Table (First_List_Id)'Address;
 677    end Lists_Address;
 678
 679    ----------
 680    -- Lock --
 681    ----------
 682
 683    procedure Lock is
 684    begin
 685       Lists.Locked := True;
 686       Lists.Release;
 687
 688       Prev_Node.Locked := True;
 689       Next_Node.Locked := True;
 690
 691       Prev_Node.Release;
 692       Next_Node.Release;
 693    end Lock;
 694
 695    -------------------
 696    -- New_Copy_List --
 697    -------------------
 698
 699    function New_Copy_List (List : List_Id) return List_Id is
 700       NL : List_Id;
 701       E  : Node_Id;
 702
 703    begin
 704       if List = No_List then
 705          return No_List;
 706
 707       else
 708          NL := New_List;
 709          E := First (List);
 710
 711          while Present (E) loop
 712             Append (New_Copy (E), NL);
 713             E := Next (E);
 714          end loop;
 715
 716          return NL;
 717       end if;
 718    end New_Copy_List;
 719
 720    ----------------------------
 721    -- New_Copy_List_Original --
 722    ----------------------------
 723
 724    function New_Copy_List_Original (List : List_Id) return List_Id is
 725       NL : List_Id;
 726       E  : Node_Id;
 727
 728    begin
 729       if List = No_List then
 730          return No_List;
 731
 732       else
 733          NL := New_List;
 734          E := First (List);
 735
 736          while Present (E) loop
 737             if Comes_From_Source (E) then
 738                Append (New_Copy (E), NL);
 739             end if;
 740
 741             E := Next (E);
 742          end loop;
 743
 744          return NL;
 745       end if;
 746    end New_Copy_List_Original;
 747
 748    --------------
 749    -- New_List --
 750    --------------
 751
 752    function New_List return List_Id is
 753
 754       procedure New_List_Debug;
 755       pragma Inline (New_List_Debug);
 756       --  Output debugging information if Debug_Flag_N is set
 757
 758       --------------------
 759       -- New_List_Debug --
 760       --------------------
 761
 762       procedure New_List_Debug is
 763       begin
 764          if Debug_Flag_N then
 765             Write_Str ("Allocate new list, returned ID = ");
 766             Write_Int (Int (Lists.Last));
 767             Write_Eol;
 768          end if;
 769       end New_List_Debug;
 770
 771    --  Start of processing for New_List
 772
 773    begin
 774       Lists.Increment_Last;
 775
 776       declare
 777          List : constant List_Id := Lists.Last;
 778
 779       begin
 780          Set_Parent (List, Empty);
 781          Set_First  (List, Empty);
 782          Set_Last   (List, Empty);
 783
 784          pragma Debug (New_List_Debug);
 785          return (List);
 786       end;
 787    end New_List;
 788
 789    --  Since the one argument case is common, we optimize to build the right
 790    --  list directly, rather than first building an empty list and then doing
 791    --  the insertion, which results in some unnecessary work.
 792
 793    function New_List (Node : Node_Id) return List_Id is
 794
 795       procedure New_List_Debug;
 796       pragma Inline (New_List_Debug);
 797       --  Output debugging information if Debug_Flag_N is set
 798
 799       --------------------
 800       -- New_List_Debug --
 801       --------------------
 802
 803       procedure New_List_Debug is
 804       begin
 805          if Debug_Flag_N then
 806             Write_Str ("Allocate new list, returned ID = ");
 807             Write_Int (Int (Lists.Last));
 808             Write_Eol;
 809          end if;
 810       end New_List_Debug;
 811
 812    --  Start of processing for New_List
 813
 814    begin
 815       if Node = Error then
 816          return New_List;
 817
 818       else
 819          pragma Assert (not Is_List_Member (Node));
 820
 821          Lists.Increment_Last;
 822
 823          declare
 824             List : constant List_Id := Lists.Last;
 825
 826          begin
 827             Set_Parent (List, Empty);
 828             Set_First  (List, Node);
 829             Set_Last   (List, Node);
 830
 831             Nodes.Table (Node).In_List := True;
 832             Set_List_Link (Node, List);
 833             Set_Prev (Node, Empty);
 834             Set_Next (Node, Empty);
 835             pragma Debug (New_List_Debug);
 836             return List;
 837          end;
 838       end if;
 839    end New_List;
 840
 841    function New_List (Node1, Node2 : Node_Id) return List_Id is
 842       L : constant List_Id := New_List (Node1);
 843    begin
 844       Append (Node2, L);
 845       return L;
 846    end New_List;
 847
 848    function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
 849       L : constant List_Id := New_List (Node1);
 850    begin
 851       Append (Node2, L);
 852       Append (Node3, L);
 853       return L;
 854    end New_List;
 855
 856    function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
 857       L : constant List_Id := New_List (Node1);
 858    begin
 859       Append (Node2, L);
 860       Append (Node3, L);
 861       Append (Node4, L);
 862       return L;
 863    end New_List;
 864
 865    function New_List
 866      (Node1 : Node_Id;
 867       Node2 : Node_Id;
 868       Node3 : Node_Id;
 869       Node4 : Node_Id;
 870       Node5 : Node_Id) return List_Id
 871    is
 872       L : constant List_Id := New_List (Node1);
 873    begin
 874       Append (Node2, L);
 875       Append (Node3, L);
 876       Append (Node4, L);
 877       Append (Node5, L);
 878       return L;
 879    end New_List;
 880
 881    function New_List
 882      (Node1 : Node_Id;
 883       Node2 : Node_Id;
 884       Node3 : Node_Id;
 885       Node4 : Node_Id;
 886       Node5 : Node_Id;
 887       Node6 : Node_Id) return List_Id
 888    is
 889       L : constant List_Id := New_List (Node1);
 890    begin
 891       Append (Node2, L);
 892       Append (Node3, L);
 893       Append (Node4, L);
 894       Append (Node5, L);
 895       Append (Node6, L);
 896       return L;
 897    end New_List;
 898
 899    ----------
 900    -- Next --
 901    ----------
 902
 903    function Next (Node : Node_Id) return Node_Id is
 904    begin
 905       pragma Assert (Is_List_Member (Node));
 906       return Next_Node.Table (Node);
 907    end Next;
 908
 909    procedure Next (Node : in out Node_Id) is
 910    begin
 911       Node := Next (Node);
 912    end Next;
 913
 914    -----------------------
 915    -- Next_Node_Address --
 916    -----------------------
 917
 918    function Next_Node_Address return System.Address is
 919    begin
 920       return Next_Node.Table (First_Node_Id)'Address;
 921    end Next_Node_Address;
 922
 923    ---------------------
 924    -- Next_Non_Pragma --
 925    ---------------------
 926
 927    function Next_Non_Pragma (Node : Node_Id) return Node_Id is
 928       N : Node_Id;
 929
 930    begin
 931       N := Node;
 932       loop
 933          N := Next (N);
 934          exit when Nkind (N) /= N_Pragma
 935                      and then
 936                    Nkind (N) /= N_Null_Statement;
 937       end loop;
 938
 939       return N;
 940    end Next_Non_Pragma;
 941
 942    procedure Next_Non_Pragma (Node : in out Node_Id) is
 943    begin
 944       Node := Next_Non_Pragma (Node);
 945    end Next_Non_Pragma;
 946
 947    --------
 948    -- No --
 949    --------
 950
 951    function No (List : List_Id) return Boolean is
 952    begin
 953       return List = No_List;
 954    end No;
 955
 956    ---------------
 957    -- Num_Lists --
 958    ---------------
 959
 960    function Num_Lists return Nat is
 961    begin
 962       return Int (Lists.Last) - Int (Lists.First) + 1;
 963    end Num_Lists;
 964
 965    -------
 966    -- p --
 967    -------
 968
 969    function p (U : Union_Id) return Node_Id is
 970    begin
 971       if U in Node_Range then
 972          return Parent (Node_Id (U));
 973       elsif U in List_Range then
 974          return Parent (List_Id (U));
 975       else
 976          return 99_999_999;
 977       end if;
 978    end p;
 979
 980    ------------
 981    -- Parent --
 982    ------------
 983
 984    function Parent (List : List_Id) return Node_Id is
 985    begin
 986       pragma Assert (List <= Lists.Last);
 987       return Lists.Table (List).Parent;
 988    end Parent;
 989
 990    ----------
 991    -- Pick --
 992    ----------
 993
 994    function Pick (List : List_Id; Index : Pos) return Node_Id is
 995       Elmt : Node_Id;
 996
 997    begin
 998       Elmt := First (List);
 999       for J in 1 .. Index - 1 loop
1000          Elmt := Next (Elmt);
1001       end loop;
1002
1003       return Elmt;
1004    end Pick;
1005
1006    -------------
1007    -- Prepend --
1008    -------------
1009
1010    procedure Prepend (Node : Node_Id; To : List_Id) is
1011       F : constant Node_Id := First (To);
1012
1013       procedure Prepend_Debug;
1014       pragma Inline (Prepend_Debug);
1015       --  Output debug information if Debug_Flag_N set
1016
1017       -------------------
1018       -- Prepend_Debug --
1019       -------------------
1020
1021       procedure Prepend_Debug is
1022       begin
1023          if Debug_Flag_N then
1024             Write_Str ("Prepend node ");
1025             Write_Int (Int (Node));
1026             Write_Str (" to list ");
1027             Write_Int (Int (To));
1028             Write_Eol;
1029          end if;
1030       end Prepend_Debug;
1031
1032    --  Start of processing for Prepend_Debug
1033
1034    begin
1035       pragma Assert (not Is_List_Member (Node));
1036
1037       if Node = Error then
1038          return;
1039       end if;
1040
1041       pragma Debug (Prepend_Debug);
1042
1043       if No (F) then
1044          Set_Last (To, Node);
1045       else
1046          Set_Prev (F, Node);
1047       end if;
1048
1049       Set_First (To, Node);
1050
1051       Nodes.Table (Node).In_List := True;
1052
1053       Set_Next      (Node, F);
1054       Set_Prev      (Node, Empty);
1055       Set_List_Link (Node, To);
1056    end Prepend;
1057
1058    ------------------
1059    -- Prepend_List --
1060    ------------------
1061
1062    procedure Prepend_List (List : List_Id; To : List_Id) is
1063
1064       procedure Prepend_List_Debug;
1065       pragma Inline (Prepend_List_Debug);
1066       --  Output debug information if Debug_Flag_N set
1067
1068       ------------------------
1069       -- Prepend_List_Debug --
1070       ------------------------
1071
1072       procedure Prepend_List_Debug is
1073       begin
1074          if Debug_Flag_N then
1075             Write_Str ("Prepend list ");
1076             Write_Int (Int (List));
1077             Write_Str (" to list ");
1078             Write_Int (Int (To));
1079             Write_Eol;
1080          end if;
1081       end Prepend_List_Debug;
1082
1083    --  Start of processing for Prepend_List
1084
1085    begin
1086       if Is_Empty_List (List) then
1087          return;
1088
1089       else
1090          declare
1091             F : constant Node_Id := First (To);
1092             L : constant Node_Id := Last (List);
1093             N : Node_Id;
1094
1095          begin
1096             pragma Debug (Prepend_List_Debug);
1097
1098             N := L;
1099             loop
1100                Set_List_Link (N, To);
1101                N := Prev (N);
1102                exit when No (N);
1103             end loop;
1104
1105             if No (F) then
1106                Set_Last (To, L);
1107             else
1108                Set_Next (L, F);
1109             end if;
1110
1111             Set_Prev (F, L);
1112             Set_First (To, First (List));
1113
1114             Set_First (List, Empty);
1115             Set_Last  (List, Empty);
1116          end;
1117       end if;
1118    end Prepend_List;
1119
1120    ---------------------
1121    -- Prepend_List_To --
1122    ---------------------
1123
1124    procedure Prepend_List_To (To : List_Id; List : List_Id) is
1125    begin
1126       Prepend_List (List, To);
1127    end Prepend_List_To;
1128
1129    ----------------
1130    -- Prepend_To --
1131    ----------------
1132
1133    procedure Prepend_To (To : List_Id; Node : Node_Id) is
1134    begin
1135       Prepend (Node, To);
1136    end Prepend_To;
1137
1138    -------------
1139    -- Present --
1140    -------------
1141
1142    function Present (List : List_Id) return Boolean is
1143    begin
1144       return List /= No_List;
1145    end Present;
1146
1147    ----------
1148    -- Prev --
1149    ----------
1150
1151    function Prev (Node : Node_Id) return Node_Id is
1152    begin
1153       pragma Assert (Is_List_Member (Node));
1154       return Prev_Node.Table (Node);
1155    end Prev;
1156
1157    procedure Prev (Node : in out Node_Id) is
1158    begin
1159       Node := Prev (Node);
1160    end Prev;
1161
1162    -----------------------
1163    -- Prev_Node_Address --
1164    -----------------------
1165
1166    function Prev_Node_Address return System.Address is
1167    begin
1168       return Prev_Node.Table (First_Node_Id)'Address;
1169    end Prev_Node_Address;
1170
1171    ---------------------
1172    -- Prev_Non_Pragma --
1173    ---------------------
1174
1175    function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1176       N : Node_Id;
1177
1178    begin
1179       N := Node;
1180       loop
1181          N := Prev (N);
1182          exit when Nkind (N) /= N_Pragma;
1183       end loop;
1184
1185       return N;
1186    end Prev_Non_Pragma;
1187
1188    procedure Prev_Non_Pragma (Node : in out Node_Id) is
1189    begin
1190       Node := Prev_Non_Pragma (Node);
1191    end Prev_Non_Pragma;
1192
1193    ------------
1194    -- Remove --
1195    ------------
1196
1197    procedure Remove (Node : Node_Id) is
1198       Lst : constant List_Id := List_Containing (Node);
1199       Prv : constant Node_Id := Prev (Node);
1200       Nxt : constant Node_Id := Next (Node);
1201
1202       procedure Remove_Debug;
1203       pragma Inline (Remove_Debug);
1204       --  Output debug information if Debug_Flag_N set
1205
1206       ------------------
1207       -- Remove_Debug --
1208       ------------------
1209
1210       procedure Remove_Debug is
1211       begin
1212          if Debug_Flag_N then
1213             Write_Str ("Remove node ");
1214             Write_Int (Int (Node));
1215             Write_Eol;
1216          end if;
1217       end Remove_Debug;
1218
1219    --  Start of processing for Remove
1220
1221    begin
1222       pragma Debug (Remove_Debug);
1223
1224       if No (Prv) then
1225          Set_First (Lst, Nxt);
1226       else
1227          Set_Next (Prv, Nxt);
1228       end if;
1229
1230       if No (Nxt) then
1231          Set_Last (Lst, Prv);
1232       else
1233          Set_Prev (Nxt, Prv);
1234       end if;
1235
1236       Nodes.Table (Node).In_List := False;
1237       Set_Parent (Node, Empty);
1238    end Remove;
1239
1240    -----------------
1241    -- Remove_Head --
1242    -----------------
1243
1244    function Remove_Head (List : List_Id) return Node_Id is
1245       Frst : constant Node_Id := First (List);
1246
1247       procedure Remove_Head_Debug;
1248       pragma Inline (Remove_Head_Debug);
1249       --  Output debug information if Debug_Flag_N set
1250
1251       -----------------------
1252       -- Remove_Head_Debug --
1253       -----------------------
1254
1255       procedure Remove_Head_Debug is
1256       begin
1257          if Debug_Flag_N then
1258             Write_Str ("Remove head of list ");
1259             Write_Int (Int (List));
1260             Write_Eol;
1261          end if;
1262       end Remove_Head_Debug;
1263
1264    --  Start of processing for Remove_Head
1265
1266    begin
1267       pragma Debug (Remove_Head_Debug);
1268
1269       if Frst = Empty then
1270          return Empty;
1271
1272       else
1273          declare
1274             Nxt : constant Node_Id := Next (Frst);
1275
1276          begin
1277             Set_First (List, Nxt);
1278
1279             if No (Nxt) then
1280                Set_Last (List, Empty);
1281             else
1282                Set_Prev (Nxt, Empty);
1283             end if;
1284
1285             Nodes.Table (Frst).In_List := False;
1286             Set_Parent (Frst, Empty);
1287             return Frst;
1288          end;
1289       end if;
1290    end Remove_Head;
1291
1292    -----------------
1293    -- Remove_Next --
1294    -----------------
1295
1296    function Remove_Next (Node : Node_Id) return Node_Id is
1297       Nxt : constant Node_Id := Next (Node);
1298
1299       procedure Remove_Next_Debug;
1300       pragma Inline (Remove_Next_Debug);
1301       --  Output debug information if Debug_Flag_N set
1302
1303       -----------------------
1304       -- Remove_Next_Debug --
1305       -----------------------
1306
1307       procedure Remove_Next_Debug is
1308       begin
1309          if Debug_Flag_N then
1310             Write_Str ("Remove next node after ");
1311             Write_Int (Int (Node));
1312             Write_Eol;
1313          end if;
1314       end Remove_Next_Debug;
1315
1316    --  Start of processing for Remove_Next
1317
1318    begin
1319       if Present (Nxt) then
1320          declare
1321             Nxt2 : constant Node_Id := Next (Nxt);
1322             LC   : constant List_Id := List_Containing (Node);
1323
1324          begin
1325             pragma Debug (Remove_Next_Debug);
1326             Set_Next (Node, Nxt2);
1327
1328             if No (Nxt2) then
1329                Set_Last (LC, Node);
1330             else
1331                Set_Prev (Nxt2, Node);
1332             end if;
1333
1334             Nodes.Table (Nxt).In_List := False;
1335             Set_Parent (Nxt, Empty);
1336          end;
1337       end if;
1338
1339       return Nxt;
1340    end Remove_Next;
1341
1342    ---------------
1343    -- Set_First --
1344    ---------------
1345
1346    procedure Set_First (List : List_Id; To : Node_Id) is
1347    begin
1348       Lists.Table (List).First := To;
1349    end Set_First;
1350
1351    --------------
1352    -- Set_Last --
1353    --------------
1354
1355    procedure Set_Last (List : List_Id; To : Node_Id) is
1356    begin
1357       Lists.Table (List).Last := To;
1358    end Set_Last;
1359
1360    -------------------
1361    -- Set_List_Link --
1362    -------------------
1363
1364    procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1365    begin
1366       Nodes.Table (Node).Link := Union_Id (To);
1367    end Set_List_Link;
1368
1369    --------------
1370    -- Set_Next --
1371    --------------
1372
1373    procedure Set_Next (Node : Node_Id; To : Node_Id) is
1374    begin
1375       Next_Node.Table (Node) := To;
1376    end Set_Next;
1377
1378    ----------------
1379    -- Set_Parent --
1380    ----------------
1381
1382    procedure Set_Parent (List : List_Id; Node : Node_Id) is
1383    begin
1384       pragma Assert (List <= Lists.Last);
1385       Lists.Table (List).Parent := Node;
1386    end Set_Parent;
1387
1388    --------------
1389    -- Set_Prev --
1390    --------------
1391
1392    procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1393    begin
1394       Prev_Node.Table (Node) := To;
1395    end Set_Prev;
1396
1397    ---------------
1398    -- Tree_Read --
1399    ---------------
1400
1401    procedure Tree_Read is
1402    begin
1403       Lists.Tree_Read;
1404       Next_Node.Tree_Read;
1405       Prev_Node.Tree_Read;
1406    end Tree_Read;
1407
1408    ----------------
1409    -- Tree_Write --
1410    ----------------
1411
1412    procedure Tree_Write is
1413    begin
1414       Lists.Tree_Write;
1415       Next_Node.Tree_Write;
1416       Prev_Node.Tree_Write;
1417    end Tree_Write;
1418
1419    ------------
1420    -- Unlock --
1421    ------------
1422
1423    procedure Unlock is
1424    begin
1425       Lists.Locked := False;
1426       Prev_Node.Locked := False;
1427       Next_Node.Locked := False;
1428    end Unlock;
1429
1430 end Nlists;