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