gcc/ada/nlists.adb

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