------------------------------------------------------------------------------
--                                                                          --
--                           GNATELIM COMPONENTS                            --
--                                                                          --
--              G N A T E L I M . A S I S _ U T I L I T I E S               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1998-2004 Ada Core Technologies, Inc.           --
--                                                                          --
-- GNATELIM  is  free software;  you can  redistribute it and/or  modify it --
-- under the 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  MERCHANTABI- --
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public Li- --
-- cense 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.                                              --
--                                                                          --
-- The original version  of  Gnatelim  was developed by  Alain  Le  Guennec --
-- It is now maintained by Ada Core Technologies Inc  (http://www.gnat.com) --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;

with Asis.Compilation_Units;  use Asis.Compilation_Units;
with Asis.Declarations;       use Asis.Declarations;
with Asis.Expressions;        use Asis.Expressions;
with Asis.Exceptions;         use Asis.Exceptions;
with Asis.Elements;           use Asis.Elements;
with Asis.Text;               use Asis.Text;
with Asis.Extensions;

with Asis.Set_Get;            use Asis.Set_Get;

with Atree;                   use Atree;
with Namet;                   use Namet;
with Sinput;                  use Sinput;
with Types;                   use Types;

with Gnatelim.Strings;        use Gnatelim.Strings;

package body Gnatelim.Asis_Utilities is

   use Asis;
   use Gnatelim.Strings.Chars;

   -------------------
   -- Build_Profile --
   -------------------

   function Build_Profile
     (Subprogram_Id : Asis.Defining_Name)
      return          String_Loc
   is
      D     : Asis.Declaration := Enclosing_Element (Subprogram_Id);
      S     : String_Loc       := Empty_String;
      First : Natural;
      DK    : Asis.Declaration_Kinds := Declaration_Kind (D);

      Params_Present : Boolean := True;

      procedure Build_Subtype_Image (Subtype_Mark : Asis.Expression);
      --  Creates a textual representation of a given subtype mark and stores
      --  it in the string table

      procedure Build_Subtype_Image (Subtype_Mark : Asis.Expression) is
      begin
         case Expression_Kind (Subtype_Mark) is
            when An_Identifier =>
               S := Enter_String (Name_Image (Subtype_Mark));

            when A_Selected_Component =>
               Build_Subtype_Image (Prefix (Subtype_Mark));
               Increment_Last;
               Table (Last) := '.';
               Build_Subtype_Image (Selector (Subtype_Mark));

            when An_Attribute_Reference =>
               Build_Subtype_Image (Prefix (Subtype_Mark));
               Increment_Last;
               Table (Last) := ''';
               Build_Subtype_Image
                 (Attribute_Designator_Identifier (Subtype_Mark));

            when others =>
               pragma Assert (False);
               null;

         end case;
      end Build_Subtype_Image;

   begin

      if DK in A_Procedure_Instantiation .. A_Function_Instantiation then
         D  := Corresponding_Declaration (D);
         DK := Declaration_Kind (D);
      end if;

      if DK not in A_Procedure_Declaration .. A_Function_Declaration
        and then DK not in
         A_Procedure_Body_Declaration .. A_Function_Body_Declaration
      then
         --  ??? At the moment this routine can be called for any scope, not
         --  ??? only for a subprogram.
         --  pragma Assert (False);
         return Empty_String;
      end if;

      First := Last + 1;

      declare
         Params : constant Asis.Element_List := Parameter_Profile (D);
      begin

         if not (Params'Length = 0
              and then
                (DK = A_Function_Declaration
                       or else
                 DK = A_Function_Body_Declaration))
         then
            S := Enter_String ("Parameter_Types => (");

            for J in Params'Range loop
               Increment_Last;
               Table (Last) := '"';
               Build_Subtype_Image (Declaration_Subtype_Mark (Params (J)));
               Increment_Last;
               Table (Last) := '"';

               if J /= Params'Last then
                  S := Enter_String (", ");
               end if;
            end loop;

            if Params'Length = 0 then
               S := Enter_String ("""""");
            end if;

            S := Enter_String (")");
         else
            --  We do not generate the string for Parameter_Types only for the
            --  case of a parameterless function
            Params_Present := False;
         end if;
      end;

      if DK = A_Function_Declaration
        or else
         DK = A_Function_Body_Declaration
      then

         if Params_Present then
            S := Enter_String (", ");
         end if;

         S := Enter_String ("Result_Type => """);

         Build_Subtype_Image (Result_Profile (D));
         Increment_Last;
         Table (Last) := '"';
      end if;

      S.First := First;
      S.Last  := Last;

      return S;

   end Build_Profile;

   ----------------------
   -- Build_Sloc_Trace --
   ----------------------

   --  This function is not an ASIS Extension query, it uses low-level access
   --  to the GNAT tree and some low-level routines from the ASIS
   --  implementation and GNAT packages

   function Build_Sloc_Trace
     (Subprogram_Id : Asis.Defining_Name)
      return          String_Loc
   is
      D     : constant Asis.Declaration := Enclosing_Element (Subprogram_Id);
      S     :          String_Loc       := Empty_String;
      First : constant Natural          := Last + 1;
      DK    : constant Asis.Declaration_Kinds := Declaration_Kind (D);

      P              : Source_Ptr;
      Sindex         : Source_File_Index;
      Instance_Depth : Natural := 0;

      function Strip_Space (S : String) return String;
      --  Is applied to the result of 'Img attribute. Cuts out the leading
      --  space.

      function Strip_Space (S : String) return String is
         First_Idx : constant Positive := S'First + 1;
         Result    : constant String := S (First_Idx .. S'Last);
      begin
         return Result;
      end Strip_Space;

      procedure Enter_Sloc;
      --  For the current value of P, sets in the string table the string
      --  of the form file_name:line_number. Also computes Sindex as the
      --  Id of the sourse file of P

      procedure Enter_Sloc is
         F_Name : File_Name_Type;
      begin
         Sindex := Get_Source_File_Index (P);
         F_Name := File_Name (Sindex);

         Get_Name_String (F_Name);

         S :=
           Enter_String (To_Wide_String (Name_Buffer (1 .. Name_Len)) & ":");
         --  At some point we should det rid of this Wide_String table and to
         --  replace it with a string table.

         S :=
           Enter_String
             (To_Wide_String (Strip_Space (Get_Physical_Line_Number (P)'Img)));

      end Enter_Sloc;

   begin

      if not (DK in A_Procedure_Declaration .. A_Function_Declaration
          or else
             DK in A_Procedure_Body_Declaration .. A_Function_Body_Declaration
          or else
             DK in A_Procedure_Instantiation .. A_Function_Instantiation)
      then
         --  ??? At the moment this routine can be called for any scope, not
         --  ??? only for a subprogram.
         --  pragma Assert (False);
         return Empty_String;
      end if;

      S := Enter_String ("Source_Location => """);
      P := Sloc (R_Node (Subprogram_Id));

      Enter_Sloc;

      P := Instantiation (Sindex);

      while P /= No_Location loop
         S              := Enter_String ("[");
         Instance_Depth := Instance_Depth + 1;

         Enter_Sloc;

         P := Instantiation (Sindex);
      end loop;

      for J in 1 .. Instance_Depth loop
         S := Enter_String ("]");
      end loop;

      S       := Enter_String ("""");
      S.First := First;
      S.Last  := Last;

      return S;
   end Build_Sloc_Trace;

   ---------------------------
   -- Corresponding_Element --
   ---------------------------

   function Corresponding_Element
     (Element : Asis.Element) return Asis.Element is

   begin
      if Element_Kind (Element) = An_Expression then
         case Expression_Kind (Element) is
            when A_Selected_Component =>
               return Corresponding_Element (Selector (Element));
            when An_Explicit_Dereference
              | An_Attribute_Reference
              | A_Function_Call
              | An_Indexed_Component
              | A_Slice =>
               return Corresponding_Element (Prefix (Element));
            when An_Identifier
              | An_Operator_Symbol
              | A_Character_Literal
              | An_Enumeration_Literal =>
               return Corresponding_Element
                 (Corresponding_Name_Declaration (Element));
            when others =>
               return Nil_Element;
         end case;

      elsif Element_Kind (Element) = A_Declaration then

         if Is_Part_Of_Inherited (Element) then
            --  We might have an implicitly inherited subprogram declaration.
            --  The only thing we can do is to go back to the explicit
            --  declaration, which is anyway the right thing to do,
            --  since there is no specific body in the object file
            --  for inherited subprograms; they share the explicit body.
            --  If this is something else Corresponding_Declaration will
            --  fail which we catch
            begin
               return Corresponding_Element
                 (Asis.Declarations.Corresponding_Declaration (Element));
            exception
               when others =>
                  return Nil_Element;
            end;

         elsif Declaration_Kind (Element) in A_Renaming_Declaration then
            return Corresponding_Element
              (Corresponding_Base_Entity (Element));

         elsif Is_A_Completion (Element) then
            return Corresponding_Element (Corresponding_Declaration (Element));

         else
            return Corresponding_Element
              (Asis.Declarations.Names (Element) (1));

         end if;

      elsif Element_Kind (Element) /= A_Defining_Name then
         --  There's nothing we can do.
         return Nil_Element;

      --  From now on, we can safely assume we have A_Defining_Name.

      elsif Is_Part_Of_Inherited (Element) then
         --  We have an implicitly inherited subprogram defining_name.
         --  Let's go back to the explicit declaration.

         --  Going back to explicit is only possible on _declarations_
         --  not on defining_names. Enclosing_Element must be used.

         return Corresponding_Element
           (Asis.Declarations.Corresponding_Declaration
            (Enclosing_Element (Element)));

      else
         --  Here we have a defining name
         if Is_Part_Of_Implicit (Element) then
            --  It is implicit but not inherited - nothing we can do
            return Nil_Element;
         else
            return Element;
         end if;
      end if;

   exception
      when Asis.Exceptions.ASIS_Inappropriate_Element =>
         return Nil_Element;
   end Corresponding_Element;

   --------------------------------------------
   -- Corresponding_Generic_Element_Unwinded --
   --------------------------------------------

   function Corresponding_Generic_Element_Unwinded
     (Element : Asis.Element) return Asis.Element is
      E : Asis.Element := Element;
   begin
      if not Is_Part_Of_Instance (Element) then
         return Nil_Element;
      end if;

      while Is_Part_Of_Instance (E) loop
         E := Corresponding_Generic_Element (E);
      end loop;

      return E;

   end Corresponding_Generic_Element_Unwinded;

   ----------------------------
   -- Corresponding_Instance --
   ----------------------------

   function Corresponding_Instance
     (Element : Asis.Element)
      return    Asis.Declaration
   is
      E : Asis.Element := Element;
      subtype A_Formal_Package is Declaration_Kinds range
        A_Formal_Package_Declaration .. A_Formal_Package_Declaration_With_Box;
   begin

      if Declaration_Kind (E) in A_Generic_Instantiation
        or else Declaration_Kind (E) in A_Formal_Package
      then
         return Corresponding_Instance (Enclosing_Element (E));
      end if;

      if not Is_Part_Of_Instance (Element) then
         return Nil_Element;
      end if;

      while Declaration_Kind (E) not in A_Generic_Instantiation
        and then Declaration_Kind (E) not in A_Formal_Package
      loop
         E := Enclosing_Element (E);
      end loop;

      if Declaration_Kind (E) not in  A_Formal_Package then
         return E;
      else
         --  The formal package declaration has Is_Part_Of_Instance as True,
         --  but we don't consider this a real instantiation. So we just step
         --  over it
         return Corresponding_Instance (Enclosing_Element (E));
      end if;

   end Corresponding_Instance;

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

   ----------
   -- SLOC --
   ----------

   function SLOC (E : Asis.Element) return Source_Loc is
      S : Span;
   begin
      if Is_Part_Of_Instance (E) then
         S := Element_Span (Corresponding_Generic_Element_Unwinded (E));
      else
         S := Element_Span (E);
      end if;

      if S = Nil_Span then
         return Empty_SLOC;
      else
         return Source_Loc'(S.First_Line, S.First_Column);
      end if;
   end SLOC;

   ------------------------
   -- Text_Name_Unwinded --
   ------------------------

   function Text_Name_Unwinded (E : Asis.Element) return Wide_String is
      Tmp : Asis.Element;
   begin
      if Is_Part_Of_Instance (E) then
         Tmp := Corresponding_Generic_Element_Unwinded (E);
      else
         Tmp := E;
      end if;

      return Text_Name (Enclosing_Compilation_Unit (Tmp));
   end Text_Name_Unwinded;

end Gnatelim.Asis_Utilities;
