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