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