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-2023, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;          use Atree;
  27 with Einfo;          use Einfo;
  28 with Einfo.Entities; use Einfo.Entities;
  29 with Einfo.Utils;    use Einfo.Utils;
  30 with Errout;         use Errout;
  31 with Lib;            use Lib;
  32 with Namet;          use Namet;
  33 with Nlists;         use Nlists;
  34 with Opt;            use Opt;
  35 with Sem;            use Sem;
  36 with Sem_Aux;        use Sem_Aux;
  37 with Sem_Prag;       use Sem_Prag;
  38 with Sem_Util;       use Sem_Util;
  39 with Sinput;         use Sinput;
  40 with Sinfo;          use Sinfo;
  41 with Sinfo.Nodes;    use Sinfo.Nodes;
  42 with Snames;         use Snames;
  43 with Stand;          use Stand;
  44 with Stringt;        use Stringt;
  45 with Table;
  46
  47 with GNAT.HTable;    use GNAT.HTable;
  48
  49 package body Sem_Elim is
  50
  51    No_Elimination : Boolean;
  52    --  Set True if no Eliminate pragmas active
  53
  54    ---------------------
  55    -- Data Structures --
  56    ---------------------
  57
  58    --  A single pragma Eliminate is represented by the following record
  59
  60    type Elim_Data;
  61    type Access_Elim_Data is access Elim_Data;
  62
  63    type Names is array (Nat range <>) of Name_Id;
  64    --  Type used to represent set of names. Used for names in Unit_Name
  65    --  and also the set of names in Argument_Types.
  66
  67    type Access_Names is access Names;
  68
  69    type Elim_Data is record
  70
  71       Unit_Name : Access_Names;
  72       --  Unit name, broken down into a set of names (e.g. A.B.C is
  73       --  represented as Name_Id values for A, B, C in sequence).
  74
  75       Entity_Name : Name_Id;
  76       --  Entity name if Entity parameter if present. If no Entity parameter
  77       --  was supplied, then Entity_Node is set to Empty, and the Entity_Name
  78       --  field contains the last identifier name in the Unit_Name.
  79
  80       Entity_Scope : Access_Names;
  81       --  Static scope of the entity within the compilation unit represented by
  82       --  Unit_Name.
  83
  84       Entity_Node : Node_Id;
  85       --  Save node of entity argument, for posting error messages. Set
  86       --  to Empty if there is no entity argument.
  87
  88       Parameter_Types : Access_Names;
  89       --  Set to set of names given for parameter types. If no parameter
  90       --  types argument is present, this argument is set to null.
  91
  92       Result_Type : Name_Id;
  93       --  Result type name if Result_Types parameter present, No_Name if not
  94
  95       Source_Location : Name_Id;
  96       --  String describing the source location of subprogram defining name if
  97       --  Source_Location parameter present, No_Name if not
  98
  99       Hash_Link : Access_Elim_Data;
 100       --  Link for hash table use
 101
 102       Homonym : Access_Elim_Data;
 103       --  Pointer to next entry with same key
 104
 105       Prag : Node_Id;
 106       --  Node_Id for Eliminate pragma
 107
 108    end record;
 109
 110    ----------------
 111    -- Hash_Table --
 112    ----------------
 113
 114    --  Setup hash table using the Entity_Name field as the hash key
 115
 116    subtype Element is Elim_Data;
 117    subtype Elmt_Ptr is Access_Elim_Data;
 118
 119    subtype Key is Name_Id;
 120
 121    type Header_Num is range 0 .. 1023;
 122
 123    Null_Ptr : constant Elmt_Ptr := null;
 124
 125    ----------------------
 126    -- Hash_Subprograms --
 127    ----------------------
 128
 129    package Hash_Subprograms is
 130
 131       function Equal (F1, F2 : Key) return Boolean;
 132       pragma Inline (Equal);
 133
 134       function Get_Key (E : Elmt_Ptr) return Key;
 135       pragma Inline (Get_Key);
 136
 137       function Hash (F : Key) return Header_Num;
 138       pragma Inline (Hash);
 139
 140       function Next (E : Elmt_Ptr) return Elmt_Ptr;
 141       pragma Inline (Next);
 142
 143       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
 144       pragma Inline (Set_Next);
 145
 146    end Hash_Subprograms;
 147
 148    package body Hash_Subprograms is
 149
 150       -----------
 151       -- Equal --
 152       -----------
 153
 154       function Equal (F1, F2 : Key) return Boolean is
 155       begin
 156          return F1 = F2;
 157       end Equal;
 158
 159       -------------
 160       -- Get_Key --
 161       -------------
 162
 163       function Get_Key (E : Elmt_Ptr) return Key is
 164       begin
 165          return E.Entity_Name;
 166       end Get_Key;
 167
 168       ----------
 169       -- Hash --
 170       ----------
 171
 172       function Hash (F : Key) return Header_Num is
 173       begin
 174          return Header_Num (Int (F) mod 1024);
 175       end Hash;
 176
 177       ----------
 178       -- Next --
 179       ----------
 180
 181       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 182       begin
 183          return E.Hash_Link;
 184       end Next;
 185
 186       --------------
 187       -- Set_Next --
 188       --------------
 189
 190       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 191       begin
 192          E.Hash_Link := Next;
 193       end Set_Next;
 194    end Hash_Subprograms;
 195
 196    ------------
 197    -- Tables --
 198    ------------
 199
 200    --  The following table records the data for each pragma, using the
 201    --  entity name as the hash key for retrieval. Entries in this table
 202    --  are set by Process_Eliminate_Pragma and read by Check_Eliminated.
 203
 204    package Elim_Hash_Table is new Static_HTable (
 205       Header_Num => Header_Num,
 206       Element    => Element,
 207       Elmt_Ptr   => Elmt_Ptr,
 208       Null_Ptr   => Null_Ptr,
 209       Set_Next   => Hash_Subprograms.Set_Next,
 210       Next       => Hash_Subprograms.Next,
 211       Key        => Key,
 212       Get_Key    => Hash_Subprograms.Get_Key,
 213       Hash       => Hash_Subprograms.Hash,
 214       Equal      => Hash_Subprograms.Equal);
 215
 216    --  The following table records entities for subprograms that are
 217    --  eliminated, and corresponding eliminate pragmas that caused the
 218    --  elimination. Entries in this table are set by Check_Eliminated
 219    --  and read by Eliminate_Error_Msg.
 220
 221    type Elim_Entity_Entry is record
 222       Prag : Node_Id;
 223       Subp : Entity_Id;
 224    end record;
 225
 226    package Elim_Entities is new Table.Table (
 227      Table_Component_Type => Elim_Entity_Entry,
 228      Table_Index_Type     => Name_Id'Base,
 229      Table_Low_Bound      => First_Name_Id,
 230      Table_Initial        => 50,
 231      Table_Increment      => 200,
 232      Table_Name           => "Elim_Entries");
 233
 234    ----------------------
 235    -- Check_Eliminated --
 236    ----------------------
 237
 238    procedure Check_Eliminated (E : Entity_Id) is
 239       Elmt : Access_Elim_Data;
 240       Scop : Entity_Id;
 241       Form : Entity_Id;
 242       Up   : Nat;
 243
 244    begin
 245       if No_Elimination then
 246          return;
 247
 248       --  Elimination of objects and types is not implemented yet
 249
 250       elsif not Is_Subprogram (E) then
 251          return;
 252       end if;
 253
 254       --  Loop through homonyms for this key
 255
 256       Elmt := Elim_Hash_Table.Get (Chars (E));
 257       while Elmt /= null loop
 258          Check_Homonyms : declare
 259             procedure Set_Eliminated;
 260             --  Set current subprogram entity as eliminated
 261
 262             --------------------
 263             -- Set_Eliminated --
 264             --------------------
 265
 266             procedure Set_Eliminated is
 267                Overridden : Entity_Id;
 268
 269             begin
 270                if Is_Dispatching_Operation (E) then
 271
 272                   --  If an overriding dispatching primitive is eliminated then
 273                   --  its parent must have been eliminated. If the parent is an
 274                   --  inherited operation, check the operation that it renames,
 275                   --  because flag Eliminated is only set on source operations.
 276
 277                   Overridden := Overridden_Operation (E);
 278
 279                   if Present (Overridden)
 280                     and then not Comes_From_Source (Overridden)
 281                     and then Present (Alias (Overridden))
 282                   then
 283                      Overridden := Alias (Overridden);
 284                   end if;
 285
 286                   if Present (Overridden)
 287                     and then not Is_Eliminated (Overridden)
 288                     and then not Is_Abstract_Subprogram (Overridden)
 289                   then
 290                      Error_Msg_Name_1 := Chars (E);
 291                      Error_Msg_N ("cannot eliminate subprogram %", E);
 292                      return;
 293                   end if;
 294                end if;
 295
 296                Set_Is_Eliminated (E);
 297                Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
 298             end Set_Eliminated;
 299
 300          --  Start of processing for Check_Homonyms
 301
 302          begin
 303             --  First we check that the name of the entity matches
 304
 305             if Elmt.Entity_Name /= Chars (E) then
 306                goto Continue;
 307             end if;
 308
 309             --  Find enclosing unit, and verify that its name and those of its
 310             --  parents match.
 311
 312             Scop := Cunit_Entity (Current_Sem_Unit);
 313
 314             --  Now see if compilation unit matches
 315
 316             Up := Elmt.Unit_Name'Last;
 317
 318             --  If we are within a subunit, the name in the pragma has been
 319             --  parsed as a child unit, but the current compilation unit is in
 320             --  fact the parent in which the subunit is embedded. We must skip
 321             --  the first name which is that of the subunit to match the pragma
 322             --  specification. Body may be that of a package or subprogram.
 323
 324             declare
 325                Par : Node_Id;
 326
 327             begin
 328                Par := Parent (E);
 329                while Present (Par) loop
 330                   if Nkind (Par) = N_Subunit then
 331                      if Chars (Defining_Entity (Proper_Body (Par))) =
 332                                                          Elmt.Unit_Name (Up)
 333                      then
 334                         Up := Up - 1;
 335                         exit;
 336
 337                      else
 338                         goto Continue;
 339                      end if;
 340                   end if;
 341
 342                   Par := Parent (Par);
 343                end loop;
 344             end;
 345
 346             for J in reverse Elmt.Unit_Name'First .. Up loop
 347                if Elmt.Unit_Name (J) /= Chars (Scop) then
 348                   goto Continue;
 349                end if;
 350
 351                Scop := Scope (Scop);
 352
 353                if Scop /= Standard_Standard and then J = 1 then
 354                   goto Continue;
 355                end if;
 356             end loop;
 357
 358             if Scop /= Standard_Standard then
 359                goto Continue;
 360             end if;
 361
 362             if Present (Elmt.Entity_Node)
 363               and then Elmt.Entity_Scope /= null
 364             then
 365                --  Check that names of enclosing scopes match. Skip blocks and
 366                --  wrapper package of subprogram instances, which do not appear
 367                --  in the pragma.
 368
 369                Scop := Scope (E);
 370
 371                for J in reverse  Elmt.Entity_Scope'Range loop
 372                   while Ekind (Scop) = E_Block
 373                     or else
 374                      (Ekind (Scop) = E_Package
 375                        and then Is_Wrapper_Package (Scop))
 376                   loop
 377                      Scop := Scope (Scop);
 378                   end loop;
 379
 380                   if Elmt.Entity_Scope (J) /= Chars (Scop) then
 381                      if Ekind (Scop) /= E_Protected_Type
 382                        or else Comes_From_Source (Scop)
 383                      then
 384                         goto Continue;
 385
 386                      --  For simple protected declarations, retrieve the source
 387                      --  name of the object, which appeared in the Eliminate
 388                      --  pragma.
 389
 390                      else
 391                         declare
 392                            Decl : constant Node_Id :=
 393                              Original_Node (Parent (Scop));
 394
 395                         begin
 396                            if Elmt.Entity_Scope (J) /=
 397                              Chars (Defining_Identifier (Decl))
 398                            then
 399                               if J > 0 then
 400                                  null;
 401                               end if;
 402                               goto Continue;
 403                            end if;
 404                         end;
 405                      end if;
 406
 407                   end if;
 408
 409                   Scop := Scope (Scop);
 410                end loop;
 411             end if;
 412
 413             --  If given entity is a library level subprogram and pragma had a
 414             --  single parameter, a match.
 415
 416             if Is_Compilation_Unit (E)
 417               and then Is_Subprogram (E)
 418               and then No (Elmt.Entity_Node)
 419             then
 420                Set_Eliminated;
 421                return;
 422
 423                --  Check for case of type or object with two parameter case
 424
 425             elsif (Is_Type (E) or else Is_Object (E))
 426               and then Elmt.Result_Type = No_Name
 427               and then Elmt.Parameter_Types = null
 428             then
 429                Set_Eliminated;
 430                return;
 431
 432             --  Check for case of subprogram
 433
 434             elsif Ekind (E) in E_Function | E_Procedure then
 435
 436                --  If Source_Location present, then see if it matches
 437
 438                if Elmt.Source_Location /= No_Name then
 439                   Get_Name_String (Elmt.Source_Location);
 440
 441                   declare
 442                      Sloc_Trace : constant String :=
 443                                     Name_Buffer (1 .. Name_Len);
 444
 445                      Idx : Natural := Sloc_Trace'First;
 446                      --  Index in Sloc_Trace, if equals to 0, then we have
 447                      --  completely traversed Sloc_Trace
 448
 449                      Last : constant Natural := Sloc_Trace'Last;
 450
 451                      P      : Source_Ptr;
 452                      Sindex : Source_File_Index;
 453
 454                      function File_Name_Match return Boolean;
 455                      --  This function is supposed to be called when Idx points
 456                      --  to the beginning of the new file name, and Name_Buffer
 457                      --  is set to contain the name of the proper source file
 458                      --  from the chain corresponding to the Sloc of E. First
 459                      --  it checks that these two files have the same name. If
 460                      --  this check is successful, moves Idx to point to the
 461                      --  beginning of the column number.
 462
 463                      function Line_Num_Match return Boolean;
 464                      --  This function is supposed to be called when Idx points
 465                      --  to the beginning of the column number, and P is
 466                      --  set to point to the proper Sloc the chain
 467                      --  corresponding to the Sloc of E. First it checks that
 468                      --  the line number Idx points on and the line number
 469                      --  corresponding to P are the same. If this check is
 470                      --  successful, moves Idx to point to the beginning of
 471                      --  the next file name in Sloc_Trace. If there is no file
 472                      --  name any more, Idx is set to 0.
 473
 474                      function Different_Trace_Lengths return Boolean;
 475                      --  From Idx and P, defines if there are in both traces
 476                      --  more element(s) in the instantiation chains. Returns
 477                      --  False if one trace contains more element(s), but
 478                      --  another does not. If both traces contains more
 479                      --  elements (that is, the function returns False), moves
 480                      --  P ahead in the chain corresponding to E, recomputes
 481                      --  Sindex and sets the name of the corresponding file in
 482                      --  Name_Buffer
 483
 484                      function Skip_Spaces return Natural;
 485                      --  If Sloc_Trace (Idx) is not space character, returns
 486                      --  Idx. Otherwise returns the index of the nearest
 487                      --  non-space character in Sloc_Trace to the right of Idx.
 488                      --  Returns 0 if there is no such character.
 489
 490                      -----------------------------
 491                      -- Different_Trace_Lengths --
 492                      -----------------------------
 493
 494                      function Different_Trace_Lengths return Boolean is
 495                      begin
 496                         P := Instantiation (Sindex);
 497
 498                         if (P = No_Location and then Idx /= 0)
 499                           or else
 500                            (P /= No_Location and then Idx = 0)
 501                         then
 502                            return True;
 503
 504                         else
 505                            if P /= No_Location then
 506                               Sindex := Get_Source_File_Index (P);
 507                               Get_Name_String (File_Name (Sindex));
 508                            end if;
 509
 510                            return False;
 511                         end if;
 512                      end Different_Trace_Lengths;
 513
 514                      ---------------------
 515                      -- File_Name_Match --
 516                      ---------------------
 517
 518                      function File_Name_Match return Boolean is
 519                         Tmp_Idx : Natural;
 520                         End_Idx : Natural;
 521
 522                      begin
 523                         if Idx = 0 then
 524                            return False;
 525                         end if;
 526
 527                         --  Find first colon. If no colon, then return False.
 528                         --  If there is a colon, Tmp_Idx is set to point just
 529                         --  before the colon.
 530
 531                         Tmp_Idx := Idx - 1;
 532                         loop
 533                            if Tmp_Idx >= Last then
 534                               return False;
 535                            elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
 536                               exit;
 537                            else
 538                               Tmp_Idx := Tmp_Idx + 1;
 539                            end if;
 540                         end loop;
 541
 542                         --  Find last non-space before this colon. If there is
 543                         --  no space character before this colon, then return
 544                         --  False. Otherwise, End_Idx is set to point to this
 545                         --  non-space character.
 546
 547                         End_Idx := Tmp_Idx;
 548                         loop
 549                            if End_Idx < Idx then
 550                               return False;
 551
 552                            elsif Sloc_Trace (End_Idx) /= ' ' then
 553                               exit;
 554
 555                            else
 556                               End_Idx := End_Idx - 1;
 557                            end if;
 558                         end loop;
 559
 560                         --  Now see if file name matches what is in Name_Buffer
 561                         --  and if so, step Idx past it and return True. If the
 562                         --  name does not match, return False.
 563
 564                         if Sloc_Trace (Idx .. End_Idx) =
 565                            Name_Buffer (1 .. Name_Len)
 566                         then
 567                            Idx := Tmp_Idx + 2;
 568                            Idx := Skip_Spaces;
 569                            return True;
 570                         else
 571                            return False;
 572                         end if;
 573                      end File_Name_Match;
 574
 575                      --------------------
 576                      -- Line_Num_Match --
 577                      --------------------
 578
 579                      function Line_Num_Match return Boolean is
 580                         N : Nat := 0;
 581
 582                      begin
 583                         if Idx = 0 then
 584                            return False;
 585                         end if;
 586
 587                         while Idx <= Last
 588                            and then Sloc_Trace (Idx) in '0' .. '9'
 589                         loop
 590                            N := N * 10 +
 591                             (Character'Pos (Sloc_Trace (Idx)) -
 592                              Character'Pos ('0'));
 593                            Idx := Idx + 1;
 594                         end loop;
 595
 596                         if Get_Physical_Line_Number (P) =
 597                            Physical_Line_Number (N)
 598                         then
 599                            while Idx <= Last and then
 600                               Sloc_Trace (Idx) /= '['
 601                            loop
 602                               Idx := Idx + 1;
 603                            end loop;
 604
 605                            if Idx <= Last then
 606                               pragma Assert (Sloc_Trace (Idx) = '[');
 607                               Idx := Idx + 1;
 608                               Idx := Skip_Spaces;
 609                            else
 610                               Idx := 0;
 611                            end if;
 612
 613                            return True;
 614
 615                         else
 616                            return False;
 617                         end if;
 618                      end Line_Num_Match;
 619
 620                      -----------------
 621                      -- Skip_Spaces --
 622                      -----------------
 623
 624                      function Skip_Spaces return Natural is
 625                         Res : Natural;
 626
 627                      begin
 628                         Res := Idx;
 629                         while Sloc_Trace (Res) = ' ' loop
 630                            Res := Res + 1;
 631
 632                            if Res > Last then
 633                               Res := 0;
 634                               exit;
 635                            end if;
 636                         end loop;
 637
 638                         return Res;
 639                      end Skip_Spaces;
 640
 641                   begin
 642                      P := Sloc (E);
 643                      Sindex := Get_Source_File_Index (P);
 644                      Get_Name_String (File_Name (Sindex));
 645
 646                      Idx := Skip_Spaces;
 647                      while Idx > 0 loop
 648                         if not File_Name_Match then
 649                            goto Continue;
 650                         elsif not Line_Num_Match then
 651                            goto Continue;
 652                         end if;
 653
 654                         if Different_Trace_Lengths then
 655                            goto Continue;
 656                         end if;
 657                      end loop;
 658                   end;
 659                end if;
 660
 661                --  If we have a Result_Type, then we must have a function with
 662                --  the proper result type.
 663
 664                if Elmt.Result_Type /= No_Name then
 665                   if Ekind (E) /= E_Function
 666                     or else Chars (Etype (E)) /= Elmt.Result_Type
 667                   then
 668                      goto Continue;
 669                   end if;
 670                end if;
 671
 672                --  If we have Parameter_Types, they must match
 673
 674                if Elmt.Parameter_Types /= null then
 675                   Form := First_Formal (E);
 676
 677                   if No (Form)
 678                     and then Elmt.Parameter_Types'Length = 1
 679                     and then Elmt.Parameter_Types (1) = No_Name
 680                   then
 681                      --  Parameterless procedure matches
 682
 683                      null;
 684
 685                   elsif Elmt.Parameter_Types = null then
 686                      goto Continue;
 687
 688                   else
 689                      for J in Elmt.Parameter_Types'Range loop
 690                         if No (Form)
 691                           or else
 692                             Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
 693                         then
 694                            goto Continue;
 695                         else
 696                            Next_Formal (Form);
 697                         end if;
 698                      end loop;
 699
 700                      if Present (Form) then
 701                         goto Continue;
 702                      end if;
 703                   end if;
 704                end if;
 705
 706                --  If we fall through, this is match
 707
 708                Set_Eliminated;
 709                return;
 710             end if;
 711          end Check_Homonyms;
 712
 713       <<Continue>>
 714          Elmt := Elmt.Homonym;
 715       end loop;
 716
 717       return;
 718    end Check_Eliminated;
 719
 720    -------------------------------------
 721    -- Check_For_Eliminated_Subprogram --
 722    -------------------------------------
 723
 724    procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is
 725       Ultimate_Subp  : constant Entity_Id := Ultimate_Alias (S);
 726       Enclosing_Subp : Entity_Id;
 727
 728    begin
 729       --  No check needed within a default expression for a formal, since this
 730       --  is not really a use, and the expression (a call or attribute) may
 731       --  never be used if the enclosing subprogram is itself eliminated.
 732
 733       if In_Spec_Expression then
 734          return;
 735       end if;
 736
 737       if Is_Eliminated (Ultimate_Subp)
 738         and then not Inside_A_Generic
 739         and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit))
 740       then
 741          Enclosing_Subp := Current_Subprogram;
 742          while Present (Enclosing_Subp) loop
 743             if Is_Eliminated (Enclosing_Subp) then
 744                return;
 745             end if;
 746
 747             Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp);
 748          end loop;
 749
 750          --  Emit error, unless we are within an instance body and the expander
 751          --  is disabled, indicating an instance within an enclosing generic.
 752          --  In an instance, the ultimate alias is an internal entity, so place
 753          --  the message on the original subprogram.
 754
 755          if In_Instance_Body and then not Expander_Active then
 756             null;
 757
 758          elsif Comes_From_Source (Ultimate_Subp) then
 759             Eliminate_Error_Msg (N, Ultimate_Subp);
 760
 761          else
 762             Eliminate_Error_Msg (N, S);
 763          end if;
 764       end if;
 765    end Check_For_Eliminated_Subprogram;
 766
 767    -------------------------
 768    -- Eliminate_Error_Msg --
 769    -------------------------
 770
 771    procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
 772    begin
 773       for J in Elim_Entities.First .. Elim_Entities.Last loop
 774          if E = Elim_Entities.Table (J).Subp then
 775             Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
 776             Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E);
 777             return;
 778          end if;
 779       end loop;
 780
 781       --  If this is an internal operation generated for a protected operation,
 782       --  its name does not match the source name, so just report the error.
 783
 784       if not Comes_From_Source (E)
 785         and then Present (First_Entity (E))
 786         and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
 787       then
 788          Error_Msg_NE
 789            ("cannot reference eliminated protected subprogram&", N, E);
 790
 791       --  Otherwise should not fall through, entry should be in table
 792
 793       else
 794          Error_Msg_NE
 795            ("subprogram& is called but its alias is eliminated", N, E);
 796          --  raise Program_Error;
 797       end if;
 798    end Eliminate_Error_Msg;
 799
 800    ----------------
 801    -- Initialize --
 802    ----------------
 803
 804    procedure Initialize is
 805    begin
 806       Elim_Hash_Table.Reset;
 807       Elim_Entities.Init;
 808       No_Elimination := True;
 809    end Initialize;
 810
 811    ------------------------------
 812    -- Process_Eliminate_Pragma --
 813    ------------------------------
 814
 815    procedure Process_Eliminate_Pragma
 816      (Pragma_Node         : Node_Id;
 817       Arg_Unit_Name       : Node_Id;
 818       Arg_Entity          : Node_Id;
 819       Arg_Parameter_Types : Node_Id;
 820       Arg_Result_Type     : Node_Id;
 821       Arg_Source_Location : Node_Id)
 822    is
 823       Data : constant Access_Elim_Data := new Elim_Data;
 824       --  Build result data here
 825
 826       Elmt : Access_Elim_Data;
 827
 828       Num_Names : Nat := 0;
 829       --  Number of names in unit name
 830
 831       Lit       : Node_Id;
 832       Arg_Ent   : Entity_Id;
 833       Arg_Uname : Node_Id;
 834
 835       function OK_Selected_Component (N : Node_Id) return Boolean;
 836       --  Test if N is a selected component with all identifiers, or a selected
 837       --  component whose selector is an operator symbol. As a side effect
 838       --  if result is True, sets Num_Names to the number of names present
 839       --  (identifiers, and operator if any).
 840
 841       ---------------------------
 842       -- OK_Selected_Component --
 843       ---------------------------
 844
 845       function OK_Selected_Component (N : Node_Id) return Boolean is
 846       begin
 847          if Nkind (N) = N_Identifier
 848            or else Nkind (N) = N_Operator_Symbol
 849          then
 850             Num_Names := Num_Names + 1;
 851             return True;
 852
 853          elsif Nkind (N) = N_Selected_Component then
 854             return OK_Selected_Component (Prefix (N))
 855               and then OK_Selected_Component (Selector_Name (N));
 856
 857          else
 858             return False;
 859          end if;
 860       end OK_Selected_Component;
 861
 862    --  Start of processing for Process_Eliminate_Pragma
 863
 864    begin
 865       Data.Prag := Pragma_Node;
 866       Error_Msg_Name_1 := Name_Eliminate;
 867
 868       --  Process Unit_Name argument
 869
 870       if Nkind (Arg_Unit_Name) = N_Identifier then
 871          Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
 872          Num_Names := 1;
 873
 874       elsif OK_Selected_Component (Arg_Unit_Name) then
 875          Data.Unit_Name := new Names (1 .. Num_Names);
 876
 877          Arg_Uname := Arg_Unit_Name;
 878          for J in reverse 2 .. Num_Names loop
 879             Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
 880             Arg_Uname := Prefix (Arg_Uname);
 881          end loop;
 882
 883          Data.Unit_Name (1) := Chars (Arg_Uname);
 884
 885       else
 886          Error_Msg_N
 887            ("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
 888          return;
 889       end if;
 890
 891       --  Process Entity argument
 892
 893       if Present (Arg_Entity) then
 894          Num_Names := 0;
 895
 896          if Nkind (Arg_Entity) = N_Identifier
 897            or else Nkind (Arg_Entity) = N_Operator_Symbol
 898          then
 899             Data.Entity_Name  := Chars (Arg_Entity);
 900             Data.Entity_Node  := Arg_Entity;
 901             Data.Entity_Scope := null;
 902
 903          elsif OK_Selected_Component (Arg_Entity) then
 904             Data.Entity_Scope := new Names (1 .. Num_Names - 1);
 905             Data.Entity_Name  := Chars (Selector_Name (Arg_Entity));
 906             Data.Entity_Node  := Arg_Entity;
 907
 908             Arg_Ent := Prefix (Arg_Entity);
 909             for J in reverse 2 .. Num_Names - 1 loop
 910                Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
 911                Arg_Ent := Prefix (Arg_Ent);
 912             end loop;
 913
 914             Data.Entity_Scope (1) := Chars (Arg_Ent);
 915
 916          elsif Is_Config_Static_String (Arg_Entity) then
 917             Data.Entity_Name := Name_Find;
 918             Data.Entity_Node := Arg_Entity;
 919
 920          else
 921             return;
 922          end if;
 923       else
 924          Data.Entity_Node := Empty;
 925          Data.Entity_Name := Data.Unit_Name (Num_Names);
 926       end if;
 927
 928       --  Process Parameter_Types argument
 929
 930       if Present (Arg_Parameter_Types) then
 931
 932          --  Here for aggregate case
 933
 934          if Nkind (Arg_Parameter_Types) = N_Aggregate then
 935             Data.Parameter_Types :=
 936               new Names
 937                 (1 .. List_Length (Expressions (Arg_Parameter_Types)));
 938
 939             Lit := First (Expressions (Arg_Parameter_Types));
 940             for J in Data.Parameter_Types'Range loop
 941                if Is_Config_Static_String (Lit) then
 942                   Data.Parameter_Types (J) := Name_Find;
 943                   Next (Lit);
 944                else
 945                   return;
 946                end if;
 947             end loop;
 948
 949          --  Otherwise we must have case of one name, which looks like a
 950          --  parenthesized literal rather than an aggregate.
 951
 952          elsif Paren_Count (Arg_Parameter_Types) /= 1 then
 953             Error_Msg_N
 954               ("wrong form for argument of pragma Eliminate",
 955                Arg_Parameter_Types);
 956             return;
 957
 958          elsif Is_Config_Static_String (Arg_Parameter_Types) then
 959             String_To_Name_Buffer (Strval (Arg_Parameter_Types));
 960
 961             if Name_Len = 0 then
 962
 963                --  Parameterless procedure
 964
 965                Data.Parameter_Types := new Names'(1 => No_Name);
 966
 967             else
 968                Data.Parameter_Types := new Names'(1 => Name_Find);
 969             end if;
 970
 971          else
 972             return;
 973          end if;
 974       end if;
 975
 976       --  Process Result_Types argument
 977
 978       if Present (Arg_Result_Type) then
 979          if Is_Config_Static_String (Arg_Result_Type) then
 980             Data.Result_Type := Name_Find;
 981          else
 982             return;
 983          end if;
 984
 985       --  Here if no Result_Types argument
 986
 987       else
 988          Data.Result_Type := No_Name;
 989       end if;
 990
 991       --  Process Source_Location argument
 992
 993       if Present (Arg_Source_Location) then
 994          if Is_Config_Static_String (Arg_Source_Location) then
 995             Data.Source_Location := Name_Find;
 996          else
 997             return;
 998          end if;
 999       else
1000          Data.Source_Location := No_Name;
1001       end if;
1002
1003       Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
1004
1005       --  If we already have an entry with this same key, then link
1006       --  it into the chain of entries for this key.
1007
1008       if Elmt /= null then
1009          Data.Homonym := Elmt.Homonym;
1010          Elmt.Homonym := Data;
1011
1012       --  Otherwise create a new entry
1013
1014       else
1015          Elim_Hash_Table.Set (Data);
1016       end if;
1017
1018       No_Elimination := False;
1019    end Process_Eliminate_Pragma;
1020
1021 end Sem_Elim;