6cbcc54138
* xeinfo.adb: Don't look for revision numbers. * xnmake.adb: Likewise. * xsinfo.adb: Likewise. * xsnames.adb: Likewise. * xtreeprs.adb: Likewise. From-SVN: r50768
589 lines
18 KiB
Ada
589 lines
18 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S E M _ E L I M --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- --
|
|
-- Copyright (C) 1997-2001 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 2, 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 COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Einfo; use Einfo;
|
|
with Errout; use Errout;
|
|
with Namet; use Namet;
|
|
with Nlists; use Nlists;
|
|
with Sinfo; use Sinfo;
|
|
with Snames; use Snames;
|
|
with Stand; use Stand;
|
|
with Stringt; use Stringt;
|
|
with Uintp; use Uintp;
|
|
|
|
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
|
|
|
|
Homonym_Number : Uint;
|
|
-- Homonyn number if Homonym_Number parameter present, No_Uint if not.
|
|
|
|
Hash_Link : Access_Elim_Data;
|
|
-- Link for hash table use
|
|
|
|
Homonym : Access_Elim_Data;
|
|
-- Pointer to next entry with same key
|
|
|
|
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;
|
|
|
|
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);
|
|
|
|
----------------------
|
|
-- Check_Eliminated --
|
|
----------------------
|
|
|
|
procedure Check_Eliminated (E : Entity_Id) is
|
|
Elmt : Access_Elim_Data;
|
|
Scop : Entity_Id;
|
|
Form : Entity_Id;
|
|
Ctr : Nat;
|
|
Ent : 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;
|
|
|
|
Elmt := Elim_Hash_Table.Get (Chars (E));
|
|
|
|
-- Loop through homonyms for this key
|
|
|
|
while Elmt /= null loop
|
|
|
|
-- First we check that the name of the entity matches
|
|
|
|
if Elmt.Entity_Name /= Chars (E) then
|
|
goto Continue;
|
|
end if;
|
|
|
|
-- Then we need to see if the static scope matches within the
|
|
-- compilation unit.
|
|
|
|
Scop := Scope (E);
|
|
if Elmt.Entity_Scope /= null then
|
|
for J in reverse Elmt.Entity_Scope'Range loop
|
|
if Elmt.Entity_Scope (J) /= Chars (Scop) then
|
|
goto Continue;
|
|
end if;
|
|
|
|
Scop := Scope (Scop);
|
|
|
|
if not Is_Compilation_Unit (Scop) and then J = 1 then
|
|
goto Continue;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
-- 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);
|
|
|
|
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_Is_Eliminated (E);
|
|
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_Is_Eliminated (E);
|
|
return;
|
|
|
|
-- Check for case of subprogram
|
|
|
|
elsif Ekind (E) = E_Function
|
|
or else Ekind (E) = E_Procedure
|
|
then
|
|
-- If Homonym_Number present, then see if it matches
|
|
|
|
if Elmt.Homonym_Number /= No_Uint then
|
|
Ctr := 1;
|
|
|
|
Ent := E;
|
|
while Present (Homonym (Ent))
|
|
and then Scope (Ent) = Scope (Homonym (Ent))
|
|
loop
|
|
Ctr := Ctr + 1;
|
|
Ent := Homonym (Ent);
|
|
end loop;
|
|
|
|
if Ctr /= Elmt.Homonym_Number then
|
|
goto Continue;
|
|
end if;
|
|
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 = null then
|
|
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_Is_Eliminated (E);
|
|
return;
|
|
end if;
|
|
|
|
<<Continue>> Elmt := Elmt.Homonym;
|
|
end loop;
|
|
|
|
return;
|
|
end Check_Eliminated;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize is
|
|
begin
|
|
Elim_Hash_Table.Reset;
|
|
No_Elimination := True;
|
|
end Initialize;
|
|
|
|
------------------------------
|
|
-- Process_Eliminate_Pragma --
|
|
------------------------------
|
|
|
|
procedure Process_Eliminate_Pragma
|
|
(Arg_Unit_Name : Node_Id;
|
|
Arg_Entity : Node_Id;
|
|
Arg_Parameter_Types : Node_Id;
|
|
Arg_Result_Type : Node_Id;
|
|
Arg_Homonym_Number : 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
|
|
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 Nkind (Arg_Entity) = N_String_Literal then
|
|
String_To_Name_Buffer (Strval (Arg_Entity));
|
|
Data.Entity_Name := Name_Find;
|
|
Data.Entity_Node := Arg_Entity;
|
|
|
|
else
|
|
Error_Msg_N
|
|
("wrong form for Entity_Argument parameter of pragma%",
|
|
Arg_Unit_Name);
|
|
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
|
|
|
|
-- Case of one name, which looks like a parenthesized literal
|
|
-- rather than an aggregate.
|
|
|
|
if Nkind (Arg_Parameter_Types) = N_String_Literal
|
|
and then Paren_Count (Arg_Parameter_Types) = 1
|
|
then
|
|
String_To_Name_Buffer (Strval (Arg_Parameter_Types));
|
|
Data.Parameter_Types := new Names'(1 => Name_Find);
|
|
|
|
-- Otherwise must be an aggregate
|
|
|
|
elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
|
|
or else Present (Component_Associations (Arg_Parameter_Types))
|
|
or else No (Expressions (Arg_Parameter_Types))
|
|
then
|
|
Error_Msg_N
|
|
("Parameter_Types for pragma% must be list of string literals",
|
|
Arg_Parameter_Types);
|
|
return;
|
|
|
|
-- Here for aggregate case
|
|
|
|
else
|
|
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 Nkind (Lit) /= N_String_Literal then
|
|
Error_Msg_N
|
|
("parameter types for pragma% must be string literals",
|
|
Lit);
|
|
return;
|
|
end if;
|
|
|
|
String_To_Name_Buffer (Strval (Lit));
|
|
Data.Parameter_Types (J) := Name_Find;
|
|
Next (Lit);
|
|
end loop;
|
|
end if;
|
|
end if;
|
|
|
|
-- Process Result_Types argument
|
|
|
|
if Present (Arg_Result_Type) then
|
|
|
|
if Nkind (Arg_Result_Type) /= N_String_Literal then
|
|
Error_Msg_N
|
|
("Result_Type argument for pragma% must be string literal",
|
|
Arg_Result_Type);
|
|
return;
|
|
end if;
|
|
|
|
String_To_Name_Buffer (Strval (Arg_Result_Type));
|
|
Data.Result_Type := Name_Find;
|
|
|
|
else
|
|
Data.Result_Type := No_Name;
|
|
end if;
|
|
|
|
-- Process Homonym_Number argument
|
|
|
|
if Present (Arg_Homonym_Number) then
|
|
|
|
if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then
|
|
Error_Msg_N
|
|
("Homonym_Number argument for pragma% must be integer literal",
|
|
Arg_Homonym_Number);
|
|
return;
|
|
end if;
|
|
|
|
Data.Homonym_Number := Intval (Arg_Homonym_Number);
|
|
|
|
else
|
|
Data.Homonym_Number := No_Uint;
|
|
end if;
|
|
|
|
-- Now link this new entry into the hash table
|
|
|
|
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;
|