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_To --
1060    ----------------
1061
1062    procedure Prepend_To (To : List_Id; Node : Node_Id) is
1063    begin
1064       Prepend (Node, To);
1065    end Prepend_To;
1066
1067    -------------
1068    -- Present --
1069    -------------
1070
1071    function Present (List : List_Id) return Boolean is
1072    begin
1073       return List /= No_List;
1074    end Present;
1075
1076    ----------
1077    -- Prev --
1078    ----------
1079
1080    function Prev (Node : Node_Id) return Node_Id is
1081    begin
1082       pragma Assert (Is_List_Member (Node));
1083       return Prev_Node.Table (Node);
1084    end Prev;
1085
1086    procedure Prev (Node : in out Node_Id) is
1087    begin
1088       Node := Prev (Node);
1089    end Prev;
1090
1091    -----------------------
1092    -- Prev_Node_Address --
1093    -----------------------
1094
1095    function Prev_Node_Address return System.Address is
1096    begin
1097       return Prev_Node.Table (First_Node_Id)'Address;
1098    end Prev_Node_Address;
1099
1100    ---------------------
1101    -- Prev_Non_Pragma --
1102    ---------------------
1103
1104    function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
1105       N : Node_Id;
1106
1107    begin
1108       N := Node;
1109       loop
1110          N := Prev (N);
1111          exit when Nkind (N) /= N_Pragma;
1112       end loop;
1113
1114       return N;
1115    end Prev_Non_Pragma;
1116
1117    procedure Prev_Non_Pragma (Node : in out Node_Id) is
1118    begin
1119       Node := Prev_Non_Pragma (Node);
1120    end Prev_Non_Pragma;
1121
1122    ------------
1123    -- Remove --
1124    ------------
1125
1126    procedure Remove (Node : Node_Id) is
1127       Lst : constant List_Id := List_Containing (Node);
1128       Prv : constant Node_Id := Prev (Node);
1129       Nxt : constant Node_Id := Next (Node);
1130
1131       procedure Remove_Debug;
1132       pragma Inline (Remove_Debug);
1133       --  Output debug information if Debug_Flag_N set
1134
1135       ------------------
1136       -- Remove_Debug --
1137       ------------------
1138
1139       procedure Remove_Debug is
1140       begin
1141          if Debug_Flag_N then
1142             Write_Str ("Remove node ");
1143             Write_Int (Int (Node));
1144             Write_Eol;
1145          end if;
1146       end Remove_Debug;
1147
1148    --  Start of processing for Remove
1149
1150    begin
1151       pragma Debug (Remove_Debug);
1152
1153       if No (Prv) then
1154          Set_First (Lst, Nxt);
1155       else
1156          Set_Next (Prv, Nxt);
1157       end if;
1158
1159       if No (Nxt) then
1160          Set_Last (Lst, Prv);
1161       else
1162          Set_Prev (Nxt, Prv);
1163       end if;
1164
1165       Nodes.Table (Node).In_List := False;
1166       Set_Parent (Node, Empty);
1167    end Remove;
1168
1169    -----------------
1170    -- Remove_Head --
1171    -----------------
1172
1173    function Remove_Head (List : List_Id) return Node_Id is
1174       Frst : constant Node_Id := First (List);
1175
1176       procedure Remove_Head_Debug;
1177       pragma Inline (Remove_Head_Debug);
1178       --  Output debug information if Debug_Flag_N set
1179
1180       -----------------------
1181       -- Remove_Head_Debug --
1182       -----------------------
1183
1184       procedure Remove_Head_Debug is
1185       begin
1186          if Debug_Flag_N then
1187             Write_Str ("Remove head of list ");
1188             Write_Int (Int (List));
1189             Write_Eol;
1190          end if;
1191       end Remove_Head_Debug;
1192
1193    --  Start of processing for Remove_Head
1194
1195    begin
1196       pragma Debug (Remove_Head_Debug);
1197
1198       if Frst = Empty then
1199          return Empty;
1200
1201       else
1202          declare
1203             Nxt : constant Node_Id := Next (Frst);
1204
1205          begin
1206             Set_First (List, Nxt);
1207
1208             if No (Nxt) then
1209                Set_Last (List, Empty);
1210             else
1211                Set_Prev (Nxt, Empty);
1212             end if;
1213
1214             Nodes.Table (Frst).In_List := False;
1215             Set_Parent (Frst, Empty);
1216             return Frst;
1217          end;
1218       end if;
1219    end Remove_Head;
1220
1221    -----------------
1222    -- Remove_Next --
1223    -----------------
1224
1225    function Remove_Next (Node : Node_Id) return Node_Id is
1226       Nxt : constant Node_Id := Next (Node);
1227
1228       procedure Remove_Next_Debug;
1229       pragma Inline (Remove_Next_Debug);
1230       --  Output debug information if Debug_Flag_N set
1231
1232       -----------------------
1233       -- Remove_Next_Debug --
1234       -----------------------
1235
1236       procedure Remove_Next_Debug is
1237       begin
1238          if Debug_Flag_N then
1239             Write_Str ("Remove next node after ");
1240             Write_Int (Int (Node));
1241             Write_Eol;
1242          end if;
1243       end Remove_Next_Debug;
1244
1245    --  Start of processing for Remove_Next
1246
1247    begin
1248       if Present (Nxt) then
1249          declare
1250             Nxt2 : constant Node_Id := Next (Nxt);
1251             LC   : constant List_Id := List_Containing (Node);
1252
1253          begin
1254             pragma Debug (Remove_Next_Debug);
1255             Set_Next (Node, Nxt2);
1256
1257             if No (Nxt2) then
1258                Set_Last (LC, Node);
1259             else
1260                Set_Prev (Nxt2, Node);
1261             end if;
1262
1263             Nodes.Table (Nxt).In_List := False;
1264             Set_Parent (Nxt, Empty);
1265          end;
1266       end if;
1267
1268       return Nxt;
1269    end Remove_Next;
1270
1271    ---------------
1272    -- Set_First --
1273    ---------------
1274
1275    procedure Set_First (List : List_Id; To : Node_Id) is
1276    begin
1277       Lists.Table (List).First := To;
1278    end Set_First;
1279
1280    --------------
1281    -- Set_Last --
1282    --------------
1283
1284    procedure Set_Last (List : List_Id; To : Node_Id) is
1285    begin
1286       Lists.Table (List).Last := To;
1287    end Set_Last;
1288
1289    -------------------
1290    -- Set_List_Link --
1291    -------------------
1292
1293    procedure Set_List_Link (Node : Node_Id; To : List_Id) is
1294    begin
1295       Nodes.Table (Node).Link := Union_Id (To);
1296    end Set_List_Link;
1297
1298    --------------
1299    -- Set_Next --
1300    --------------
1301
1302    procedure Set_Next (Node : Node_Id; To : Node_Id) is
1303    begin
1304       Next_Node.Table (Node) := To;
1305    end Set_Next;
1306
1307    ----------------
1308    -- Set_Parent --
1309    ----------------
1310
1311    procedure Set_Parent (List : List_Id; Node : Node_Id) is
1312    begin
1313       pragma Assert (List <= Lists.Last);
1314       Lists.Table (List).Parent := Node;
1315    end Set_Parent;
1316
1317    --------------
1318    -- Set_Prev --
1319    --------------
1320
1321    procedure Set_Prev (Node : Node_Id; To : Node_Id) is
1322    begin
1323       Prev_Node.Table (Node) := To;
1324    end Set_Prev;
1325
1326    ---------------
1327    -- Tree_Read --
1328    ---------------
1329
1330    procedure Tree_Read is
1331    begin
1332       Lists.Tree_Read;
1333       Next_Node.Tree_Read;
1334       Prev_Node.Tree_Read;
1335    end Tree_Read;
1336
1337    ----------------
1338    -- Tree_Write --
1339    ----------------
1340
1341    procedure Tree_Write is
1342    begin
1343       Lists.Tree_Write;
1344       Next_Node.Tree_Write;
1345       Prev_Node.Tree_Write;
1346    end Tree_Write;
1347
1348    ------------
1349    -- Unlock --
1350    ------------
1351
1352    procedure Unlock is
1353    begin
1354       Lists.Locked := False;
1355       Prev_Node.Locked := False;
1356       Next_Node.Locked := False;
1357    end Unlock;
1358
1359 end Nlists;