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-2004 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 Sinput;  use Sinput;
  33 with Sinfo;   use Sinfo;
  34 with Snames;  use Snames;
  35 with Stand;   use Stand;
  36 with Stringt; use Stringt;
  37 with Table;
  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       Source_Location : Name_Id;
  87       --  String describing the source location of subprogram defining name if
  88       --  Source_Location parameter present, No_Name if not
  89
  90       Hash_Link : Access_Elim_Data;
  91       --  Link for hash table use
  92
  93       Homonym : Access_Elim_Data;
  94       --  Pointer to next entry with same key
  95
  96       Prag : Node_Id;
  97       --  Node_Id for Eliminate pragma
  98
  99    end record;
 100
 101    ----------------
 102    -- Hash_Table --
 103    ----------------
 104
 105    --  Setup hash table using the Entity_Name field as the hash key
 106
 107    subtype Element is Elim_Data;
 108    subtype Elmt_Ptr is Access_Elim_Data;
 109
 110    subtype Key is Name_Id;
 111
 112    type Header_Num is range 0 .. 1023;
 113
 114    Null_Ptr : constant Elmt_Ptr := null;
 115
 116    ----------------------
 117    -- Hash_Subprograms --
 118    ----------------------
 119
 120    package Hash_Subprograms is
 121
 122       function Equal (F1, F2 : Key) return Boolean;
 123       pragma Inline (Equal);
 124
 125       function Get_Key (E : Elmt_Ptr) return Key;
 126       pragma Inline (Get_Key);
 127
 128       function Hash (F : Key) return Header_Num;
 129       pragma Inline (Hash);
 130
 131       function Next (E : Elmt_Ptr) return Elmt_Ptr;
 132       pragma Inline (Next);
 133
 134       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 135       pragma Inline (Set_Next);
 136
 137    end Hash_Subprograms;
 138
 139    package body Hash_Subprograms is
 140
 141       -----------
 142       -- Equal --
 143       -----------
 144
 145       function Equal (F1, F2 : Key) return Boolean is
 146       begin
 147          return F1 = F2;
 148       end Equal;
 149
 150       -------------
 151       -- Get_Key --
 152       -------------
 153
 154       function Get_Key (E : Elmt_Ptr) return Key is
 155       begin
 156          return E.Entity_Name;
 157       end Get_Key;
 158
 159       ----------
 160       -- Hash --
 161       ----------
 162
 163       function Hash (F : Key) return Header_Num is
 164       begin
 165          return Header_Num (Int (F) mod 1024);
 166       end Hash;
 167
 168       ----------
 169       -- Next --
 170       ----------
 171
 172       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 173       begin
 174          return E.Hash_Link;
 175       end Next;
 176
 177       --------------
 178       -- Set_Next --
 179       --------------
 180
 181       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 182       begin
 183          E.Hash_Link := Next;
 184       end Set_Next;
 185    end Hash_Subprograms;
 186
 187    ------------
 188    -- Tables --
 189    ------------
 190
 191    --  The following table records the data for each pragmas, using the
 192    --  entity name as the hash key for retrieval. Entries in this table
 193    --  are set by Process_Eliminate_Pragma and read by Check_Eliminated.
 194
 195    package Elim_Hash_Table is new Static_HTable (
 196       Header_Num => Header_Num,
 197       Element    => Element,
 198       Elmt_Ptr   => Elmt_Ptr,
 199       Null_Ptr   => Null_Ptr,
 200       Set_Next   => Hash_Subprograms.Set_Next,
 201       Next       => Hash_Subprograms.Next,
 202       Key        => Key,
 203       Get_Key    => Hash_Subprograms.Get_Key,
 204       Hash       => Hash_Subprograms.Hash,
 205       Equal      => Hash_Subprograms.Equal);
 206
 207    --  The following table records entities for subprograms that are
 208    --  eliminated, and corresponding eliminate pragmas that caused the
 209    --  elimination. Entries in this table are set by Check_Eliminated
 210    --  and read by Eliminate_Error_Msg.
 211
 212    type Elim_Entity_Entry is record
 213       Prag : Node_Id;
 214       Subp : Entity_Id;
 215    end record;
 216
 217    package Elim_Entities is new Table.Table (
 218      Table_Component_Type => Elim_Entity_Entry,
 219      Table_Index_Type     => Name_Id,
 220      Table_Low_Bound      => First_Name_Id,
 221      Table_Initial        => 50,
 222      Table_Increment      => 200,
 223      Table_Name           => "Elim_Entries");
 224
 225    ----------------------
 226    -- Check_Eliminated --
 227    ----------------------
 228
 229    procedure Check_Eliminated (E : Entity_Id) is
 230       Elmt : Access_Elim_Data;
 231       Scop : Entity_Id;
 232       Form : Entity_Id;
 233
 234       function Original_Chars (S : Entity_Id) return Name_Id;
 235       --  If the candidate subprogram is a protected operation of a single
 236       --  protected object, the scope of the operation is the created
 237       --  protected type, and we have to retrieve the original name of
 238       --  the object.
 239
 240       --------------------
 241       -- Original_Chars --
 242       --------------------
 243
 244       function Original_Chars (S : Entity_Id) return Name_Id is
 245       begin
 246          if Ekind (S) /= E_Protected_Type
 247            or else Comes_From_Source (S)
 248          then
 249             return Chars (S);
 250          else
 251             return Chars (Defining_Identifier (Original_Node (Parent (S))));
 252          end if;
 253       end Original_Chars;
 254
 255    --  Start of processing for Check_Eliminated
 256
 257    begin
 258       if No_Elimination then
 259          return;
 260
 261       --  Elimination of objects and types is not implemented yet
 262
 263       elsif Ekind (E) not in Subprogram_Kind then
 264          return;
 265       end if;
 266
 267       Elmt := Elim_Hash_Table.Get (Chars (E));
 268
 269       --  Loop through homonyms for this key
 270
 271       while Elmt /= null loop
 272          declare
 273             procedure Set_Eliminated;
 274             --  Set current subprogram entity as eliminated
 275
 276             procedure Set_Eliminated is
 277             begin
 278                Set_Is_Eliminated (E);
 279                Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
 280             end Set_Eliminated;
 281
 282          begin
 283             --  First we check that the name of the entity matches
 284
 285             if Elmt.Entity_Name /= Chars (E) then
 286                goto Continue;
 287             end if;
 288
 289             --  Then we need to see if the static scope matches within the
 290             --  compilation unit.
 291
 292             --  At the moment, gnatelim does not consider block statements as
 293             --  scopes (even if a block is named)
 294
 295             Scop := Scope (E);
 296             while Ekind (Scop) = E_Block loop
 297                Scop := Scope (Scop);
 298             end loop;
 299
 300             if Elmt.Entity_Scope /= null then
 301                for J in reverse Elmt.Entity_Scope'Range loop
 302                   if Elmt.Entity_Scope (J) /= Original_Chars (Scop) then
 303                      goto Continue;
 304                   end if;
 305
 306                   Scop := Scope (Scop);
 307                   while Ekind (Scop) = E_Block loop
 308                      Scop := Scope (Scop);
 309                   end loop;
 310
 311                   if not Is_Compilation_Unit (Scop) and then J = 1 then
 312                      goto Continue;
 313                   end if;
 314                end loop;
 315             end if;
 316
 317             --  Now see if compilation unit matches
 318
 319             for J in reverse Elmt.Unit_Name'Range loop
 320                if Elmt.Unit_Name (J) /= Chars (Scop) then
 321                   goto Continue;
 322                end if;
 323
 324                Scop := Scope (Scop);
 325                while Ekind (Scop) = E_Block loop
 326                   Scop := Scope (Scop);
 327                end loop;
 328
 329                if Scop /= Standard_Standard and then J = 1 then
 330                   goto Continue;
 331                end if;
 332             end loop;
 333
 334             if Scop /= Standard_Standard then
 335                goto Continue;
 336             end if;
 337
 338             --  Check for case of given entity is a library level subprogram
 339             --  and we have the single parameter Eliminate case, a match!
 340
 341             if Is_Compilation_Unit (E)
 342               and then Is_Subprogram (E)
 343               and then No (Elmt.Entity_Node)
 344             then
 345                Set_Eliminated;
 346                return;
 347
 348                --  Check for case of type or object with two parameter case
 349
 350             elsif (Is_Type (E) or else Is_Object (E))
 351               and then Elmt.Result_Type = No_Name
 352               and then Elmt.Parameter_Types = null
 353             then
 354                Set_Eliminated;
 355                return;
 356
 357                --  Check for case of subprogram
 358
 359             elsif Ekind (E) = E_Function
 360               or else Ekind (E) = E_Procedure
 361             then
 362                --  If Source_Location present, then see if it matches
 363
 364                if Elmt.Source_Location /= No_Name then
 365                   Get_Name_String (Elmt.Source_Location);
 366
 367                   declare
 368                      Sloc_Trace : constant String :=
 369                        Name_Buffer (1 .. Name_Len);
 370
 371                      Idx : Natural := Sloc_Trace'First;
 372                      --  Index in Sloc_Trace, if equals to 0, then we have
 373                      --  completely traversed Sloc_Trace
 374
 375                      Last : constant Natural := Sloc_Trace'Last;
 376
 377                      P      : Source_Ptr;
 378                      Sindex : Source_File_Index;
 379
 380                      function File_Mame_Match return Boolean;
 381                      --  This function is supposed to be called when Idx points
 382                      --  to the beginning of the new file name, and Name_Buffer
 383                      --  is set to contain the name of the proper source file
 384                      --  from the chain corresponding to the Sloc of E. First
 385                      --  it checks that these two files have the same name. If
 386                      --  this check is successful, moves Idx to point to the
 387                      --  beginning of the column number.
 388
 389                      function Line_Num_Match return Boolean;
 390                      --  This function is supposed to be called when Idx points
 391                      --  to the beginning of the column number, and P is
 392                      --  set to point to the proper Sloc the chain
 393                      --  corresponding to the Sloc of E. First it checks that
 394                      --  the line number Idx points on and the line number
 395                      --  corresponding to P are the same. If this check is
 396                      --  successful, moves Idx to point to the beginning of
 397                      --  the next file name in Sloc_Trace. If there is no file
 398                      --  name any more, Idx is set to 0.
 399
 400                      function Different_Trace_Lengths return Boolean;
 401                      --  From Idx and P, defines if there are in both traces
 402                      --  more element(s) in the instantiation chains. Returns
 403                      --  False if one trace contains more element(s), but
 404                      --  another does not. If both traces contains more
 405                      --  elements (that is, the function returns False), moves
 406                      --  P ahead in the chain corresponding to E, recomputes
 407                      --  Sindex and sets the name of the corresponding file in
 408                      --  Name_Buffer
 409
 410                      function Skip_Spaces return Natural;
 411                      --  If Sloc_Trace (Idx) is not space character, returns
 412                      --  Idx. Otherwise returns the index of the nearest
 413                      --  non-space character in Sloc_Trace to the right of
 414                      --  Idx. Returns 0 if there is no such character.
 415
 416                      function Different_Trace_Lengths return Boolean is
 417                      begin
 418                         P := Instantiation (Sindex);
 419
 420                         if (P = No_Location and then Idx /= 0)
 421                           or else
 422                            (P /= No_Location and then Idx = 0)
 423                         then
 424                            return True;
 425                         else
 426
 427                            if P /= No_Location then
 428                               Sindex := Get_Source_File_Index (P);
 429                               Get_Name_String (File_Name (Sindex));
 430                            end if;
 431
 432                            return False;
 433                         end if;
 434                      end Different_Trace_Lengths;
 435
 436                      function File_Mame_Match return Boolean is
 437                         Tmp_Idx : Positive;
 438                         End_Idx : Positive;
 439                      begin
 440
 441                         if Idx = 0 then
 442                            return False;
 443                         end if;
 444
 445                         for J in Idx .. Last loop
 446                            if Sloc_Trace (J) = ':' then
 447                               Tmp_Idx := J - 1;
 448                               exit;
 449                            end if;
 450                         end loop;
 451
 452                         for J in reverse Idx .. Tmp_Idx loop
 453                            if Sloc_Trace (J) /= ' ' then
 454                               End_Idx := J;
 455                               exit;
 456                            end if;
 457                         end loop;
 458
 459                         if Sloc_Trace (Idx .. End_Idx) =
 460                            Name_Buffer (1 .. Name_Len)
 461                         then
 462                            Idx := Tmp_Idx + 2;
 463
 464                            Idx := Skip_Spaces;
 465
 466                            return True;
 467                         else
 468                            return False;
 469                         end if;
 470
 471                      end File_Mame_Match;
 472
 473                      function Line_Num_Match return Boolean is
 474                         N : Int := 0;
 475                      begin
 476
 477                         if Idx = 0 then
 478                            return False;
 479                         end if;
 480
 481                         while Idx <= Last
 482                            and then
 483                               Sloc_Trace (Idx) in '0' .. '9'
 484                         loop
 485                            N := N * 10 +
 486                             (Character'Pos (Sloc_Trace (Idx)) -
 487                              Character'Pos ('0'));
 488
 489                            Idx := Idx + 1;
 490                         end loop;
 491
 492                         if Get_Physical_Line_Number (P) =
 493                            Physical_Line_Number (N)
 494                         then
 495
 496                            while Sloc_Trace (Idx) /= '['
 497                                and then
 498                                  Idx <= Last
 499                            loop
 500                               Idx := Idx + 1;
 501                            end loop;
 502
 503                            if Sloc_Trace (Idx) = '['
 504                              and then
 505                                Idx < Last
 506                            then
 507                               Idx := Idx + 1;
 508                               Idx := Skip_Spaces;
 509                            else
 510                               Idx := 0;
 511                            end if;
 512
 513                            return True;
 514                         else
 515                            return False;
 516                         end if;
 517
 518                      end Line_Num_Match;
 519
 520                      function Skip_Spaces return Natural is
 521                         Res : Natural := Idx;
 522                      begin
 523
 524                         while Sloc_Trace (Res) = ' ' loop
 525                            Res := Res + 1;
 526
 527                            if Res > Last then
 528                               Res := 0;
 529                               exit;
 530                            end if;
 531                         end loop;
 532
 533                         return Res;
 534                      end Skip_Spaces;
 535
 536                   begin
 537                      P      := Sloc (E);
 538                      Sindex := Get_Source_File_Index (P);
 539                      Get_Name_String (File_Name (Sindex));
 540
 541                      Idx := Skip_Spaces;
 542
 543                      while Idx > 0 loop
 544
 545                         if not File_Mame_Match then
 546                            goto Continue;
 547                         elsif not Line_Num_Match then
 548                            goto Continue;
 549                         end if;
 550
 551                         if Different_Trace_Lengths then
 552                            goto Continue;
 553                         end if;
 554                      end loop;
 555                   end;
 556                end if;
 557
 558                --  If we have a Result_Type, then we must have a function
 559                --  with the proper result type
 560
 561                if Elmt.Result_Type /= No_Name then
 562                   if Ekind (E) /= E_Function
 563                     or else Chars (Etype (E)) /= Elmt.Result_Type
 564                   then
 565                      goto Continue;
 566                   end if;
 567                end if;
 568
 569                --  If we have Parameter_Types, they must match
 570
 571                if Elmt.Parameter_Types /= null then
 572                   Form := First_Formal (E);
 573
 574                   if No (Form)
 575                    and then
 576                     Elmt.Parameter_Types'Length = 1
 577                    and then
 578                     Elmt.Parameter_Types (1) = No_Name
 579                   then
 580                      --  Parameterless procedure matches
 581
 582                      null;
 583
 584                   elsif Elmt.Parameter_Types = null then
 585                      goto Continue;
 586
 587                   else
 588                      for J in Elmt.Parameter_Types'Range loop
 589                         if No (Form)
 590                           or else
 591                             Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
 592                         then
 593                            goto Continue;
 594                         else
 595                            Next_Formal (Form);
 596                         end if;
 597                      end loop;
 598
 599                      if Present (Form) then
 600                         goto Continue;
 601                      end if;
 602                   end if;
 603                end if;
 604
 605                --  If we fall through, this is match
 606
 607                Set_Eliminated;
 608                return;
 609             end if;
 610
 611             <<Continue>> Elmt := Elmt.Homonym;
 612          end;
 613       end loop;
 614
 615       return;
 616    end Check_Eliminated;
 617
 618    -------------------------
 619    -- Eliminate_Error_Msg --
 620    -------------------------
 621
 622    procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
 623    begin
 624       for J in Elim_Entities.First .. Elim_Entities.Last loop
 625          if E = Elim_Entities.Table (J).Subp then
 626             Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
 627             Error_Msg_NE ("cannot call subprogram & eliminated #", N, E);
 628             return;
 629          end if;
 630       end loop;
 631
 632       --  Should never fall through, since entry should be in table
 633
 634       pragma Assert (False);
 635    end Eliminate_Error_Msg;
 636
 637    ----------------
 638    -- Initialize --
 639    ----------------
 640
 641    procedure Initialize is
 642    begin
 643       Elim_Hash_Table.Reset;
 644       Elim_Entities.Init;
 645       No_Elimination := True;
 646    end Initialize;
 647
 648    ------------------------------
 649    -- Process_Eliminate_Pragma --
 650    ------------------------------
 651
 652    procedure Process_Eliminate_Pragma
 653      (Pragma_Node         : Node_Id;
 654       Arg_Unit_Name       : Node_Id;
 655       Arg_Entity          : Node_Id;
 656       Arg_Parameter_Types : Node_Id;
 657       Arg_Result_Type     : Node_Id;
 658       Arg_Source_Location : Node_Id)
 659    is
 660       Data : constant Access_Elim_Data := new Elim_Data;
 661       --  Build result data here
 662
 663       Elmt : Access_Elim_Data;
 664
 665       Num_Names : Nat := 0;
 666       --  Number of names in unit name
 667
 668       Lit       : Node_Id;
 669       Arg_Ent   : Entity_Id;
 670       Arg_Uname : Node_Id;
 671
 672       function OK_Selected_Component (N : Node_Id) return Boolean;
 673       --  Test if N is a selected component with all identifiers, or a
 674       --  selected component whose selector is an operator symbol. As a
 675       --  side effect if result is True, sets Num_Names to the number
 676       --  of names present (identifiers and operator if any).
 677
 678       ---------------------------
 679       -- OK_Selected_Component --
 680       ---------------------------
 681
 682       function OK_Selected_Component (N : Node_Id) return Boolean is
 683       begin
 684          if Nkind (N) = N_Identifier
 685            or else Nkind (N) = N_Operator_Symbol
 686          then
 687             Num_Names := Num_Names + 1;
 688             return True;
 689
 690          elsif Nkind (N) = N_Selected_Component then
 691             return OK_Selected_Component (Prefix (N))
 692               and then OK_Selected_Component (Selector_Name (N));
 693
 694          else
 695             return False;
 696          end if;
 697       end OK_Selected_Component;
 698
 699    --  Start of processing for Process_Eliminate_Pragma
 700
 701    begin
 702       Data.Prag := Pragma_Node;
 703       Error_Msg_Name_1 := Name_Eliminate;
 704
 705       --  Process Unit_Name argument
 706
 707       if Nkind (Arg_Unit_Name) = N_Identifier then
 708          Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
 709          Num_Names := 1;
 710
 711       elsif OK_Selected_Component (Arg_Unit_Name) then
 712          Data.Unit_Name := new Names (1 .. Num_Names);
 713
 714          Arg_Uname := Arg_Unit_Name;
 715          for J in reverse 2 .. Num_Names loop
 716             Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
 717             Arg_Uname := Prefix (Arg_Uname);
 718          end loop;
 719
 720          Data.Unit_Name (1) := Chars (Arg_Uname);
 721
 722       else
 723          Error_Msg_N
 724            ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
 725          return;
 726       end if;
 727
 728       --  Process Entity argument
 729
 730       if Present (Arg_Entity) then
 731          Num_Names := 0;
 732
 733          if Nkind (Arg_Entity) = N_Identifier
 734            or else Nkind (Arg_Entity) = N_Operator_Symbol
 735          then
 736             Data.Entity_Name  := Chars (Arg_Entity);
 737             Data.Entity_Node  := Arg_Entity;
 738             Data.Entity_Scope := null;
 739
 740          elsif OK_Selected_Component (Arg_Entity) then
 741             Data.Entity_Scope := new Names (1 .. Num_Names - 1);
 742             Data.Entity_Name  := Chars (Selector_Name (Arg_Entity));
 743             Data.Entity_Node  := Arg_Entity;
 744
 745             Arg_Ent := Prefix (Arg_Entity);
 746             for J in reverse 2 .. Num_Names - 1 loop
 747                Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
 748                Arg_Ent := Prefix (Arg_Ent);
 749             end loop;
 750
 751             Data.Entity_Scope (1) := Chars (Arg_Ent);
 752
 753          elsif Nkind (Arg_Entity) = N_String_Literal then
 754             String_To_Name_Buffer (Strval (Arg_Entity));
 755             Data.Entity_Name := Name_Find;
 756             Data.Entity_Node := Arg_Entity;
 757
 758          else
 759             Error_Msg_N
 760               ("wrong form for Entity_Argument parameter of pragma%",
 761                Arg_Unit_Name);
 762             return;
 763          end if;
 764       else
 765          Data.Entity_Node := Empty;
 766          Data.Entity_Name := Data.Unit_Name (Num_Names);
 767       end if;
 768
 769       --  Process Parameter_Types argument
 770
 771       if Present (Arg_Parameter_Types) then
 772
 773          --  Case of one name, which looks like a parenthesized literal
 774          --  rather than an aggregate.
 775
 776          if Nkind (Arg_Parameter_Types) = N_String_Literal
 777            and then Paren_Count (Arg_Parameter_Types) = 1
 778          then
 779             String_To_Name_Buffer (Strval (Arg_Parameter_Types));
 780
 781             if Name_Len = 0 then
 782                --  Parameterless procedure
 783                Data.Parameter_Types := new Names'(1 => No_Name);
 784             else
 785                Data.Parameter_Types := new Names'(1 => Name_Find);
 786             end if;
 787
 788          --  Otherwise must be an aggregate
 789
 790          elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
 791            or else Present (Component_Associations (Arg_Parameter_Types))
 792            or else No (Expressions (Arg_Parameter_Types))
 793          then
 794             Error_Msg_N
 795               ("Parameter_Types for pragma% must be list of string literals",
 796                Arg_Parameter_Types);
 797             return;
 798
 799          --  Here for aggregate case
 800
 801          else
 802             Data.Parameter_Types :=
 803               new Names
 804                 (1 .. List_Length (Expressions (Arg_Parameter_Types)));
 805
 806             Lit := First (Expressions (Arg_Parameter_Types));
 807             for J in Data.Parameter_Types'Range loop
 808                if Nkind (Lit) /= N_String_Literal then
 809                   Error_Msg_N
 810                     ("parameter types for pragma% must be string literals",
 811                      Lit);
 812                   return;
 813                end if;
 814
 815                String_To_Name_Buffer (Strval (Lit));
 816                Data.Parameter_Types (J) := Name_Find;
 817                Next (Lit);
 818             end loop;
 819          end if;
 820       end if;
 821
 822       --  Process Result_Types argument
 823
 824       if Present (Arg_Result_Type) then
 825
 826          if Nkind (Arg_Result_Type) /= N_String_Literal then
 827             Error_Msg_N
 828               ("Result_Type argument for pragma% must be string literal",
 829                Arg_Result_Type);
 830             return;
 831          end if;
 832
 833          String_To_Name_Buffer (Strval (Arg_Result_Type));
 834          Data.Result_Type := Name_Find;
 835
 836       else
 837          Data.Result_Type := No_Name;
 838       end if;
 839
 840       --  Process Source_Location argument
 841
 842       if Present (Arg_Source_Location) then
 843
 844          if Nkind (Arg_Source_Location) /= N_String_Literal then
 845             Error_Msg_N
 846               ("Source_Location argument for pragma% must be string literal",
 847                Arg_Source_Location);
 848             return;
 849          end if;
 850
 851          String_To_Name_Buffer (Strval (Arg_Source_Location));
 852          Data.Source_Location := Name_Find;
 853
 854       else
 855          Data.Source_Location := No_Name;
 856       end if;
 857
 858       Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
 859
 860       --  If we already have an entry with this same key, then link
 861       --  it into the chain of entries for this key.
 862
 863       if Elmt /= null then
 864          Data.Homonym := Elmt.Homonym;
 865          Elmt.Homonym := Data;
 866
 867       --  Otherwise create a new entry
 868
 869       else
 870          Elim_Hash_Table.Set (Data);
 871       end if;
 872
 873       No_Elimination := False;
 874    end Process_Eliminate_Pragma;
 875
 876 end Sem_Elim;