------------------------------------------------------------------------------ -- -- -- 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;