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-2004 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
 190       pragma Assert (Elmt /= No_Elmt);
 191
 192       Elmts.Increment_Last;
 193       Elmts.Table (Elmts.Last).Node := Node;
 194       Elmts.Table (Elmts.Last).Next := N;
 195
 196       Elmts.Table (Elmt).Next := Union_Id (Elmts.Last);
 197
 198       if N in Elist_Range then
 199          Elists.Table (Elist_Id (N)).Last := Elmts.Last;
 200       end if;
 201    end Insert_Elmt_After;
 202
 203    ------------------------
 204    -- Is_Empty_Elmt_List --
 205    ------------------------
 206
 207    function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is
 208    begin
 209       return Elists.Table (List).First = No_Elmt;
 210    end Is_Empty_Elmt_List;
 211
 212    -------------------
 213    -- Last_Elist_Id --
 214    -------------------
 215
 216    function Last_Elist_Id return Elist_Id is
 217    begin
 218       return Elists.Last;
 219    end Last_Elist_Id;
 220
 221    ---------------
 222    -- Last_Elmt --
 223    ---------------
 224
 225    function Last_Elmt (List : Elist_Id) return Elmt_Id is
 226    begin
 227       return Elists.Table (List).Last;
 228    end Last_Elmt;
 229
 230    ------------------
 231    -- Last_Elmt_Id --
 232    ------------------
 233
 234    function Last_Elmt_Id return Elmt_Id is
 235    begin
 236       return Elmts.Last;
 237    end Last_Elmt_Id;
 238
 239    ----------
 240    -- Lock --
 241    ----------
 242
 243    procedure Lock is
 244    begin
 245       Elists.Locked := True;
 246       Elmts.Locked := True;
 247       Elists.Release;
 248       Elmts.Release;
 249    end Lock;
 250
 251    -------------------
 252    -- New_Elmt_List --
 253    -------------------
 254
 255    function New_Elmt_List return Elist_Id is
 256    begin
 257       Elists.Increment_Last;
 258       Elists.Table (Elists.Last).First := No_Elmt;
 259       Elists.Table (Elists.Last).Last  := No_Elmt;
 260
 261       if Debug_Flag_N then
 262          Write_Str ("Allocate new element list, returned ID = ");
 263          Write_Int (Int (Elists.Last));
 264          Write_Eol;
 265       end if;
 266
 267       return Elists.Last;
 268    end New_Elmt_List;
 269
 270    ---------------
 271    -- Next_Elmt --
 272    ---------------
 273
 274    function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is
 275       N : constant Union_Id := Elmts.Table (Elmt).Next;
 276
 277    begin
 278       if N in Elist_Range then
 279          return No_Elmt;
 280       else
 281          return Elmt_Id (N);
 282       end if;
 283    end Next_Elmt;
 284
 285    procedure Next_Elmt (Elmt : in out Elmt_Id) is
 286    begin
 287       Elmt := Next_Elmt (Elmt);
 288    end Next_Elmt;
 289
 290    --------
 291    -- No --
 292    --------
 293
 294    function No (List : Elist_Id) return Boolean is
 295    begin
 296       return List = No_Elist;
 297    end No;
 298
 299    function No (Elmt : Elmt_Id) return Boolean is
 300    begin
 301       return Elmt = No_Elmt;
 302    end No;
 303
 304    -----------
 305    -- Node --
 306    -----------
 307
 308    function Node (Elmt : Elmt_Id) return Node_Id is
 309    begin
 310       if Elmt = No_Elmt then
 311          return Empty;
 312       else
 313          return Elmts.Table (Elmt).Node;
 314       end if;
 315    end Node;
 316
 317    ----------------
 318    -- Num_Elists --
 319    ----------------
 320
 321    function Num_Elists return Nat is
 322    begin
 323       return Int (Elmts.Last) - Int (Elmts.First) + 1;
 324    end Num_Elists;
 325
 326    ------------------
 327    -- Prepend_Elmt --
 328    ------------------
 329
 330    procedure Prepend_Elmt (Node : Node_Id; To : Elist_Id) is
 331       F : constant Elmt_Id := Elists.Table (To).First;
 332
 333    begin
 334       Elmts.Increment_Last;
 335       Elmts.Table (Elmts.Last).Node := Node;
 336
 337       if F = No_Elmt then
 338          Elists.Table (To).Last := Elmts.Last;
 339          Elmts.Table (Elmts.Last).Next := Union_Id (To);
 340       else
 341          Elmts.Table (Elmts.Last).Next := Union_Id (F);
 342       end if;
 343
 344       Elists.Table (To).First  := Elmts.Last;
 345
 346    end Prepend_Elmt;
 347
 348    -------------
 349    -- Present --
 350    -------------
 351
 352    function Present (List : Elist_Id) return Boolean is
 353    begin
 354       return List /= No_Elist;
 355    end Present;
 356
 357    function Present (Elmt : Elmt_Id) return Boolean is
 358    begin
 359       return Elmt /= No_Elmt;
 360    end Present;
 361
 362    -----------------
 363    -- Remove_Elmt --
 364    -----------------
 365
 366    procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is
 367       Nxt : Elmt_Id;
 368       Prv : Elmt_Id;
 369
 370    begin
 371       Nxt := Elists.Table (List).First;
 372
 373       --  Case of removing only element in the list
 374
 375       if Elmts.Table (Nxt).Next in Elist_Range then
 376
 377          pragma Assert (Nxt = Elmt);
 378
 379          Elists.Table (List).First := No_Elmt;
 380          Elists.Table (List).Last  := No_Elmt;
 381
 382       --  Case of removing the first element in the list
 383
 384       elsif Nxt = Elmt then
 385          Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next);
 386
 387       --  Case of removing second or later element in the list
 388
 389       else
 390          loop
 391             Prv := Nxt;
 392             Nxt := Elmt_Id (Elmts.Table (Prv).Next);
 393             exit when Nxt = Elmt
 394               or else Elmts.Table (Nxt).Next in Elist_Range;
 395          end loop;
 396
 397          pragma Assert (Nxt = Elmt);
 398
 399          Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next;
 400
 401          if Elmts.Table (Prv).Next in Elist_Range then
 402             Elists.Table (List).Last := Prv;
 403          end if;
 404       end if;
 405    end Remove_Elmt;
 406
 407    ----------------------
 408    -- Remove_Last_Elmt --
 409    ----------------------
 410
 411    procedure Remove_Last_Elmt (List : Elist_Id) is
 412       Nxt : Elmt_Id;
 413       Prv : Elmt_Id;
 414
 415    begin
 416       Nxt := Elists.Table (List).First;
 417
 418       --  Case of removing only element in the list
 419
 420       if Elmts.Table (Nxt).Next in Elist_Range then
 421          Elists.Table (List).First := No_Elmt;
 422          Elists.Table (List).Last  := No_Elmt;
 423
 424       --  Case of at least two elements in list
 425
 426       else
 427          loop
 428             Prv := Nxt;
 429             Nxt := Elmt_Id (Elmts.Table (Prv).Next);
 430             exit when Elmts.Table (Nxt).Next in Elist_Range;
 431          end loop;
 432
 433          Elmts.Table (Prv).Next   := Elmts.Table (Nxt).Next;
 434          Elists.Table (List).Last := Prv;
 435       end if;
 436    end Remove_Last_Elmt;
 437
 438    ------------------
 439    -- Replace_Elmt --
 440    ------------------
 441
 442    procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Id) is
 443    begin
 444       Elmts.Table (Elmt).Node := New_Node;
 445    end Replace_Elmt;
 446
 447    ---------------
 448    -- Tree_Read --
 449    ---------------
 450
 451    procedure Tree_Read is
 452    begin
 453       Elists.Tree_Read;
 454       Elmts.Tree_Read;
 455    end Tree_Read;
 456
 457    ----------------
 458    -- Tree_Write --
 459    ----------------
 460
 461    procedure Tree_Write is
 462    begin
 463       Elists.Tree_Write;
 464       Elmts.Tree_Write;
 465    end Tree_Write;
 466
 467 end Elists;