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