902 lines
29 KiB
Ada
902 lines
29 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S E M _ E L I M --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Einfo; use Einfo;
|
|
with Errout; use Errout;
|
|
with Lib; use Lib;
|
|
with Namet; use Namet;
|
|
with Nlists; use Nlists;
|
|
with Sem; use Sem;
|
|
with Sem_Prag; use Sem_Prag;
|
|
with Sem_Util; use Sem_Util;
|
|
with Sinput; use Sinput;
|
|
with Sinfo; use Sinfo;
|
|
with Snames; use Snames;
|
|
with Stand; use Stand;
|
|
with Stringt; use Stringt;
|
|
with Table;
|
|
|
|
with GNAT.HTable; use GNAT.HTable;
|
|
|
|
package body Sem_Elim is
|
|
|
|
No_Elimination : Boolean;
|
|
-- Set True if no Eliminate pragmas active
|
|
|
|
---------------------
|
|
-- Data Structures --
|
|
---------------------
|
|
|
|
-- A single pragma Eliminate is represented by the following record
|
|
|
|
type Elim_Data;
|
|
type Access_Elim_Data is access Elim_Data;
|
|
|
|
type Names is array (Nat range <>) of Name_Id;
|
|
-- Type used to represent set of names. Used for names in Unit_Name
|
|
-- and also the set of names in Argument_Types.
|
|
|
|
type Access_Names is access Names;
|
|
|
|
type Elim_Data is record
|
|
|
|
Unit_Name : Access_Names;
|
|
-- Unit name, broken down into a set of names (e.g. A.B.C is
|
|
-- represented as Name_Id values for A, B, C in sequence).
|
|
|
|
Entity_Name : Name_Id;
|
|
-- Entity name if Entity parameter if present. If no Entity parameter
|
|
-- was supplied, then Entity_Node is set to Empty, and the Entity_Name
|
|
-- field contains the last identifier name in the Unit_Name.
|
|
|
|
Entity_Scope : Access_Names;
|
|
-- Static scope of the entity within the compilation unit represented by
|
|
-- Unit_Name.
|
|
|
|
Entity_Node : Node_Id;
|
|
-- Save node of entity argument, for posting error messages. Set
|
|
-- to Empty if there is no entity argument.
|
|
|
|
Parameter_Types : Access_Names;
|
|
-- Set to set of names given for parameter types. If no parameter
|
|
-- types argument is present, this argument is set to null.
|
|
|
|
Result_Type : Name_Id;
|
|
-- Result type name if Result_Types parameter present, No_Name if not
|
|
|
|
Source_Location : Name_Id;
|
|
-- String describing the source location of subprogram defining name if
|
|
-- Source_Location parameter present, No_Name if not
|
|
|
|
Hash_Link : Access_Elim_Data;
|
|
-- Link for hash table use
|
|
|
|
Homonym : Access_Elim_Data;
|
|
-- Pointer to next entry with same key
|
|
|
|
Prag : Node_Id;
|
|
-- Node_Id for Eliminate pragma
|
|
|
|
end record;
|
|
|
|
----------------
|
|
-- Hash_Table --
|
|
----------------
|
|
|
|
-- Setup hash table using the Entity_Name field as the hash key
|
|
|
|
subtype Element is Elim_Data;
|
|
subtype Elmt_Ptr is Access_Elim_Data;
|
|
|
|
subtype Key is Name_Id;
|
|
|
|
type Header_Num is range 0 .. 1023;
|
|
|
|
Null_Ptr : constant Elmt_Ptr := null;
|
|
|
|
----------------------
|
|
-- Hash_Subprograms --
|
|
----------------------
|
|
|
|
package Hash_Subprograms is
|
|
|
|
function Equal (F1, F2 : Key) return Boolean;
|
|
pragma Inline (Equal);
|
|
|
|
function Get_Key (E : Elmt_Ptr) return Key;
|
|
pragma Inline (Get_Key);
|
|
|
|
function Hash (F : Key) return Header_Num;
|
|
pragma Inline (Hash);
|
|
|
|
function Next (E : Elmt_Ptr) return Elmt_Ptr;
|
|
pragma Inline (Next);
|
|
|
|
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
|
|
pragma Inline (Set_Next);
|
|
|
|
end Hash_Subprograms;
|
|
|
|
package body Hash_Subprograms is
|
|
|
|
-----------
|
|
-- Equal --
|
|
-----------
|
|
|
|
function Equal (F1, F2 : Key) return Boolean is
|
|
begin
|
|
return F1 = F2;
|
|
end Equal;
|
|
|
|
-------------
|
|
-- Get_Key --
|
|
-------------
|
|
|
|
function Get_Key (E : Elmt_Ptr) return Key is
|
|
begin
|
|
return E.Entity_Name;
|
|
end Get_Key;
|
|
|
|
----------
|
|
-- Hash --
|
|
----------
|
|
|
|
function Hash (F : Key) return Header_Num is
|
|
begin
|
|
return Header_Num (Int (F) mod 1024);
|
|
end Hash;
|
|
|
|
----------
|
|
-- Next --
|
|
----------
|
|
|
|
function Next (E : Elmt_Ptr) return Elmt_Ptr is
|
|
begin
|
|
return E.Hash_Link;
|
|
end Next;
|
|
|
|
--------------
|
|
-- Set_Next --
|
|
--------------
|
|
|
|
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
|
|
begin
|
|
E.Hash_Link := Next;
|
|
end Set_Next;
|
|
end Hash_Subprograms;
|
|
|
|
------------
|
|
-- Tables --
|
|
------------
|
|
|
|
-- The following table records the data for each pragmas, using the
|
|
-- entity name as the hash key for retrieval. Entries in this table
|
|
-- are set by Process_Eliminate_Pragma and read by Check_Eliminated.
|
|
|
|
package Elim_Hash_Table is new Static_HTable (
|
|
Header_Num => Header_Num,
|
|
Element => Element,
|
|
Elmt_Ptr => Elmt_Ptr,
|
|
Null_Ptr => Null_Ptr,
|
|
Set_Next => Hash_Subprograms.Set_Next,
|
|
Next => Hash_Subprograms.Next,
|
|
Key => Key,
|
|
Get_Key => Hash_Subprograms.Get_Key,
|
|
Hash => Hash_Subprograms.Hash,
|
|
Equal => Hash_Subprograms.Equal);
|
|
|
|
-- The following table records entities for subprograms that are
|
|
-- eliminated, and corresponding eliminate pragmas that caused the
|
|
-- elimination. Entries in this table are set by Check_Eliminated
|
|
-- and read by Eliminate_Error_Msg.
|
|
|
|
type Elim_Entity_Entry is record
|
|
Prag : Node_Id;
|
|
Subp : Entity_Id;
|
|
end record;
|
|
|
|
package Elim_Entities is new Table.Table (
|
|
Table_Component_Type => Elim_Entity_Entry,
|
|
Table_Index_Type => Name_Id'Base,
|
|
Table_Low_Bound => First_Name_Id,
|
|
Table_Initial => 50,
|
|
Table_Increment => 200,
|
|
Table_Name => "Elim_Entries");
|
|
|
|
----------------------
|
|
-- Check_Eliminated --
|
|
----------------------
|
|
|
|
procedure Check_Eliminated (E : Entity_Id) is
|
|
Elmt : Access_Elim_Data;
|
|
Scop : Entity_Id;
|
|
Form : Entity_Id;
|
|
|
|
begin
|
|
if No_Elimination then
|
|
return;
|
|
|
|
-- Elimination of objects and types is not implemented yet
|
|
|
|
elsif Ekind (E) not in Subprogram_Kind then
|
|
return;
|
|
end if;
|
|
|
|
-- Loop through homonyms for this key
|
|
|
|
Elmt := Elim_Hash_Table.Get (Chars (E));
|
|
while Elmt /= null loop
|
|
Check_Homonyms : declare
|
|
procedure Set_Eliminated;
|
|
-- Set current subprogram entity as eliminated
|
|
|
|
--------------------
|
|
-- Set_Eliminated --
|
|
--------------------
|
|
|
|
procedure Set_Eliminated is
|
|
begin
|
|
if Is_Dispatching_Operation (E) then
|
|
|
|
-- If an overriding dispatching primitive is eliminated then
|
|
-- its parent must have been eliminated.
|
|
|
|
if Is_Overriding_Operation (E)
|
|
and then not Is_Eliminated (Overridden_Operation (E))
|
|
then
|
|
Error_Msg_Name_1 := Chars (E);
|
|
Error_Msg_N ("cannot eliminate subprogram %", E);
|
|
return;
|
|
end if;
|
|
end if;
|
|
|
|
Set_Is_Eliminated (E);
|
|
Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
|
|
end Set_Eliminated;
|
|
|
|
-- Start of processing for Check_Homonyms
|
|
|
|
begin
|
|
-- First we check that the name of the entity matches
|
|
|
|
if Elmt.Entity_Name /= Chars (E) then
|
|
goto Continue;
|
|
end if;
|
|
|
|
-- Find enclosing unit
|
|
|
|
Scop := Cunit_Entity (Current_Sem_Unit);
|
|
|
|
-- Now see if compilation unit matches
|
|
|
|
for J in reverse Elmt.Unit_Name'Range loop
|
|
if Elmt.Unit_Name (J) /= Chars (Scop) then
|
|
goto Continue;
|
|
end if;
|
|
|
|
Scop := Scope (Scop);
|
|
while Ekind (Scop) = E_Block loop
|
|
Scop := Scope (Scop);
|
|
end loop;
|
|
|
|
if Scop /= Standard_Standard and then J = 1 then
|
|
goto Continue;
|
|
end if;
|
|
end loop;
|
|
|
|
if Scop /= Standard_Standard then
|
|
goto Continue;
|
|
end if;
|
|
|
|
-- Check for case of given entity is a library level subprogram
|
|
-- and we have the single parameter Eliminate case, a match!
|
|
|
|
if Is_Compilation_Unit (E)
|
|
and then Is_Subprogram (E)
|
|
and then No (Elmt.Entity_Node)
|
|
then
|
|
Set_Eliminated;
|
|
return;
|
|
|
|
-- Check for case of type or object with two parameter case
|
|
|
|
elsif (Is_Type (E) or else Is_Object (E))
|
|
and then Elmt.Result_Type = No_Name
|
|
and then Elmt.Parameter_Types = null
|
|
then
|
|
Set_Eliminated;
|
|
return;
|
|
|
|
-- Check for case of subprogram
|
|
|
|
elsif Ekind (E) = E_Function
|
|
or else Ekind (E) = E_Procedure
|
|
then
|
|
-- If Source_Location present, then see if it matches
|
|
|
|
if Elmt.Source_Location /= No_Name then
|
|
Get_Name_String (Elmt.Source_Location);
|
|
|
|
declare
|
|
Sloc_Trace : constant String :=
|
|
Name_Buffer (1 .. Name_Len);
|
|
|
|
Idx : Natural := Sloc_Trace'First;
|
|
-- Index in Sloc_Trace, if equals to 0, then we have
|
|
-- completely traversed Sloc_Trace
|
|
|
|
Last : constant Natural := Sloc_Trace'Last;
|
|
|
|
P : Source_Ptr;
|
|
Sindex : Source_File_Index;
|
|
|
|
function File_Name_Match return Boolean;
|
|
-- This function is supposed to be called when Idx points
|
|
-- to the beginning of the new file name, and Name_Buffer
|
|
-- is set to contain the name of the proper source file
|
|
-- from the chain corresponding to the Sloc of E. First
|
|
-- it checks that these two files have the same name. If
|
|
-- this check is successful, moves Idx to point to the
|
|
-- beginning of the column number.
|
|
|
|
function Line_Num_Match return Boolean;
|
|
-- This function is supposed to be called when Idx points
|
|
-- to the beginning of the column number, and P is
|
|
-- set to point to the proper Sloc the chain
|
|
-- corresponding to the Sloc of E. First it checks that
|
|
-- the line number Idx points on and the line number
|
|
-- corresponding to P are the same. If this check is
|
|
-- successful, moves Idx to point to the beginning of
|
|
-- the next file name in Sloc_Trace. If there is no file
|
|
-- name any more, Idx is set to 0.
|
|
|
|
function Different_Trace_Lengths return Boolean;
|
|
-- From Idx and P, defines if there are in both traces
|
|
-- more element(s) in the instantiation chains. Returns
|
|
-- False if one trace contains more element(s), but
|
|
-- another does not. If both traces contains more
|
|
-- elements (that is, the function returns False), moves
|
|
-- P ahead in the chain corresponding to E, recomputes
|
|
-- Sindex and sets the name of the corresponding file in
|
|
-- Name_Buffer
|
|
|
|
function Skip_Spaces return Natural;
|
|
-- If Sloc_Trace (Idx) is not space character, returns
|
|
-- Idx. Otherwise returns the index of the nearest
|
|
-- non-space character in Sloc_Trace to the right of Idx.
|
|
-- Returns 0 if there is no such character.
|
|
|
|
-----------------------------
|
|
-- Different_Trace_Lengths --
|
|
-----------------------------
|
|
|
|
function Different_Trace_Lengths return Boolean is
|
|
begin
|
|
P := Instantiation (Sindex);
|
|
|
|
if (P = No_Location and then Idx /= 0)
|
|
or else
|
|
(P /= No_Location and then Idx = 0)
|
|
then
|
|
return True;
|
|
|
|
else
|
|
if P /= No_Location then
|
|
Sindex := Get_Source_File_Index (P);
|
|
Get_Name_String (File_Name (Sindex));
|
|
end if;
|
|
|
|
return False;
|
|
end if;
|
|
end Different_Trace_Lengths;
|
|
|
|
---------------------
|
|
-- File_Name_Match --
|
|
---------------------
|
|
|
|
function File_Name_Match return Boolean is
|
|
Tmp_Idx : Natural;
|
|
End_Idx : Natural;
|
|
|
|
begin
|
|
if Idx = 0 then
|
|
return False;
|
|
end if;
|
|
|
|
-- Find first colon. If no colon, then return False.
|
|
-- If there is a colon, Tmp_Idx is set to point just
|
|
-- before the colon.
|
|
|
|
Tmp_Idx := Idx - 1;
|
|
loop
|
|
if Tmp_Idx >= Last then
|
|
return False;
|
|
elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
|
|
exit;
|
|
else
|
|
Tmp_Idx := Tmp_Idx + 1;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Find last non-space before this colon. If there is
|
|
-- no space character before this colon, then return
|
|
-- False. Otherwise, End_Idx is set to point to this
|
|
-- non-space character.
|
|
|
|
End_Idx := Tmp_Idx;
|
|
loop
|
|
if End_Idx < Idx then
|
|
return False;
|
|
|
|
elsif Sloc_Trace (End_Idx) /= ' ' then
|
|
exit;
|
|
|
|
else
|
|
End_Idx := End_Idx - 1;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Now see if file name matches what is in Name_Buffer
|
|
-- and if so, step Idx past it and return True. If the
|
|
-- name does not match, return False.
|
|
|
|
if Sloc_Trace (Idx .. End_Idx) =
|
|
Name_Buffer (1 .. Name_Len)
|
|
then
|
|
Idx := Tmp_Idx + 2;
|
|
Idx := Skip_Spaces;
|
|
return True;
|
|
else
|
|
return False;
|
|
end if;
|
|
end File_Name_Match;
|
|
|
|
--------------------
|
|
-- Line_Num_Match --
|
|
--------------------
|
|
|
|
function Line_Num_Match return Boolean is
|
|
N : Int := 0;
|
|
|
|
begin
|
|
if Idx = 0 then
|
|
return False;
|
|
end if;
|
|
|
|
while Idx <= Last
|
|
and then Sloc_Trace (Idx) in '0' .. '9'
|
|
loop
|
|
N := N * 10 +
|
|
(Character'Pos (Sloc_Trace (Idx)) -
|
|
Character'Pos ('0'));
|
|
Idx := Idx + 1;
|
|
end loop;
|
|
|
|
if Get_Physical_Line_Number (P) =
|
|
Physical_Line_Number (N)
|
|
then
|
|
while Idx <= Last and then
|
|
Sloc_Trace (Idx) /= '['
|
|
loop
|
|
Idx := Idx + 1;
|
|
end loop;
|
|
|
|
if Idx <= Last and then
|
|
Sloc_Trace (Idx) = '['
|
|
then
|
|
Idx := Idx + 1;
|
|
Idx := Skip_Spaces;
|
|
else
|
|
Idx := 0;
|
|
end if;
|
|
|
|
return True;
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end Line_Num_Match;
|
|
|
|
-----------------
|
|
-- Skip_Spaces --
|
|
-----------------
|
|
|
|
function Skip_Spaces return Natural is
|
|
Res : Natural;
|
|
|
|
begin
|
|
Res := Idx;
|
|
while Sloc_Trace (Res) = ' ' loop
|
|
Res := Res + 1;
|
|
|
|
if Res > Last then
|
|
Res := 0;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
return Res;
|
|
end Skip_Spaces;
|
|
|
|
begin
|
|
P := Sloc (E);
|
|
Sindex := Get_Source_File_Index (P);
|
|
Get_Name_String (File_Name (Sindex));
|
|
|
|
Idx := Skip_Spaces;
|
|
while Idx > 0 loop
|
|
if not File_Name_Match then
|
|
goto Continue;
|
|
elsif not Line_Num_Match then
|
|
goto Continue;
|
|
end if;
|
|
|
|
if Different_Trace_Lengths then
|
|
goto Continue;
|
|
end if;
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
-- If we have a Result_Type, then we must have a function with
|
|
-- the proper result type.
|
|
|
|
if Elmt.Result_Type /= No_Name then
|
|
if Ekind (E) /= E_Function
|
|
or else Chars (Etype (E)) /= Elmt.Result_Type
|
|
then
|
|
goto Continue;
|
|
end if;
|
|
end if;
|
|
|
|
-- If we have Parameter_Types, they must match
|
|
|
|
if Elmt.Parameter_Types /= null then
|
|
Form := First_Formal (E);
|
|
|
|
if No (Form)
|
|
and then Elmt.Parameter_Types'Length = 1
|
|
and then Elmt.Parameter_Types (1) = No_Name
|
|
then
|
|
-- Parameterless procedure matches
|
|
|
|
null;
|
|
|
|
elsif Elmt.Parameter_Types = null then
|
|
goto Continue;
|
|
|
|
else
|
|
for J in Elmt.Parameter_Types'Range loop
|
|
if No (Form)
|
|
or else
|
|
Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
|
|
then
|
|
goto Continue;
|
|
else
|
|
Next_Formal (Form);
|
|
end if;
|
|
end loop;
|
|
|
|
if Present (Form) then
|
|
goto Continue;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
-- If we fall through, this is match
|
|
|
|
Set_Eliminated;
|
|
return;
|
|
end if;
|
|
end Check_Homonyms;
|
|
|
|
<<Continue>>
|
|
Elmt := Elmt.Homonym;
|
|
end loop;
|
|
|
|
return;
|
|
end Check_Eliminated;
|
|
|
|
-------------------------------------
|
|
-- Check_For_Eliminated_Subprogram --
|
|
-------------------------------------
|
|
|
|
procedure Check_For_Eliminated_Subprogram (N : Node_Id; S : Entity_Id) is
|
|
Ultimate_Subp : constant Entity_Id := Ultimate_Alias (S);
|
|
Enclosing_Subp : Entity_Id;
|
|
|
|
begin
|
|
if Is_Eliminated (Ultimate_Subp)
|
|
and then not Inside_A_Generic
|
|
and then not Is_Generic_Unit (Cunit_Entity (Current_Sem_Unit))
|
|
then
|
|
Enclosing_Subp := Current_Subprogram;
|
|
while Present (Enclosing_Subp) loop
|
|
if Is_Eliminated (Enclosing_Subp) then
|
|
return;
|
|
end if;
|
|
|
|
Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp);
|
|
end loop;
|
|
|
|
Eliminate_Error_Msg (N, Ultimate_Subp);
|
|
end if;
|
|
end Check_For_Eliminated_Subprogram;
|
|
|
|
-------------------------
|
|
-- Eliminate_Error_Msg --
|
|
-------------------------
|
|
|
|
procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
|
|
begin
|
|
for J in Elim_Entities.First .. Elim_Entities.Last loop
|
|
if E = Elim_Entities.Table (J).Subp then
|
|
Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
|
|
Error_Msg_NE ("cannot reference subprogram & eliminated #", N, E);
|
|
return;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If this is an internal operation generated for a protected operation,
|
|
-- its name does not match the source name, so just report the error.
|
|
|
|
if not Comes_From_Source (E)
|
|
and then Present (First_Entity (E))
|
|
and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
|
|
then
|
|
Error_Msg_NE
|
|
("cannot reference eliminated protected subprogram", N, E);
|
|
|
|
-- Otherwise should not fall through, entry should be in table
|
|
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
end Eliminate_Error_Msg;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize is
|
|
begin
|
|
Elim_Hash_Table.Reset;
|
|
Elim_Entities.Init;
|
|
No_Elimination := True;
|
|
end Initialize;
|
|
|
|
------------------------------
|
|
-- Process_Eliminate_Pragma --
|
|
------------------------------
|
|
|
|
procedure Process_Eliminate_Pragma
|
|
(Pragma_Node : Node_Id;
|
|
Arg_Unit_Name : Node_Id;
|
|
Arg_Entity : Node_Id;
|
|
Arg_Parameter_Types : Node_Id;
|
|
Arg_Result_Type : Node_Id;
|
|
Arg_Source_Location : Node_Id)
|
|
is
|
|
Data : constant Access_Elim_Data := new Elim_Data;
|
|
-- Build result data here
|
|
|
|
Elmt : Access_Elim_Data;
|
|
|
|
Num_Names : Nat := 0;
|
|
-- Number of names in unit name
|
|
|
|
Lit : Node_Id;
|
|
Arg_Ent : Entity_Id;
|
|
Arg_Uname : Node_Id;
|
|
|
|
function OK_Selected_Component (N : Node_Id) return Boolean;
|
|
-- Test if N is a selected component with all identifiers, or a
|
|
-- selected component whose selector is an operator symbol. As a
|
|
-- side effect if result is True, sets Num_Names to the number
|
|
-- of names present (identifiers and operator if any).
|
|
|
|
---------------------------
|
|
-- OK_Selected_Component --
|
|
---------------------------
|
|
|
|
function OK_Selected_Component (N : Node_Id) return Boolean is
|
|
begin
|
|
if Nkind (N) = N_Identifier
|
|
or else Nkind (N) = N_Operator_Symbol
|
|
then
|
|
Num_Names := Num_Names + 1;
|
|
return True;
|
|
|
|
elsif Nkind (N) = N_Selected_Component then
|
|
return OK_Selected_Component (Prefix (N))
|
|
and then OK_Selected_Component (Selector_Name (N));
|
|
|
|
else
|
|
return False;
|
|
end if;
|
|
end OK_Selected_Component;
|
|
|
|
-- Start of processing for Process_Eliminate_Pragma
|
|
|
|
begin
|
|
Data.Prag := Pragma_Node;
|
|
Error_Msg_Name_1 := Name_Eliminate;
|
|
|
|
-- Process Unit_Name argument
|
|
|
|
if Nkind (Arg_Unit_Name) = N_Identifier then
|
|
Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
|
|
Num_Names := 1;
|
|
|
|
elsif OK_Selected_Component (Arg_Unit_Name) then
|
|
Data.Unit_Name := new Names (1 .. Num_Names);
|
|
|
|
Arg_Uname := Arg_Unit_Name;
|
|
for J in reverse 2 .. Num_Names loop
|
|
Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
|
|
Arg_Uname := Prefix (Arg_Uname);
|
|
end loop;
|
|
|
|
Data.Unit_Name (1) := Chars (Arg_Uname);
|
|
|
|
else
|
|
Error_Msg_N
|
|
("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
|
|
return;
|
|
end if;
|
|
|
|
-- Process Entity argument
|
|
|
|
if Present (Arg_Entity) then
|
|
Num_Names := 0;
|
|
|
|
if Nkind (Arg_Entity) = N_Identifier
|
|
or else Nkind (Arg_Entity) = N_Operator_Symbol
|
|
then
|
|
Data.Entity_Name := Chars (Arg_Entity);
|
|
Data.Entity_Node := Arg_Entity;
|
|
Data.Entity_Scope := null;
|
|
|
|
elsif OK_Selected_Component (Arg_Entity) then
|
|
Data.Entity_Scope := new Names (1 .. Num_Names - 1);
|
|
Data.Entity_Name := Chars (Selector_Name (Arg_Entity));
|
|
Data.Entity_Node := Arg_Entity;
|
|
|
|
Arg_Ent := Prefix (Arg_Entity);
|
|
for J in reverse 2 .. Num_Names - 1 loop
|
|
Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
|
|
Arg_Ent := Prefix (Arg_Ent);
|
|
end loop;
|
|
|
|
Data.Entity_Scope (1) := Chars (Arg_Ent);
|
|
|
|
elsif Is_Config_Static_String (Arg_Entity) then
|
|
Data.Entity_Name := Name_Find;
|
|
Data.Entity_Node := Arg_Entity;
|
|
|
|
else
|
|
return;
|
|
end if;
|
|
else
|
|
Data.Entity_Node := Empty;
|
|
Data.Entity_Name := Data.Unit_Name (Num_Names);
|
|
end if;
|
|
|
|
-- Process Parameter_Types argument
|
|
|
|
if Present (Arg_Parameter_Types) then
|
|
|
|
-- Here for aggregate case
|
|
|
|
if Nkind (Arg_Parameter_Types) = N_Aggregate then
|
|
Data.Parameter_Types :=
|
|
new Names
|
|
(1 .. List_Length (Expressions (Arg_Parameter_Types)));
|
|
|
|
Lit := First (Expressions (Arg_Parameter_Types));
|
|
for J in Data.Parameter_Types'Range loop
|
|
if Is_Config_Static_String (Lit) then
|
|
Data.Parameter_Types (J) := Name_Find;
|
|
Next (Lit);
|
|
else
|
|
return;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Otherwise we must have case of one name, which looks like a
|
|
-- parenthesized literal rather than an aggregate.
|
|
|
|
elsif Paren_Count (Arg_Parameter_Types) /= 1 then
|
|
Error_Msg_N
|
|
("wrong form for argument of pragma Eliminate",
|
|
Arg_Parameter_Types);
|
|
return;
|
|
|
|
elsif Is_Config_Static_String (Arg_Parameter_Types) then
|
|
String_To_Name_Buffer (Strval (Arg_Parameter_Types));
|
|
|
|
if Name_Len = 0 then
|
|
|
|
-- Parameterless procedure
|
|
|
|
Data.Parameter_Types := new Names'(1 => No_Name);
|
|
|
|
else
|
|
Data.Parameter_Types := new Names'(1 => Name_Find);
|
|
end if;
|
|
|
|
else
|
|
return;
|
|
end if;
|
|
end if;
|
|
|
|
-- Process Result_Types argument
|
|
|
|
if Present (Arg_Result_Type) then
|
|
if Is_Config_Static_String (Arg_Result_Type) then
|
|
Data.Result_Type := Name_Find;
|
|
else
|
|
return;
|
|
end if;
|
|
|
|
-- Here if no Result_Types argument
|
|
|
|
else
|
|
Data.Result_Type := No_Name;
|
|
end if;
|
|
|
|
-- Process Source_Location argument
|
|
|
|
if Present (Arg_Source_Location) then
|
|
if Is_Config_Static_String (Arg_Source_Location) then
|
|
Data.Source_Location := Name_Find;
|
|
else
|
|
return;
|
|
end if;
|
|
else
|
|
Data.Source_Location := No_Name;
|
|
end if;
|
|
|
|
Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
|
|
|
|
-- If we already have an entry with this same key, then link
|
|
-- it into the chain of entries for this key.
|
|
|
|
if Elmt /= null then
|
|
Data.Homonym := Elmt.Homonym;
|
|
Elmt.Homonym := Data;
|
|
|
|
-- Otherwise create a new entry
|
|
|
|
else
|
|
Elim_Hash_Table.Set (Data);
|
|
end if;
|
|
|
|
No_Elimination := False;
|
|
end Process_Eliminate_Pragma;
|
|
|
|
end Sem_Elim;
|