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