----------------------------------------------------------------------
--  Analyzer package body                                           --
--  Copyright (C) 2002 Adalog                                       --
--  Author: J-P. Rosen                                              --
--                                                                  --
--  ADALOG   is   providing   training,   consultancy,   expertise, --
--  assistance and custom developments  in Ada and related software --
--  engineering techniques.  For more info about our services:      --
--  ADALOG                   Tel: +33 1 41 24 31 40                 --
--  19-21 rue du 8 mai 1945  Fax: +33 1 41 24 07 36                 --
--  94110 ARCUEIL            E-m: info@adalog.fr                    --
--  FRANCE                   URL: http://www.adalog.fr              --
--                                                                  --
--  This  unit 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.  This  unit is distributed --
--  in the hope  that it will be useful,  but WITHOUT 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 this program; see file --
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.           --
--                                                                  --
--  As  a special  exception, if  other files  instantiate generics --
--  from  this unit,  or you  link this  unit with  other  files to --
--  produce an executable,  this unit does not by  itself cause the --
--  resulting executable  to be covered  by the GNU  General Public --
--  License.  This exception does  not however invalidate any other --
--  reasons why  the executable  file might be  covered by  the GNU --
--  Public License.                                                 --
----------------------------------------------------------------------

with   -- Standard Ada units
  Ada.Unchecked_Deallocation,
  Ada.Strings.Wide_Fixed,
  Ada.Wide_Text_IO,
  Ada.Characters.Handling;

with   -- ASIS components
  Asis.Compilation_Units,
  Asis.Elements,
  Asis.Exceptions,
  Asis.Expressions,
  Asis.Iterator;
pragma Elaborate_All (Asis.Iterator);

with   -- Application specific units
  Utilities,
  Thick_Queries,
  Analyzer.Table_manager;
pragma Elaborate (Analyzer.Table_Manager);
package body Analyzer is
   use Asis, Asis.Exceptions;
   use Compilation_Units, Elements;
   use Utilities;

   ----------------------------------------------------------------
   --                 Internal elements                          --
   ----------------------------------------------------------------

   ------------------
   -- Global types --
   ------------------

   type WS_Access is access Wide_String;

   ----------------------
   -- Global variables --
   ----------------------

   Name_List : Table_Manager.Table;

   Prev_Package : WS_Access;

   ----------------------
   -- Add_Kept_Element --
   ----------------------

   type Node;
   type Link is access Node;
   type Node is
      record
         Element : WS_Access;
         Next    : Link;
      end record;

   Elements_Head : Link;

   procedure Add_Kept_Element (Name : in Wide_String) is
      -- Note: To_Upper ensures that the lower bound of the created string is 1.
   begin
      Elements_Head := new Node'(Element => new Wide_String'(To_Upper (Name)),
                                 Next    => Elements_Head);
   end Add_Kept_Element;

   --------------
   -- Register --
   --------------

   procedure Register (Element : in Defining_Name) is
      -- Pre-condition: not Is_Null (Element)
      use Table_Manager, Thick_Queries;
      Name_String : constant Wide_String := To_Upper (Full_Name_Image (Element));
      -- Note: To_Upper ensures that the lower bound of Name_String is 1.
      Ptr : Link := Elements_Head;
      OK_To_Add : Boolean := False;

      function Format (S : Wide_String) return Wide_String is
         use Ada.Characters.Handling;
         Result : Wide_String := S;
         Change_Case : Boolean := False;
      begin
         for I in Result'Range loop
            if Change_Case and Is_Character (Result (I)) then
               -- To_Lower does not exist for Wide_Character
               Result (I) := To_Wide_Character (To_Lower (To_Character (Result (I))));
            end if;
            Change_Case := Result (I) /= '_';
         end loop;
         return Result;
      end Format;
   begin
      if Ptr = null then
         OK_To_Add := True;
      else
         while Ptr /= null loop
            if Ptr.Element.all = Name_String or else
              (Name_String'Length > Ptr.Element'Length and then
               Name_String (1..Ptr.Element'Length) = Ptr.Element.all and then
               Name_String (Ptr.Element'Length + 1) = '.')
            then
               OK_To_Add := True;
               exit;
            end if;
            Ptr := Ptr.Next;
         end loop;
      end if;

      if OK_To_Add then
         declare
            Decl : Asis.Element := Enclosing_Element (Element);
         begin
            case Element_Kind (Decl) is
               when A_Declaration =>
                  Add (Name_String,
                       To => Name_List,
                       Comment => Format (Declaration_Kinds'Wide_Image (Declaration_Kind (Decl))));
               when A_Statement =>
                  -- For completeness, but this should not happen in this program since it happens
                  -- only for statements names and labels or for-loop variables, which are always local
                  Add (Name_String, To => Name_List);
               when others =>
                  -- Impossible
                  raise Program_Error;
            end case;
            Trace ("Adding " & Name_String & " - " & Element_Kinds'Wide_Image (Element_Kind (Decl)));
         end;
      end if;
   end Register;

   ----------
   -- Free --
   ----------

   procedure Free is new Ada.Unchecked_Deallocation (Wide_String, WS_Access);

   --------------
   -- Traverse --
   --------------

   procedure Pre_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Asis.Compilation_Unit);
   procedure Post_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Asis.Compilation_Unit);
   procedure Traverse is new Asis.Iterator.Traverse_Element
     (Asis.Compilation_Unit, Pre_Procedure, Post_Procedure);

   --------------------
   -- Post_Procedure --
   --------------------

   procedure Post_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Asis.Compilation_Unit) is

   begin
      null;
   end Post_Procedure;

   -------------------
   -- Pre_Procedure --
   -------------------

   procedure Pre_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Asis.Compilation_Unit) is
      use Asis.Expressions;

      use Thick_Queries;
   begin
      Control := Continue;

      case Element_Kind (Element) is
         when An_Expression =>                 ------------ Expression ------------
            case Expression_Kind (Element) is
               when An_Attribute_Reference =>
                  -- Traverse manually the left branch only, in order to avoid processing
                  -- the attribute identifier
                  Traverse (Prefix (Element), Control, State);
                  if Control /= Terminate_Immediately then
                     Control := Abandon_Children;
                  end if;

               when A_Selected_Component =>
                  -- We are only interested in the actual element, not in prefix identifiers
                  -- unless we are dealing with an element inside a structure
                  case Expression_Type_Kind (Prefix (Element)) is
                     when A_Record_Type_Definition |
                       A_Tagged_Record_Type_Definition |
                       An_Access_Type_Definition
                       =>
                        Traverse (Prefix (Element), Control, State);
                     when others =>
                        Traverse (Selector (Element), Control, State);
                  end case;
                  if Control /= Terminate_Immediately then
                     Control := Abandon_Children;
                  end if;

               when An_Identifier | An_Enumeration_Literal =>
                  declare
                     The_Name : Asis.Element;
                     The_Unit : Asis.Compilation_Unit;
                  begin
                     The_Name := Corresponding_Name_Definition (Element);
                     -- ASIS doc says:
                     -- Corresponding_Name_Definition returns a Nil_Element if the reference
                     -- is to an implicitly declared element for which the implementation does
                     -- not provide declarations and defining name elements.
                     if not Is_Nil (The_Name) then
                        -- State is already the Corresponding_Declaration, unless there is none
                        -- (in which case State is the unit itself). We do the same for the
                        -- Enclosing_Unit of The_Name.
                        -- We eliminate The_Name if the declaration of its enclosing unit is the
                        -- same as the declaration of the unit being processed => this allows
                        -- eliminating references from a body to elements declared in the
                        -- corresponding specification (as well as references within the unit being
                        -- processed, of course).
                        The_Unit := Corresponding_Declaration (Enclosing_Compilation_Unit (The_Name));
                        if Is_Nil (The_Unit) then
                           The_Unit := Enclosing_Compilation_Unit (The_Name);
                        end if;
                        if not Is_Equal (The_Unit, State) then
                           Register (The_Name);
                        end if;
                     end if;
                  exception
                     when ASIS_Inappropriate_Element =>
                        -- A name of a pragma association for example
                        -- We REALLY don't care
                        null;
                  end;

               when others =>
                  null;
            end case;

         when An_Association =>                 ------------ Association ------------
            -- We are only interested in the actual
            case Association_Kind (Element) is
               when Not_An_Association =>
                  -- Impossible
                  raise Program_Error;

               when A_Pragma_Argument_Association |
                    A_Parameter_Association |
                    A_Generic_Association =>
                  Traverse (Actual_Parameter (Element), Control, State);

               when A_Discriminant_Association =>
                  Traverse (Discriminant_Expression (Element), Control, State);

               when A_Record_Component_Association |
                    An_Array_Component_Association =>
                  Traverse (Component_Expression (Element), Control, State);
            end case;
            if Control /= Terminate_Immediately then
               Control := Abandon_Children;
            end if;

         when others =>
            null;
      end case;

   exception
      when others =>
         Trace ("Exception in Pre-proc, kind of failing element: " &
                Element_Kinds'Wide_Image (Element_Kind (Element)));
         raise;
   end Pre_Procedure;

   ----------------------------------------------------------------
   --                 Exported subprograms                       --
   ----------------------------------------------------------------

   -------------
   -- Process --
   -------------

   procedure Process (Unit_Name  : in     Wide_String;
                      Which_Part : in     Parts;
                      My_Context : in out Asis.Context)
   is

      procedure Do_Process (My_Unit : Compilation_Unit) is
         My_Declaration : Declaration;
         The_Control    : Traverse_Control := Continue;
         The_Info       : Asis.Compilation_Unit;

         use Table_Manager;
      begin
         if Is_Nil (My_Unit) then
            Trace (Wide_String'("NIL unit"));
            return;
         end if;

         -- Nothing interesting in context clauses
         -- Process unit only:
         My_Declaration := Unit_Declaration (My_Unit);

         The_Info := Corresponding_Declaration (My_Unit);
         if Is_Nil (The_Info) then
            The_Info := My_Unit;
         end if;
         Traverse (My_Declaration, The_Control, The_Info);

      end Do_Process;

   begin  -- Process
      Trace ("Analyzing " & Unit_Name);

      case Which_Part is
         when Specification_Part =>
            Trace ("Spec");
            Do_Process (Library_Unit_Declaration (Unit_Name, My_Context));
         when Body_Part =>
            Trace ("Body");
            Do_Process (Compilation_Unit_Body (Unit_Name, My_Context));
      end case;

   end Process;

   --------------------
   -- Produce_result --
   --------------------

   procedure Produce_Result (Unit_Name   : Wide_String := "";
                             Which_Part  : Parts       := Specification_Part;
                             Output_File : String) is
      use Ada.Wide_Text_IO, Table_Manager;

      F_Out : File_Type;

      procedure Print_Name (Name : Wide_String; Comment : Wide_String; Count : Positive) is
         use Ada.Strings, Ada.Strings.Wide_Fixed, Ada.Wide_Text_IO;

         Pos : constant Natural := Index (Name, ".", Going => Backward);
         Pack_Name : constant Wide_String := Name (Name'First .. Pos-1);
         Elem_Name : constant Wide_String := Name (Pos+1 .. Name'Last);
      begin
         if Pack_Name = "" then
            Free (Prev_Package);
            Put ("=> ");
         else
            if Prev_Package = null or else Pack_Name /= Prev_Package.all then
               Free (Prev_Package);
               Put_Line ("=> from " & Pack_Name);
               Prev_Package := new Wide_String'(Pack_Name);
            end if;
            Put ("   ");
         end if;
         Put (Elem_Name);
         Put (" - ");
         if Comment /= "" then
            Put (Comment);
            Put (' ');
         end if;
         Put ('*');
         Put (Integer'Wide_Image (Count));
         New_Line;
      end Print_Name;

      procedure Print_Use_List is new Table_Manager.Iterate (Print_Name);

   begin
      Trace ("Producing " & Unit_Name & ' ' & Parts'Wide_Image (Which_Part));

      if Is_Empty (Name_List) then
         -- nothing to produce
         Trace (Wide_String'("empty list"));
         return;
      end if;

      if Output_File /= "" then
         Safe_Open (F_Out, Name => Output_File, Mode => Append);
         Set_Output (F_Out);
      end if;

      if Unit_Name /= "" then
         Put (Unit_Name);
         case Which_Part is
            when Specification_Part =>
               null;
            when Body_Part =>
               Put (" (body)");
         end case;
         Put_Line (" =>");
      end if;

      Free (Prev_Package);   -- OK if null
      Print_Use_List (Name_List);
      Reset (Name_List);

      if Is_Open (F_Out) then
         Set_Output (Standard_Output);
         Close (F_Out);
      end if;

   exception
      when others =>
         if Is_Open (F_Out) then
            Set_Output (Standard_Output);
            Close (F_Out);
         end if;
         raise;
   end Produce_Result;

end Analyzer;

