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