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