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