------------------------------------------------------------------------------
-- --
-- GNATELIM COMPONENTS --
-- --
-- G N A T E L I M . A N A L Y S I S --
-- --
-- B o d y --
-- --
-- $Revision: 1.32 $
-- --
-- Copyright (c) 1997-2002, Free Software Foundation, Inc. --
-- --
-- Gnatelim is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. Gnatelim is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY 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. --
-- --
-- Gnatelim is distributed as a part of the ASIS implementation for GNAT --
-- (ASIS-for-GNAT). --
-- --
-- Gnatelim was originally developed by Alain Le Guennec --
-- --
-- Gnatelim is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
------------------------------------------------------------------------------
with GNATELIM.Options; use GNATELIM.Options;
with GNATELIM.Errors; use GNATELIM.Errors;
with GNATELIM.Entities; use GNATELIM.Entities;
with Asis.Compilation_Units; use Asis.Compilation_Units;
with Asis.Elements; use Asis.Elements;
with Asis.Declarations; use Asis.Declarations;
with Asis.Expressions; use Asis.Expressions;
with Asis.Statements; use Asis.Statements;
with Asis.Text; use Asis.Text;
with Asis.Iterator; use Asis;
with Asis.Extensions;
-- Asis.Extensions is not 'used',
-- to make non-standard queries more visible.
with Ada.Characters.Handling; use Ada.Characters.Handling;
package body GNATELIM.Analysis is
type State_Information is record
Depth : Natural;
Scope : Entity_Id;
Instance : Entity_Id;
end record;
-- State during tree-traversal.
-- Depth represents the nesting level wrt. to the top-level element.
-------------------------
-- Local subprograms --
-------------------------
procedure Pre_Operation (Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out State_Information);
procedure Post_Operation (Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out State_Information);
procedure Traverse_Tree is new Asis.Iterator.Traverse_Element
(State_Information, Pre_Operation, Post_Operation);
procedure Analyze_Element (Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out State_Information);
-- Called by Pre_Operation.
-- Checks whether the currently traversed element corresponds
-- to either a declaration of interest or a use of such an entity
-- (via a call, an attribute reference, and so on...)
function Is_A_Scope (Element : Asis.Element) return Boolean;
-- Returns True if Element represents an interesting Entity,
-- ie. one that can be registered and that makes for a new scope.
function Defining_Names (Element : Asis.Element)
return Asis.Defining_Name_List;
-- Returns the list of defining names declared by the Element.
-- If Element is A_Declaration, returns all defining names enclosed.
-- If Element is A_Statement, returns the Statement_Identifier, if any,
-- and the statement Element unchanged otherwise.
-- Returns a list of 'Length zero in all other cases.
function Corresponding_Name (Element : Asis.Element;
Scope : Entity_Id)
return Wide_String;
-- Returns the name that should be given to the Entity
-- based on its Element and Scope components.
-- The name of A_Defining_name Element is the defining_name.
-- The name of A_Statement is the Statement_Identifier, if any.
-- Other internal entities will have "appropriate" names.
function Is_A_Completion (Element : Asis.Element) return Boolean;
-- Returns True if Element completes a previous declaration.
function Corresponding_Master (Scope : Entity_Id)
return Entity_Id;
-- Returns the master of the Scope (which may be the Scope itself.)
-- No_Entity as a result means that the master is the environment task.
procedure New_Scope (Element : Asis.Element;
Instance : Entity_Id;
Scope : Entity_Id);
-- Called when an Is_A_Scope (Element) is found.
-- An Entity corresponding to this Element is built and registered.
-- Then the sub-tree is scanned for nested elements of interest.
-------------------------
-- Analyze_Partition --
-------------------------
procedure Analyze_Partition
(Main_Subprogram : Asis.Compilation_Unit;
Composed_Of : Asis.Compilation_Unit_List)
is
Main_Element : Asis.Element;
procedure Print_Subunits (U : Asis.Compilation_Unit);
-- Provided that U is of A_Library_Unit_Body or A_Subunit kind,
-- recursively prints out the list of all its subunit
procedure Print_Subunits (U : Asis.Compilation_Unit) is
Sub_Units : Asis.Compilation_Unit_List := Subunits (U);
begin
for J in Sub_Units'Range loop
Warning (Asis.Compilation_Units.Text_Name (Sub_Units (J)), True);
Print_Subunits (Sub_Units (J));
end loop;
end Print_Subunits;
begin
-- This should be revised as soon as the queries
-- the in A.CU.Relations package are available.
-- We simulate a traversal of the environment task.
-- Some reordering of units may save tree swapping...
for U in Composed_Of'Range loop
declare
Unit : Asis.Compilation_Unit := Composed_Of (U);
Unit_Body : Asis.Compilation_Unit;
Unit_Element : Asis.Declaration;
begin
Warning (Asis.Compilation_Units.Text_Name (Unit), True);
if Unit_Kind (Unit) in A_Library_Unit_Body then
Print_Subunits (Unit);
end if;
if Is_Nil (Unit)
or else (Dont_Eliminate_In_RTS
and then Unit_Origin (Unit) /= An_Application_Unit)
then
Unit_Element := Nil_Element;
else
Unit_Body := Corresponding_Body (Unit);
if not Is_Nil (Unit_Body) then
-- Let's swap in the .atb file !
Unit_Element := Unit_Declaration (Unit_Body);
end if;
Unit_Element := Unit_Declaration (Unit);
end if;
if not Is_Nil (Unit_Element) then
New_Scope (Element => Unit_Element,
Instance => No_Entity,
Scope => No_Entity);
end if;
end;
end loop;
-- Consider the implicit call from the environment task
-- to the Main subprogram like any other call.
-- Note that there need not be any main subprogram.
if not Is_Nil (Main_Subprogram) then
Main_Element := Asis.Elements.Unit_Declaration (Main_Subprogram);
Note_Use (Entity =>
Corresponding_Entity (Element => Main_Element,
Instance => No_Entity),
Used_By => No_Entity);
end if;
-- Now the transitive-closure can begin.
Perform_Transitive_Closure;
end Analyze_Partition;
---------------------
-- Pre_Operation --
---------------------
procedure Pre_Operation (Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out State_Information) is
begin
State.Depth := State.Depth + 1;
if State.Depth > 1 then
-- We analyze only elements _nested_ inside the top-level element.
Analyze_Element (Element, Control, State);
-- Depending on the new value of Control,
-- the call to Post_Operation may be skipped.
-- In that case, the Depth must be adjusted here.
if Control = Abandon_Children
or else Control = Abandon_Siblings
then
State.Depth := State.Depth - 1;
elsif Control = Terminate_Immediately then
State.Depth := 0;
end if;
end if;
end Pre_Operation;
----------------------
-- Post_Operation --
----------------------
procedure Post_Operation (Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out State_Information) is
begin
pragma Unreferenced (Element);
pragma Unreferenced (Control);
State.Depth := State.Depth - 1;
end Post_Operation;
------------------
-- Is_A_Scope --
------------------
function Is_A_Scope (Element : Asis.Element) return Boolean is
begin
case Element_Kind (Element) is
when A_Declaration =>
case Declaration_Kind (Element) is
when A_Procedure_Declaration
| A_Function_Declaration
| A_Procedure_Body_Declaration
| A_Function_Body_Declaration
| A_Package_Declaration
| A_Package_Body_Declaration
| A_Task_Type_Declaration
| A_Protected_Type_Declaration
| A_Single_Task_Declaration
| A_Single_Protected_Declaration
| A_Task_Body_Declaration
| A_Protected_Body_Declaration
| A_Procedure_Body_Stub
| A_Function_Body_Stub
| A_Package_Body_Stub
| A_Task_Body_Stub
| A_Protected_Body_Stub
| A_Generic_Procedure_Declaration
| A_Generic_Function_Declaration
| A_Generic_Package_Declaration
| A_Generic_Package_Renaming_Declaration
| A_Generic_Procedure_Renaming_Declaration
| A_Generic_Function_Renaming_Declaration
| A_Formal_Procedure_Declaration
| A_Formal_Function_Declaration
| A_Formal_Package_Declaration
| A_Package_Renaming_Declaration
| A_Procedure_Renaming_Declaration
| A_Function_Renaming_Declaration
| A_Package_Instantiation
| A_Function_Instantiation
| A_Procedure_Instantiation
=> return True;
when others => null;
end case;
when A_Statement =>
case Statement_Kind (Element) is
when A_Block_Statement
=> return True;
when others => null;
end case;
when others => null;
end case;
return False;
end Is_A_Scope;
----------------------
-- Defining_Names --
----------------------
function Defining_Names (Element : Asis.Element)
return Asis.Defining_Name_List is
begin
case Element_Kind (Element) is
when A_Declaration =>
return Asis.Declarations.Names (Element);
when A_Statement =>
case Statement_Kind (Element) is
when A_Loop_Statement
| A_While_Loop_Statement
| A_For_Loop_Statement
| A_Block_Statement
=>
declare
Name : Asis.Defining_Name :=
Statement_Identifier (Element);
begin
if not Is_Nil (Name) then
return Defining_Name_List '(1 => Name);
else
return Defining_Name_List '(1 => Element);
end if;
end;
when others => null;
end case;
when others => null;
end case;
return Nil_Element_List;
end Defining_Names;
--------------------------
-- Corresponding_Name --
--------------------------
function Corresponding_Name (Element : Asis.Element;
Scope : Entity_Id)
return Wide_String is
begin
pragma Unreferenced (Scope); -- ????
case Element_Kind (Element) is
when A_Defining_Name =>
return Defining_Name_Image (Element);
when A_Statement =>
case Statement_Kind (Element) is
-- ??? incorrect but should not make gnatelim to
-- function improperly
when A_Block_Statement =>
return "INTERNAL";
when others => null;
end case;
when others => null;
end case;
return "";
end Corresponding_Name;
-----------------------
-- Is_A_Completion --
-----------------------
function Is_A_Completion (Element : Asis.Element) return Boolean is
begin
case Declaration_Kind (Element) is
when A_Package_Body_Declaration
| A_Package_Body_Stub
| A_Task_Body_Declaration
| A_Protected_Body_Declaration
| A_Task_Body_Stub
| A_Protected_Body_Stub =>
return True;
when A_Renaming_Declaration =>
return Asis.Extensions.Is_Renaming_As_Body (Element);
when A_Procedure_Body_Declaration
| A_Function_Body_Declaration
| A_Procedure_Body_Stub
| A_Function_Body_Stub =>
return not Asis.Extensions.Acts_As_Spec (Element);
when others =>
return False;
end case;
end Is_A_Completion;
----------------------------
-- Corresponding_Master --
----------------------------
function Corresponding_Master (Scope : Entity_Id)
return Entity_Id is
Master : Entity_Id := Scope;
begin
while not Is_A_Master (Master)
loop
Master := Get_Scope (Master);
end loop;
return Master;
end Corresponding_Master;
-----------------
-- New_Scope --
-----------------
procedure New_Scope (Element : Asis.Element;
Instance : Entity_Id;
Scope : Entity_Id)
is
Declaration : Asis.Element;
Completion : Asis.Element;
Entity : Entity_Id;
Control : Asis.Traverse_Control;
State : State_Information;
begin
pragma Assert (Is_A_Scope (Element));
-- We do not register entity completion, only the first declaration.
if not Is_A_Completion (Element) then
-- This is not a declaration of a previous declaration.
-- It is its own completion.
Completion := Asis.Nil_Element;
Declaration := Element;
declare
Names : Asis.Defining_Name_List := Defining_Names (Element);
Next_Name : ASIS_Natural;
begin
for DN in Names'Range loop
declare
Name : Wide_String := Corresponding_Name (Names (DN), Scope);
begin
Next_Name := DN;
Entity := New_Entity (Names (DN), Instance, Name, Scope);
Warning ("gnatelim: " & Name & " registered.");
-- if Defining_Name_Kind (Names (DN)) = A_Defining_Operator_Symbol then
-- -- GNAT does not handle elimination of operators as of 05/13/1999
-- Note_Use (Entity => Entity, Used_By => No_Entity);
-- Warning ("This is an operator function, can't be eliminated yet.");
-- end if;
if Operator_Kind (Names (DN)) = An_Equal_Operator then
-- Since ASIS-for-GNAT doesn't have implementation for
-- Corresponding_Equality_Operator as of 11/29/99, all
-- "=" operators are marked as used so that there aren't
-- any problems with "/=" operators
Note_Use (Entity => Entity, Used_By => No_Entity);
Warning ("Equality operator, can't be eliminated yet.");
end if;
exception
when Already_Registered =>
Error
("gnatelim: an entity has been registered twice !" &
Delimiter_Image &
"Element =>" &
Debug_Image (Names (Next_Name)) &
Delimiter_Image &
"Instance =>" &
Delimiter_Image &
Debug_Image (Get_Element (Instance)) &
Delimiter_Image &
"Name => " &
Name &
Delimiter_Image &
"Scope => " &
Delimiter_Image &
Debug_Image (Get_Element (Scope)));
end;
end loop;
end;
else
-- A completion: let's get the completed declaration.
Completion := Element;
Declaration := Corresponding_Declaration (Completion);
Entity := Corresponding_Entity (Declaration, Instance);
end if;
case Declaration_Kind (Element) is
when A_Body_Stub =>
-- The proper body is processed in the same scope
-- as its corresponding stub.
declare
Proper_Body : Asis.Declaration;
begin
-- We get the proper body corresponding to the stub.
-- At the moment (3.10), this WILL cause tree-swapping,
-- but in future GNAT releases, the proper-bodies
-- will be in the same tree as the corresponding stub,
-- hence solving this pb.
Warning ("gnatelim: going from stub to proper body.");
Proper_Body := Corresponding_Subunit (Element);
if Is_Nil (Proper_Body) then
Error
("gnatelim: couldn't find the proper body of a subunit.");
else
Control := Asis.Continue;
State.Depth := 0;
State.Instance := Instance;
State.Scope := Entity;
Traverse_Tree (Proper_Body, Control, State);
pragma Assert (State.Depth = 0);
end if;
end;
when A_Renaming_Declaration =>
declare
Renamed : Asis.Expression := Renamed_Entity (Element);
begin
-- The renamed entity is linked to its renaming.
Warning ("gnatelim: unwinding a renaming declaration.");
Note_Use (Entity => Corresponding_Entity (Renamed, Instance),
Used_By => Entity);
Control := Asis.Continue;
State.Depth := 0;
State.Instance := Instance;
State.Scope := Scope;
Traverse_Tree (Renamed, Control, State);
pragma Assert (State.Depth = 0);
end;
when A_Generic_Instantiation =>
declare
Gen_Inst : Asis.Declaration;
begin
-- We get the instantiation
Warning ("gnatelim: going to instance declaration.");
Gen_Inst := Corresponding_Declaration (Element);
if Is_Nil (Gen_Inst) then
Error
("gnatelim: couldn't find the instance declaration.");
else
New_Scope (Gen_Inst, Instance, Get_Scope (Entity));
end if;
Warning ("gnatelim: going to instance body."
& Debug_Image (Element));
Gen_Inst := Corresponding_Body (Element);
if Is_Nil (Gen_Inst) then
Warning
("gnatelim: couldn't find the instance body.");
else
New_Scope (Gen_Inst, Instance, Get_Scope (Entity));
end if;
end;
when others =>
null;
end case;
-- Since tracking calls to dispatching operations
-- is too complex, we mark them as used, always.
begin
if Asis.Declarations.Is_Dispatching_Operation (Element) then
Warning ("gnatelim: dispatching operation found.");
Note_Use (Entity => Entity,
Used_By => No_Entity);
end if;
exception
when others =>
-- There is a bug in Is_Dispatching_Operation...
Error
("gnatelim: ASIS-BUG : Is_Dispatching_Operation crashed for "
& Get_Name (Entity));
end;
if not (Declaration_Kind (Declaration) in A_Generic_Declaration) then
-- Then we traverse the ASIS-Tree rooted at this element.
-- Content of generic unit is not traversed.
Control := Asis.Continue;
State.Depth := 0;
State.Instance := Instance;
State.Scope := Entity;
Traverse_Tree (Element, Control, State);
pragma Assert (State.Depth = 0);
end if;
end New_Scope;
-----------------------
-- Analyze_Element --
-----------------------
procedure Analyze_Element (Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out State_Information) is
Scope : Entity_Id renames State.Scope;
Instance : Entity_Id renames State.Instance;
begin -- Analyze_Element
--------------------------------------------------------
-- Check if found a nested declaration of interest, --
-- to be inserted in the table. --
--------------------------------------------------------
if Is_A_Scope (Element) then
Control := Asis.Abandon_Children;
New_Scope (Element => Element,
Instance => Instance,
Scope => Scope);
end if;
if Expression_Kind (Element) = A_Function_Call
or else Statement_Kind (Element) = A_Procedure_Call_Statement
then
-------------------------------------
-- A subprogram call to analyze. --
-------------------------------------
-- We'll have to analyze the parameters !!! Not done yet.
declare
Call_Point : Asis.Element renames Element;
Called_Element : Asis.Element;
Called_Entity : Entity_Id;
begin
-- Optimally, we would have to check if default values
-- for parameters are overriden for this call, and if not,
-- we should analyze the default expression in the profile.
-- Currently, we always analyze default expression when we
-- encounter the spec, which is a lot more pessimistic.
if Statement_Kind (Call_Point) = A_Procedure_Call_Statement then
Called_Element := Corresponding_Called_Entity (Call_Point);
elsif Expression_Kind (Call_Point) = A_Function_Call then
Called_Element := Corresponding_Called_Function (Call_Point);
end if;
Called_Entity := Corresponding_Entity (Called_Element, Instance);
-- It is not always possible to statically determine
-- which subprogram is called, because either:
-- ------------------------------------------
-- -the call is a dispatching call to a dispatching operation
-- -the prefix is an attribute_reference ('Image, 'Succ ...)
-- (what about stream-attributes redefined by the user ?)
-- -the prefix is an access_to_subprogram dereference
-- Dispatching calls are not handled at this level.
-- Instead, we mark all dispatching operations as used
-- when their declaration is encountered.
-- This is a bit pessimistic, but safe.
-- We eventually have a subprogram declaration to analyze.
Note_Use (Entity => Called_Entity,
Used_By => Corresponding_Master (Scope));
end;
elsif Attribute_Kind (Element) = An_Access_Attribute or else
Attribute_Kind (Element) = An_Address_Attribute or else
Attribute_Kind (Element) = An_Implementation_Defined_Attribute
-- ??? is it safe enough to include just
-- ??? An_Implementation_Defined_Attribute in the condition
-- ??? (the goal is to check the GNAT-specific
-- ??? Unrestricted_Access attribute)
then
-------------------------------------------------
-- A possible 'Accessed element to analyze ? --
-------------------------------------------------
declare
Referenced_Entity : Entity_Id :=
Corresponding_Entity (Prefix (Element), Instance);
begin
Note_Use (Entity => Referenced_Entity,
Used_By => Corresponding_Master (Scope));
end;
elsif Element_Kind (Element) = A_Pragma then
------------------------------------------------
-- A possible exported subprogram to mark ? --
------------------------------------------------
declare
Pragma_Name : String :=
To_Lower (To_String (Pragma_Name_Image (Element)));
begin
if not (Pragma_Name = "export" or else
Pragma_Name = "export_function" or else
Pragma_Name = "export_procedure" or else
Pragma_Name = "export_valued_procedure" or else
Pragma_Name = "export_object")
-- and then Pragma_Name /= "whatever_you_want"
then
-- Not an interesting pragma. Giving up.
Control := Abandon_Children;
return;
end if;
end;
-- If we arrive here, it means we have an interesting pragma.
declare
Arguments : Asis.Association_List :=
Pragma_Argument_Associations (Element);
Referenced_Entity : Entity_Id;
begin
for A in Arguments'Range loop
Referenced_Entity :=
Corresponding_Entity (Actual_Parameter (Arguments (A)),
Instance);
if Present (Referenced_Entity) then
Note_Use (Entity => Referenced_Entity,
Used_By => No_Entity);
end if;
end loop;
end;
elsif Expression_Kind (Element) = A_Selected_Component then
-- There is a limitation in ASIS-for-GNAT
-- related to selected components and
-- optimization of static expressions.
-- We have to handle a possible failure.
declare
Child1, Child2 : Asis.Element;
begin
begin
Child1 := Asis.Expressions.Prefix (Element);
Child2 := Asis.Expressions.Selector (Element);
exception
when others =>
Warning ("gnatelim: could not process a selected component");
Control := Abandon_Children;
end;
end;
end if;
end Analyze_Element;
end GNATELIM.Analysis;
syntax highlighted by Code2HTML, v. 0.9.1