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