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