gcc/ada/sem_elim.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ E L I M                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.13 $
  10 --                                                                          --
  11 --          Copyright (C) 1997-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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;   use Atree;
  30 with Einfo;   use Einfo;
  31 with Errout;  use Errout;
  32 with Namet;   use Namet;
  33 with Nlists;  use Nlists;
  34 with Sinfo;   use Sinfo;
  35 with Snames;  use Snames;
  36 with Stand;   use Stand;
  37 with Stringt; use Stringt;
  38
  39 with GNAT.HTable; use GNAT.HTable;
  40 package body Sem_Elim is
  41
  42    No_Elimination : Boolean;
  43    --  Set True if no Eliminate pragmas active
  44
  45    ---------------------
  46    -- Data Structures --
  47    ---------------------
  48
  49    --  A single pragma Eliminate is represented by the following record
  50
  51    type Elim_Data;
  52    type Access_Elim_Data is access Elim_Data;
  53
  54    type Names is array (Nat range <>) of Name_Id;
  55    --  Type used to represent set of names. Used for names in Unit_Name
  56    --  and also the set of names in Argument_Types.
  57
  58    type Access_Names is access Names;
  59
  60    type Elim_Data is record
  61
  62       Unit_Name : Access_Names;
  63       --  Unit name, broken down into a set of names (e.g. A.B.C is
  64       --  represented as Name_Id values for A, B, C in sequence).
  65
  66       Entity_Name : Name_Id;
  67       --  Entity name if Entity parameter if present. If no Entity parameter
  68       --  was supplied, then Entity_Node is set to Empty, and the Entity_Name
  69       --  field contains the last identifier name in the Unit_Name.
  70
  71       Entity_Scope : Access_Names;
  72       --  Static scope of the entity within the compilation unit represented by
  73       --  Unit_Name.
  74
  75       Entity_Node : Node_Id;
  76       --  Save node of entity argument, for posting error messages. Set
  77       --  to Empty if there is no entity argument.
  78
  79       Parameter_Types : Access_Names;
  80       --  Set to set of names given for parameter types. If no parameter
  81       --  types argument is present, this argument is set to null.
  82
  83       Result_Type : Name_Id;
  84       --  Result type name if Result_Types parameter present, No_Name if not
  85
  86       Hash_Link : Access_Elim_Data;
  87       --  Link for hash table use
  88
  89       Homonym : Access_Elim_Data;
  90       --  Pointer to next entry with same key
  91
  92    end record;
  93
  94    ----------------
  95    -- Hash_Table --
  96    ----------------
  97
  98    --  Setup hash table using the Entity_Name field as the hash key
  99
 100    subtype Element is Elim_Data;
 101    subtype Elmt_Ptr is Access_Elim_Data;
 102
 103    subtype Key is Name_Id;
 104
 105    type Header_Num is range 0 .. 1023;
 106
 107    Null_Ptr : constant Elmt_Ptr := null;
 108
 109    ----------------------
 110    -- Hash_Subprograms --
 111    ----------------------
 112
 113    package Hash_Subprograms is
 114
 115       function Equal (F1, F2 : Key) return Boolean;
 116       pragma Inline (Equal);
 117
 118       function Get_Key (E : Elmt_Ptr) return Key;
 119       pragma Inline (Get_Key);
 120
 121       function Hash (F : Key) return Header_Num;
 122       pragma Inline (Hash);
 123
 124       function Next (E : Elmt_Ptr) return Elmt_Ptr;
 125       pragma Inline (Next);
 126
 127       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 128       pragma Inline (Set_Next);
 129
 130    end Hash_Subprograms;
 131
 132    package body Hash_Subprograms is
 133
 134       -----------
 135       -- Equal --
 136       -----------
 137
 138       function Equal (F1, F2 : Key) return Boolean is
 139       begin
 140          return F1 = F2;
 141       end Equal;
 142
 143       -------------
 144       -- Get_Key --
 145       -------------
 146
 147       function Get_Key (E : Elmt_Ptr) return Key is
 148       begin
 149          return E.Entity_Name;
 150       end Get_Key;
 151
 152       ----------
 153       -- Hash --
 154       ----------
 155
 156       function Hash (F : Key) return Header_Num is
 157       begin
 158          return Header_Num (Int (F) mod 1024);
 159       end Hash;
 160
 161       ----------
 162       -- Next --
 163       ----------
 164
 165       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 166       begin
 167          return E.Hash_Link;
 168       end Next;
 169
 170       --------------
 171       -- Set_Next --
 172       --------------
 173
 174       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 175       begin
 176          E.Hash_Link := Next;
 177       end Set_Next;
 178    end Hash_Subprograms;
 179
 180    package Elim_Hash_Table is new Static_HTable (
 181       Header_Num => Header_Num,
 182       Element    => Element,
 183       Elmt_Ptr   => Elmt_Ptr,
 184       Null_Ptr   => Null_Ptr,
 185       Set_Next   => Hash_Subprograms.Set_Next,
 186       Next       => Hash_Subprograms.Next,
 187       Key        => Key,
 188       Get_Key    => Hash_Subprograms.Get_Key,
 189       Hash       => Hash_Subprograms.Hash,
 190       Equal      => Hash_Subprograms.Equal);
 191
 192    ----------------------
 193    -- Check_Eliminated --
 194    ----------------------
 195
 196    procedure Check_Eliminated (E : Entity_Id) is
 197       Elmt : Access_Elim_Data;
 198       Scop : Entity_Id;
 199       Form : Entity_Id;
 200
 201    begin
 202       if No_Elimination then
 203          return;
 204
 205       --  Elimination of objects and types is not implemented yet.
 206
 207       elsif Ekind (E) not in Subprogram_Kind then
 208          return;
 209       end if;
 210
 211       Elmt := Elim_Hash_Table.Get (Chars (E));
 212
 213       --  Loop through homonyms for this key
 214
 215       while Elmt /= null loop
 216
 217          --  First we check that the name of the entity matches
 218
 219          if Elmt.Entity_Name /= Chars (E) then
 220             goto Continue;
 221          end if;
 222
 223          --  Then we need to see if the static scope matches within the
 224          --  compilation unit.
 225
 226          Scop := Scope (E);
 227          if Elmt.Entity_Scope /= null then
 228             for J in reverse Elmt.Entity_Scope'Range loop
 229                if Elmt.Entity_Scope (J) /= Chars (Scop) then
 230                   goto Continue;
 231                end if;
 232
 233                Scop := Scope (Scop);
 234
 235                if not Is_Compilation_Unit (Scop) and then J = 1 then
 236                   goto Continue;
 237                end if;
 238             end loop;
 239          end if;
 240
 241          --  Now see if compilation unit matches
 242
 243          for J in reverse Elmt.Unit_Name'Range loop
 244             if Elmt.Unit_Name (J) /= Chars (Scop) then
 245                goto Continue;
 246             end if;
 247
 248             Scop := Scope (Scop);
 249
 250             if Scop /= Standard_Standard and then J = 1 then
 251                goto Continue;
 252             end if;
 253          end loop;
 254
 255          if Scop /= Standard_Standard then
 256             goto Continue;
 257          end if;
 258
 259          --  Check for case of given entity is a library level subprogram
 260          --  and we have the single parameter Eliminate case, a match!
 261
 262          if Is_Compilation_Unit (E)
 263            and then Is_Subprogram (E)
 264            and then No (Elmt.Entity_Node)
 265          then
 266             Set_Is_Eliminated (E);
 267             return;
 268
 269          --  Check for case of type or object with two parameter case
 270
 271          elsif (Is_Type (E) or else Is_Object (E))
 272            and then Elmt.Result_Type = No_Name
 273            and then Elmt.Parameter_Types = null
 274          then
 275             Set_Is_Eliminated (E);
 276             return;
 277
 278          --  Check for case of subprogram
 279
 280          elsif Ekind (E) = E_Function
 281            or else Ekind (E) = E_Procedure
 282          then
 283             --  Two parameter case always matches
 284
 285             if Elmt.Result_Type = No_Name
 286               and then Elmt.Parameter_Types = null
 287             then
 288                Set_Is_Eliminated (E);
 289                return;
 290
 291             --  Here we have a profile, so see if it matches
 292
 293             else
 294                if Ekind (E) = E_Function then
 295                   if Chars (Etype (E)) /= Elmt.Result_Type then
 296                      goto Continue;
 297                   end if;
 298                end if;
 299
 300                Form := First_Formal (E);
 301
 302                if No (Form) and then Elmt.Parameter_Types = null then
 303                   Set_Is_Eliminated (E);
 304                   return;
 305
 306                elsif Elmt.Parameter_Types = null then
 307                   goto Continue;
 308
 309                else
 310                   for J in Elmt.Parameter_Types'Range loop
 311                      if No (Form)
 312                        or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
 313                      then
 314                         goto Continue;
 315                      else
 316                         Next_Formal (Form);
 317                      end if;
 318                   end loop;
 319
 320                   if Present (Form) then
 321                      goto Continue;
 322                   else
 323                      Set_Is_Eliminated (E);
 324                      return;
 325                   end if;
 326                end if;
 327             end if;
 328          end if;
 329
 330          <<Continue>> Elmt := Elmt.Homonym;
 331       end loop;
 332
 333       return;
 334    end Check_Eliminated;
 335
 336    ----------------
 337    -- Initialize --
 338    ----------------
 339
 340    procedure Initialize is
 341    begin
 342       Elim_Hash_Table.Reset;
 343       No_Elimination := True;
 344    end Initialize;
 345
 346    ------------------------------
 347    -- Process_Eliminate_Pragma --
 348    ------------------------------
 349
 350    procedure Process_Eliminate_Pragma
 351      (Arg_Unit_Name       : Node_Id;
 352       Arg_Entity          : Node_Id;
 353       Arg_Parameter_Types : Node_Id;
 354       Arg_Result_Type     : Node_Id)
 355    is
 356       Argx_Unit_Name       : Node_Id;
 357       Argx_Entity          : Node_Id;
 358       Argx_Parameter_Types : Node_Id;
 359       Argx_Result_Type     : Node_Id;
 360
 361       Data : constant Access_Elim_Data := new Elim_Data;
 362       --  Build result data here
 363
 364       Elmt : Access_Elim_Data;
 365
 366       Num_Names : Nat := 0;
 367       --  Number of names in unit name
 368
 369       Lit : Node_Id;
 370
 371       function OK_Selected_Component (N : Node_Id) return Boolean;
 372       --  Test if N is a selected component with all identifiers, or a
 373       --  selected component whose selector is an operator symbol. As a
 374       --  side effect if result is True, sets Num_Names to the number
 375       --  of names present (identifiers and operator if any).
 376
 377       ---------------------------
 378       -- OK_Selected_Component --
 379       ---------------------------
 380
 381       function OK_Selected_Component (N : Node_Id) return Boolean is
 382       begin
 383          if Nkind (N) = N_Identifier
 384            or else Nkind (N) = N_Operator_Symbol
 385          then
 386             Num_Names := Num_Names + 1;
 387             return True;
 388
 389          elsif Nkind (N) = N_Selected_Component then
 390             return OK_Selected_Component (Prefix (N))
 391               and then OK_Selected_Component (Selector_Name (N));
 392
 393          else
 394             return False;
 395          end if;
 396       end OK_Selected_Component;
 397
 398    --  Start of processing for Process_Eliminate_Pragma
 399
 400    begin
 401       Error_Msg_Name_1 := Name_Eliminate;
 402
 403       --  Process Unit_Name argument
 404
 405       Argx_Unit_Name := Expression (Arg_Unit_Name);
 406
 407       if Nkind (Argx_Unit_Name) = N_Identifier then
 408          Data.Unit_Name := new Names'(1 => Chars (Argx_Unit_Name));
 409          Num_Names := 1;
 410
 411       elsif OK_Selected_Component (Argx_Unit_Name) then
 412          Data.Unit_Name := new Names (1 .. Num_Names);
 413
 414          for J in reverse 2 .. Num_Names loop
 415             Data.Unit_Name (J) := Chars (Selector_Name (Argx_Unit_Name));
 416             Argx_Unit_Name := Prefix (Argx_Unit_Name);
 417          end loop;
 418
 419          Data.Unit_Name (1) := Chars (Argx_Unit_Name);
 420
 421       else
 422          Error_Msg_N
 423            ("wrong form for Unit_Name parameter of pragma%",
 424             Argx_Unit_Name);
 425          return;
 426       end if;
 427
 428       --  Process Entity argument
 429
 430       if Present (Arg_Entity) then
 431          Argx_Entity := Expression (Arg_Entity);
 432          Num_Names := 0;
 433
 434          if Nkind (Argx_Entity) = N_Identifier
 435            or else Nkind (Argx_Entity) = N_Operator_Symbol
 436          then
 437             Data.Entity_Name  := Chars (Argx_Entity);
 438             Data.Entity_Node  := Argx_Entity;
 439             Data.Entity_Scope := null;
 440
 441          elsif OK_Selected_Component (Argx_Entity) then
 442             Data.Entity_Scope := new Names (1 .. Num_Names - 1);
 443             Data.Entity_Name  := Chars (Selector_Name (Argx_Entity));
 444             Data.Entity_Node  := Argx_Entity;
 445
 446             Argx_Entity := Prefix (Argx_Entity);
 447             for J in reverse 2 .. Num_Names - 1 loop
 448                Data.Entity_Scope (J) := Chars (Selector_Name (Argx_Entity));
 449                Argx_Entity := Prefix (Argx_Entity);
 450             end loop;
 451
 452             Data.Entity_Scope (1) := Chars (Argx_Entity);
 453
 454          elsif Nkind (Argx_Entity) = N_String_Literal then
 455             String_To_Name_Buffer (Strval (Argx_Entity));
 456             Data.Entity_Name := Name_Find;
 457             Data.Entity_Node := Argx_Entity;
 458
 459          else
 460             Error_Msg_N
 461               ("wrong form for Entity_Argument parameter of pragma%",
 462               Argx_Unit_Name);
 463             return;
 464          end if;
 465       else
 466          Data.Entity_Node := Empty;
 467          Data.Entity_Name := Data.Unit_Name (Num_Names);
 468       end if;
 469
 470       --  Process Parameter_Types argument
 471
 472       if Present (Arg_Parameter_Types) then
 473          Argx_Parameter_Types := Expression (Arg_Parameter_Types);
 474
 475          --  Case of one name, which looks like a parenthesized literal
 476          --  rather than an aggregate.
 477
 478          if Nkind (Argx_Parameter_Types) = N_String_Literal
 479            and then Paren_Count (Argx_Parameter_Types) = 1
 480          then
 481             String_To_Name_Buffer (Strval (Argx_Parameter_Types));
 482             Data.Parameter_Types := new Names'(1 => Name_Find);
 483
 484          --  Otherwise must be an aggregate
 485
 486          elsif Nkind (Argx_Parameter_Types) /= N_Aggregate
 487            or else Present (Component_Associations (Argx_Parameter_Types))
 488            or else No (Expressions (Argx_Parameter_Types))
 489          then
 490             Error_Msg_N
 491               ("Parameter_Types for pragma% must be list of string literals",
 492                Argx_Parameter_Types);
 493             return;
 494
 495          --  Here for aggregate case
 496
 497          else
 498             Data.Parameter_Types :=
 499               new Names
 500                 (1 .. List_Length (Expressions (Argx_Parameter_Types)));
 501
 502             Lit := First (Expressions (Argx_Parameter_Types));
 503             for J in Data.Parameter_Types'Range loop
 504                if Nkind (Lit) /= N_String_Literal then
 505                   Error_Msg_N
 506                     ("parameter types for pragma% must be string literals",
 507                      Lit);
 508                   return;
 509                end if;
 510
 511                String_To_Name_Buffer (Strval (Lit));
 512                Data.Parameter_Types (J) := Name_Find;
 513                Next (Lit);
 514             end loop;
 515          end if;
 516       end if;
 517
 518       --  Process Result_Types argument
 519
 520       if Present (Arg_Result_Type) then
 521          Argx_Result_Type := Expression (Arg_Result_Type);
 522
 523          if Nkind (Argx_Result_Type) /= N_String_Literal then
 524             Error_Msg_N
 525               ("Result_Type argument for pragma% must be string literal",
 526                Argx_Result_Type);
 527             return;
 528          end if;
 529
 530          String_To_Name_Buffer (Strval (Argx_Result_Type));
 531          Data.Result_Type := Name_Find;
 532
 533       else
 534          Data.Result_Type := No_Name;
 535       end if;
 536
 537       --  Now link this new entry into the hash table
 538
 539       Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
 540
 541       --  If we already have an entry with this same key, then link
 542       --  it into the chain of entries for this key.
 543
 544       if Elmt /= null then
 545          Data.Homonym := Elmt.Homonym;
 546          Elmt.Homonym := Data;
 547
 548       --  Otherwise create a new entry
 549
 550       else
 551          Elim_Hash_Table.Set (Data);
 552       end if;
 553
 554       No_Elimination := False;
 555    end Process_Eliminate_Pragma;
 556
 557 end Sem_Elim;