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