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-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
  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'Base,
  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_Or_Entity_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'Base,
 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 (N : Node_Or_Entity_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 := N;
 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_Or_Entity_Id = ");
 138          Write_Int (Int (N));
 139          Write_Eol;
 140       end if;
 141    end Append_Elmt;
 142
 143    ------------------------
 144    -- Append_Unique_Elmt --
 145    ------------------------
 146
 147    procedure Append_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is
 148       Elmt : Elmt_Id;
 149    begin
 150       Elmt := First_Elmt (To);
 151       loop
 152          if No (Elmt) then
 153             Append_Elmt (N, To);
 154             return;
 155          elsif Node (Elmt) = N then
 156             return;
 157          else
 158             Next_Elmt (Elmt);
 159          end if;
 160       end loop;
 161    end Append_Unique_Elmt;
 162
 163    --------------------
 164    -- Elists_Address --
 165    --------------------
 166
 167    function Elists_Address return System.Address is
 168    begin
 169       return Elists.Table (First_Elist_Id)'Address;
 170    end Elists_Address;
 171
 172    -------------------
 173    -- Elmts_Address --
 174    -------------------
 175
 176    function Elmts_Address return System.Address is
 177    begin
 178       return Elmts.Table (First_Elmt_Id)'Address;
 179    end Elmts_Address;
 180
 181    ----------------
 182    -- First_Elmt --
 183    ----------------
 184
 185    function First_Elmt (List : Elist_Id) return Elmt_Id is
 186    begin
 187       pragma Assert (List > Elist_Low_Bound);
 188       return Elists.Table (List).First;
 189    end First_Elmt;
 190
 191    ----------------
 192    -- Initialize --
 193    ----------------
 194
 195    procedure Initialize is
 196    begin
 197       Elists.Init;
 198       Elmts.Init;
 199    end Initialize;
 200
 201    -----------------------
 202    -- Insert_Elmt_After --
 203    -----------------------
 204
 205    procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id) is
 206       Nxt : constant Union_Id := Elmts.Table (Elmt).Next;
 207
 208    begin
 209       pragma Assert (Elmt /= No_Elmt);
 210
 211       Elmts.Increment_Last;
 212       Elmts.Table (Elmts.Last).Node := N;
 213       Elmts.Table (Elmts.Last).Next := Nxt;
 214
 215       Elmts.Table (Elmt).Next := Union_Id (Elmts.Last);
 216
 217       if Nxt in Elist_Range then
 218          Elists.Table (Elist_Id (Nxt)).Last := Elmts.Last;
 219       end if;
 220    end Insert_Elmt_After;
 221
 222    ------------------------
 223    -- Is_Empty_Elmt_List --
 224    ------------------------
 225
 226    function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is
 227    begin
 228       return Elists.Table (List).First = No_Elmt;
 229    end Is_Empty_Elmt_List;
 230
 231    -------------------
 232    -- Last_Elist_Id --
 233    -------------------
 234
 235    function Last_Elist_Id return Elist_Id is
 236    begin
 237       return Elists.Last;
 238    end Last_Elist_Id;
 239
 240    ---------------
 241    -- Last_Elmt --
 242    ---------------
 243
 244    function Last_Elmt (List : Elist_Id) return Elmt_Id is
 245    begin
 246       return Elists.Table (List).Last;
 247    end Last_Elmt;
 248
 249    ------------------
 250    -- Last_Elmt_Id --
 251    ------------------
 252
 253    function Last_Elmt_Id return Elmt_Id is
 254    begin
 255       return Elmts.Last;
 256    end Last_Elmt_Id;
 257
 258    ----------
 259    -- Lock --
 260    ----------
 261
 262    procedure Lock is
 263    begin
 264       Elists.Locked := True;
 265       Elmts.Locked := True;
 266       Elists.Release;
 267       Elmts.Release;
 268    end Lock;
 269
 270    -------------------
 271    -- New_Elmt_List --
 272    -------------------
 273
 274    function New_Elmt_List return Elist_Id is
 275    begin
 276       Elists.Increment_Last;
 277       Elists.Table (Elists.Last).First := No_Elmt;
 278       Elists.Table (Elists.Last).Last  := No_Elmt;
 279
 280       if Debug_Flag_N then
 281          Write_Str ("Allocate new element list, returned ID = ");
 282          Write_Int (Int (Elists.Last));
 283          Write_Eol;
 284       end if;
 285
 286       return Elists.Last;
 287    end New_Elmt_List;
 288
 289    ---------------
 290    -- Next_Elmt --
 291    ---------------
 292
 293    function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is
 294       N : constant Union_Id := Elmts.Table (Elmt).Next;
 295
 296    begin
 297       if N in Elist_Range then
 298          return No_Elmt;
 299       else
 300          return Elmt_Id (N);
 301       end if;
 302    end Next_Elmt;
 303
 304    procedure Next_Elmt (Elmt : in out Elmt_Id) is
 305    begin
 306       Elmt := Next_Elmt (Elmt);
 307    end Next_Elmt;
 308
 309    --------
 310    -- No --
 311    --------
 312
 313    function No (List : Elist_Id) return Boolean is
 314    begin
 315       return List = No_Elist;
 316    end No;
 317
 318    function No (Elmt : Elmt_Id) return Boolean is
 319    begin
 320       return Elmt = No_Elmt;
 321    end No;
 322
 323    ----------
 324    -- Node --
 325    ----------
 326
 327    function Node (Elmt : Elmt_Id) return Node_Or_Entity_Id is
 328    begin
 329       if Elmt = No_Elmt then
 330          return Empty;
 331       else
 332          return Elmts.Table (Elmt).Node;
 333       end if;
 334    end Node;
 335
 336    ----------------
 337    -- Num_Elists --
 338    ----------------
 339
 340    function Num_Elists return Nat is
 341    begin
 342       return Int (Elmts.Last) - Int (Elmts.First) + 1;
 343    end Num_Elists;
 344
 345    ------------------
 346    -- Prepend_Elmt --
 347    ------------------
 348
 349    procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is
 350       F : constant Elmt_Id := Elists.Table (To).First;
 351
 352    begin
 353       Elmts.Increment_Last;
 354       Elmts.Table (Elmts.Last).Node := N;
 355
 356       if F = No_Elmt then
 357          Elists.Table (To).Last := Elmts.Last;
 358          Elmts.Table (Elmts.Last).Next := Union_Id (To);
 359       else
 360          Elmts.Table (Elmts.Last).Next := Union_Id (F);
 361       end if;
 362
 363       Elists.Table (To).First  := Elmts.Last;
 364    end Prepend_Elmt;
 365
 366    -------------
 367    -- Present --
 368    -------------
 369
 370    function Present (List : Elist_Id) return Boolean is
 371    begin
 372       return List /= No_Elist;
 373    end Present;
 374
 375    function Present (Elmt : Elmt_Id) return Boolean is
 376    begin
 377       return Elmt /= No_Elmt;
 378    end Present;
 379
 380    -----------------
 381    -- Remove_Elmt --
 382    -----------------
 383
 384    procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is
 385       Nxt : Elmt_Id;
 386       Prv : Elmt_Id;
 387
 388    begin
 389       Nxt := Elists.Table (List).First;
 390
 391       --  Case of removing only element in the list
 392
 393       if Elmts.Table (Nxt).Next in Elist_Range then
 394
 395          pragma Assert (Nxt = Elmt);
 396
 397          Elists.Table (List).First := No_Elmt;
 398          Elists.Table (List).Last  := No_Elmt;
 399
 400       --  Case of removing the first element in the list
 401
 402       elsif Nxt = Elmt then
 403          Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next);
 404
 405       --  Case of removing second or later element in the list
 406
 407       else
 408          loop
 409             Prv := Nxt;
 410             Nxt := Elmt_Id (Elmts.Table (Prv).Next);
 411             exit when Nxt = Elmt
 412               or else Elmts.Table (Nxt).Next in Elist_Range;
 413          end loop;
 414
 415          pragma Assert (Nxt = Elmt);
 416
 417          Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next;
 418
 419          if Elmts.Table (Prv).Next in Elist_Range then
 420             Elists.Table (List).Last := Prv;
 421          end if;
 422       end if;
 423    end Remove_Elmt;
 424
 425    ----------------------
 426    -- Remove_Last_Elmt --
 427    ----------------------
 428
 429    procedure Remove_Last_Elmt (List : Elist_Id) is
 430       Nxt : Elmt_Id;
 431       Prv : Elmt_Id;
 432
 433    begin
 434       Nxt := Elists.Table (List).First;
 435
 436       --  Case of removing only element in the list
 437
 438       if Elmts.Table (Nxt).Next in Elist_Range then
 439          Elists.Table (List).First := No_Elmt;
 440          Elists.Table (List).Last  := No_Elmt;
 441
 442       --  Case of at least two elements in list
 443
 444       else
 445          loop
 446             Prv := Nxt;
 447             Nxt := Elmt_Id (Elmts.Table (Prv).Next);
 448             exit when Elmts.Table (Nxt).Next in Elist_Range;
 449          end loop;
 450
 451          Elmts.Table (Prv).Next   := Elmts.Table (Nxt).Next;
 452          Elists.Table (List).Last := Prv;
 453       end if;
 454    end Remove_Last_Elmt;
 455
 456    ------------------
 457    -- Replace_Elmt --
 458    ------------------
 459
 460    procedure Replace_Elmt (Elmt : Elmt_Id; New_Node : Node_Or_Entity_Id) is
 461    begin
 462       Elmts.Table (Elmt).Node := New_Node;
 463    end Replace_Elmt;
 464
 465    ---------------
 466    -- Tree_Read --
 467    ---------------
 468
 469    procedure Tree_Read is
 470    begin
 471       Elists.Tree_Read;
 472       Elmts.Tree_Read;
 473    end Tree_Read;
 474
 475    ----------------
 476    -- Tree_Write --
 477    ----------------
 478
 479    procedure Tree_Write is
 480    begin
 481       Elists.Tree_Write;
 482       Elmts.Tree_Write;
 483    end Tree_Write;
 484
 485    ------------
 486    -- Unlock --
 487    ------------
 488
 489    procedure Unlock is
 490    begin
 491       Elists.Locked := False;
 492       Elmts.Locked := False;
 493    end Unlock;
 494
 495 end Elists;