gcc/ada/elists.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               E L I S T S                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2006, 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
  35 --  source file must be properly reflected in the C header a-elists.h.
  36
  37 with Alloc;
  38 with Debug;  use Debug;
  39 with Output; use Output;
  40 with Table;
  41
  42 package body Elists is
  43
  44    -------------------------------------
  45    -- Implementation of Element Lists --
  46    -------------------------------------
  47
  48    --  Element lists are composed of three types of entities. The element
  49    --  list header, which references the first and last elements of the
  50    --  list, the elements themselves which are singly linked and also
  51    --  reference the nodes on the list, and finally the nodes themselves.
  52    --  The following diagram shows how an element list is represented:
  53
  54    --       +----------------------------------------------------+
  55    --       |  +------------------------------------------+      |
  56    --       |  |                                          |      |
  57    --       V  |                                          V      |
  58    --    +-----|--+    +-------+    +-------+         +-------+  |
  59    --    |  Elmt  |    |  1st  |    |  2nd  |         |  Last |  |
  60    --    |  List  |--->|  Elmt |--->|  Elmt  ---...-->|  Elmt ---+
  61    --    | Header |    |   |   |    |   |   |         |   |   |
  62    --    +--------+    +---|---+    +---|---+         +---|---+
  63    --                      |            |                 |
  64    --                      V            V                 V
  65    --                  +-------+    +-------+         +-------+
  66    --                  |       |    |       |         |       |
  67    --                  | Node1 |    | Node2 |         | Node3 |
  68    --                  |       |    |       |         |       |
  69    --                  +-------+    +-------+         +-------+
  70
  71    --  The list header is an entry in the Elists table. The values used for
  72    --  the type Elist_Id are subscripts into this table. The First_Elmt field
  73    --  (Lfield1) points to the first element on the list, or to No_Elmt in the
  74    --  case of an empty list. Similarly the Last_Elmt field (Lfield2) points to
  75    --  the last element on the list or to No_Elmt in the case of an empty list.
  76
  77    --  The elements themselves are entries in the Elmts table. The Next field
  78    --  of each entry points to the next element, or to the Elist header if this
  79    --  is the last item in the list. The Node field points to the node which
  80    --  is referenced by the corresponding list entry.
  81
  82    -------------------------
  83    -- Element List Tables --
  84    -------------------------
  85
  86    type Elist_Header is record
  87       First : Elmt_Id;
  88       Last  : Elmt_Id;
  89    end record;
  90
  91    package Elists is new Table.Table (
  92      Table_Component_Type => Elist_Header,
  93      Table_Index_Type     => Elist_Id,
  94      Table_Low_Bound      => First_Elist_Id,
  95      Table_Initial        => Alloc.Elists_Initial,
  96      Table_Increment      => Alloc.Elists_Increment,
  97      Table_Name           => "Elists");
  98
  99    type Elmt_Item is record
 100       Node : Node_Id;
 101       Next : Union_Id;
 102    end record;
 103
 104    package Elmts is new Table.Table (
 105      Table_Component_Type => Elmt_Item,
 106      Table_Index_Type     => Elmt_Id,
 107      Table_Low_Bound      => First_Elmt_Id,
 108      Table_Initial        => Alloc.Elmts_Initial,
 109      Table_Increment      => Alloc.Elmts_Increment,
 110      Table_Name           => "Elmts");
 111
 112    -----------------
 113    -- Append_Elmt --
 114    -----------------
 115
 116    procedure Append_Elmt (Node : Node_Id; To : Elist_Id) is
 117       L : constant Elmt_Id := Elists.Table (To).Last;
 118
 119    begin
 120       Elmts.Increment_Last;
 121       Elmts.Table (Elmts.Last).Node := Node;
 122       Elmts.Table (Elmts.Last).Next := Union_Id (To);
 123
 124       if L = No_Elmt then
 125          Elists.Table (To).First := Elmts.Last;
 126       else
 127          Elmts.Table (L).Next := Union_Id (Elmts.Last);
 128       end if;
 129
 130       Elists.Table (To).Last  := Elmts.Last;
 131
 132       if Debug_Flag_N then
 133          Write_Str ("Append new element Elmt_Id = ");
 134          Write_Int (Int (Elmts.Last));
 135          Write_Str (" to list Elist_Id = ");
 136          Write_Int (Int (To));
 137          Write_Str (" referencing Node_Id = ");
 138          Write_Int (Int (Node));
 139          Write_Eol;
 140       end if;
 141    end Append_Elmt;
 142
 143    --------------------
 144    -- Elists_Address --
 145    --------------------
 146
 147    function Elists_Address return System.Address is
 148    begin
 149       return Elists.Table (First_Elist_Id)'Address;
 150    end Elists_Address;
 151
 152    -------------------
 153    -- Elmts_Address --
 154    -------------------
 155
 156    function Elmts_Address return System.Address is
 157    begin
 158       return Elmts.Table (First_Elmt_Id)'Address;
 159    end Elmts_Address;
 160
 161    ----------------
 162    -- First_Elmt --
 163    ----------------
 164
 165    function First_Elmt (List : Elist_Id) return Elmt_Id is
 166    begin
 167       pragma Assert (List > Elist_Low_Bound);
 168       return Elists.Table (List).First;
 169    end First_Elmt;
 170
 171    ----------------
 172    -- Initialize --
 173    ----------------
 174
 175    procedure Initialize is
 176    begin
 177       Elists.Init;
 178       Elmts.Init;
 179    end Initialize;
 180
 181    -----------------------
 182    -- Insert_Elmt_After --
 183    -----------------------
 184
 185    procedure Insert_Elmt_After (Node : Node_Id; Elmt : Elmt_Id) is
 186       N : constant Union_Id := Elmts.Table (Elmt).Next;
 187
 188    begin
 189       pragma Assert (Elmt /= No_Elmt);
 190
 191       Elmts.Increment_Last;
 192       Elmts.Table (Elmts.Last).Node := Node;
 193       Elmts.Table (Elmts.Last).Next := N;
 194
 195       Elmts.Table (Elmt).Next := Union_Id (Elmts.Last);
 196
 197       if N in Elist_Range then
 198          Elists.Table (Elist_Id (N)).Last := Elmts.Last;
 199       end if;
 200    end Insert_Elmt_After;
 201
 202    ------------------------
 203    -- Is_Empty_Elmt_List --
 204    ------------------------
 205
 206    function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is
 207    begin
 208       return Elists.Table (List).First = No_Elmt;
 209    end Is_Empty_Elmt_List;
 210
 211    -------------------
 212    -- Last_Elist_Id --
 213    -------------------
 214
 215    function Last_Elist_Id return Elist_Id is
 216    begin
 217       return Elists.Last;
 218    end Last_Elist_Id;
 219
 220    ---------------
 221    -- Last_Elmt --
 222    ---------------
 223
 224    function Last_Elmt (List : Elist_Id) return Elmt_Id is
 225    begin
 226       return Elists.Table (List).Last;
 227    end Last_Elmt;
 228
 229    ------------------
 230    -- Last_Elmt_Id --
 231    ------------------
 232
 233    function Last_Elmt_Id return Elmt_Id is
 234    begin
 235       return Elmts.Last;
 236    end Last_Elmt_Id;
 237
 238    ----------
 239    -- Lock --
 240    ----------
 241
 242    procedure Lock is
 243    begin
 244       Elists.Locked := True;
 245       Elmts.Locked := True;
 246       Elists.Release;
 247       Elmts.Release;
 248    end Lock;
 249
 250    -------------------
 251    -- New_Elmt_List --
 252    -------------------
 253
 254    function New_Elmt_List return Elist_Id is
 255    begin
 256       Elists.Increment_Last;
 257       Elists.Table (Elists.Last).First := No_Elmt;
 258       Elists.Table (Elists.Last).Last  := No_Elmt;
 259
 260       if Debug_Flag_N then
 261          Write_Str ("Allocate new element list, returned ID = ");
 262          Write_Int (Int (Elists.Last));
 263          Write_Eol;
 264       end if;
 265
 266       return Elists.Last;
 267    end New_Elmt_List;
 268
 269    ---------------
 270    -- Next_Elmt --
 271    ---------------
 272
 273    function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is
 274       N : constant Union_Id := Elmts.Table (Elmt).Next;
 275
 276    begin
 277       if N in Elist_Range then
 278          return No_Elmt;
 279       else
 280          return Elmt_Id (N);
 281       end if;
 282    end Next_Elmt;
 283
 284    procedure Next_Elmt (Elmt : in out Elmt_Id) is
 285    begin
 286       Elmt := Next_Elmt (Elmt);
 287    end Next_Elmt;
 288
 289    --------
 290    -- No --
 291    --------
 292
 293    function No (List : Elist_Id) return Boolean is
 294    begin
 295       return List = No_Elist;
 296    end No;
 297
 298    function No (Elmt : Elmt_Id) return Boolean is
 299    begin
 300       return Elmt = No_Elmt;
 301    end No;
 302
 303    ----------
 304    -- Node --
 305    ----------
 306
 307    function Node (Elmt : Elmt_Id) return Node_Or_Entity_Id is
 308    begin
 309       if Elmt = No_Elmt then
 310          return Empty;
 311       else
 312          return Elmts.Table (Elmt).Node;
 313       end if;
 314    end Node;
 315
 316    ----------------
 317    -- Num_Elists --
 318    ----------------
 319
 320    function Num_Elists return Nat is
 321    begin
 322       return Int (Elmts.Last) - Int (Elmts.First) + 1;
 323    end Num_Elists;
 324
 325    ------------------
 326    -- Prepend_Elmt --
 327    ------------------
 328
 329    procedure Prepend_Elmt (Node : Node_Id; To : Elist_Id) is
 330       F : constant Elmt_Id := Elists.Table (To).First;
 331
 332    begin
 333       Elmts.Increment_Last;
 334       Elmts.Table (Elmts.Last).Node := Node;
 335
 336       if F = No_Elmt then
 337          Elists.Table (To).Last := Elmts.Last;
 338          Elmts.Table (Elmts.Last).Next := Union_Id (To);
 339       else
 340          Elmts.Table (Elmts.Last).Next := Union_Id (F);
 341       end if;
 342
 343       Elists.Table (To).First  := Elmts.Last;
 344
 345    end Prepend_Elmt;
 346
 347    -------------
 348    -- Present --
 349    -------------
 350
 351    function Present (List : Elist_Id) return Boolean is
 352    begin
 353       return List /= No_Elist;
 354    end Present;
 355
 356    function Present (Elmt : Elmt_Id) return Boolean is
 357    begin
 358       return Elmt /= No_Elmt;
 359    end Present;
 360
 361    -----------------
 362    -- Remove_Elmt --
 363    -----------------
 364
 365    procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is
 366       Nxt : Elmt_Id;
 367       Prv : Elmt_Id;
 368
 369    begin
 370       Nxt := Elists.Table (List).First;
 371
 372       --  Case of removing only element in the list
 373
 374       if Elmts.Table (Nxt).Next in Elist_Range then
 375
 376          pragma Assert (Nxt = Elmt);
 377
 378          Elists.Table (List).First := No_Elmt;
 379          Elists.Table (List).Last  := No_Elmt;
 380
 381       --  Case of removing the first element in the list
 382
 383       elsif Nxt = Elmt then
 384          Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next);
 385
 386       --  Case of removing second or later element in the list
 387
 388       else
 389          loop
 390             Prv := Nxt;
 391             Nxt := Elmt_Id (Elmts.Table (Prv).Next);
 392             exit when Nxt = Elmt
 393               or else Elmts.Table (Nxt).Next in Elist_Range;
 394          end loop;
 395
 396          pragma Assert (Nxt = Elmt);
 397
 398          Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next;
 399
 400          if Elmts.Table (Prv).Next in Elist_Range then
 401             Elists.Table (List).Last := Prv;
 402          end if;
 403       end if;
 404    end Remove_Elmt;
 405
 406    ----------------------
 407    -- Remove_Last_Elmt --
 408    ----------------------
 409
 410    procedure Remove_Last_Elmt (List : Elist_Id) is
 411       Nxt : Elmt_Id;
 412       Prv : Elmt_Id;
 413
 414    begin
 415       Nxt := Elists.Table (List).First;
 416
 417       --  Case of removing only element in the list
 418
 419       if Elmts.Table (Nxt).Next in Elist_Range then
 420          Elists.Table (List).First := No_Elmt;
 421          Elists.Table (List).Last  := No_Elmt;
 422
 423       --  Case of at least two elements in list
 424
 425       else
 426          loop
 427             Prv := Nxt;
 428             Nxt := Elmt_Id (Elmts.Table (Prv).Next);
 429             exit when Elmts.Table (Nxt).Next in Elist_Range;
 430          end loop;
 431
 432          Elmts.Table (Prv).Next   := Elmts.Table (Nxt).Next;
 433          Elists.Table (List).Last := Prv;
 434       end if;
 435    end Remove_Last_Elmt;
 436
 437    ------------------
 438    -- Replace_Elmt --
 439    ------------------
 440
 441    procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Id) is
 442    begin
 443       Elmts.Table (Elmt).Node := New_Node;
 444    end Replace_Elmt;
 445
 446    ---------------
 447    -- Tree_Read --
 448    ---------------
 449
 450    procedure Tree_Read is
 451    begin
 452       Elists.Tree_Read;
 453       Elmts.Tree_Read;
 454    end Tree_Read;
 455
 456    ----------------
 457    -- Tree_Write --
 458    ----------------
 459
 460    procedure Tree_Write is
 461    begin
 462       Elists.Tree_Write;
 463       Elmts.Tree_Write;
 464    end Tree_Write;
 465
 466 end Elists;