------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . E N C L _ E L                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-2005, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT 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. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, 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 ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--
--
--
--
--
--
--
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT  is  now  maintained  by  AdaCore               --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Asis;            use Asis;
with Asis.Elements;   use Asis.Elements;

with Asis.Set_Get;    use Asis.Set_Get;

with A4G.A_Types;     use A4G.A_Types;
with A4G.Encl_El_Old; use A4G.Encl_El_Old;
with A4G.Int_Knds;    use A4G.Int_Knds;
with A4G.Mapping;     use A4G.Mapping;

with Atree;           use Atree;
with Nlists;          use Nlists;
with Sinfo;           use Sinfo;
with Sinput;          use Sinput;
with Stand;           use Stand;
with Types;           use Types;

package body A4G.Encl_El is

   ------------------------------------------------
   -- The general approach to the implementation --
   -- of the Enclosing_Element query             --
   ------------------------------------------------

   --  There are special cases and regular cases in obtaining an enclosing
   --  element. The case is considered as regular when obtaining the
   --  enclosing element consists in going one step up the ASIS "tree".
   --  The special cases includes enclosing element for implicit
   --  declarations subprogram declarations (but not for their components!),
   --  when enclosing element is an explicit type declaration being the
   --  cause for appearing this implicit declaration in the program text;
   --  or expanded generic declarations, when enclosing element is the
   --  corresponding generic instantiation etc.
   --
   --  Special cases are processed by special functions, and the
   --  Get_Enclosing function covers all the regular cases.
   --
   --  Get_Enclosing is implemented on top of the switch which
   --
   --  The following situations are distinguished in the implementation
   --  of Get_Enclosing:
   --
   --  1. One step up the ASIS tree corresponds to one step up the GNAT
   --     tree, and auto kind determination is possible for the
   --     enclosing element

   ---------------------------------
   -- Corresponding_Instantiation --
   ---------------------------------

   function Corresponding_Instantiation
     (Element : Asis.Element)
      return Asis.Element
   is
      Argument_Node : Node_Id                         := R_Node (Element);
      Argument_Kind : constant Internal_Element_Kinds := Int_Kind (Element);
      Result_Node   : Node_Id                         := Argument_Node;
      Result_Kind   : Internal_Element_Kinds;
      Result_Unit   : constant Asis.Compilation_Unit  := Encl_Unit (Element);
   begin

      if Argument_Kind = A_Package_Declaration or else
         Argument_Kind = A_Package_Body_Declaration
      then

         --  A formal package with box needs a special processing - it is
         --  based on the same node as the argument

         if Nkind (Original_Node (Argument_Node)) =
            N_Formal_Package_Declaration
         then
            Result_Kind := A_Formal_Package_Declaration_With_Box;
         else
            Argument_Node := Parent (Argument_Node);

            if Nkind (Argument_Node) in N_Generic_Declaration and then
               Is_List_Member (Result_Node)                   and then
               List_Containing (Result_Node) =
                  Generic_Formal_Declarations (Argument_Node)
            then
               Result_Kind := A_Formal_Package_Declaration;
            else
               Result_Kind := A_Package_Instantiation;
            end if;

         end if;

      else

         if Argument_Kind = A_Procedure_Declaration or else
            Argument_Kind = A_Procedure_Body_Declaration
         then
            Result_Kind := A_Procedure_Instantiation;
         else
            Result_Kind := A_Function_Instantiation;
         end if;

         --  we have to go the N_Package_Decalaration node of an
         --  artificial package created by the compiler for a subprogram
         --  instantiation - two steps up the tree are needed:
         Result_Node := Parent (Result_Node);

         if Argument_Kind = A_Procedure_Declaration or else
            Argument_Kind = A_Function_Declaration
         then
            Result_Node := Parent (Result_Node);
         end if;

      end if;

      if Nkind (Parent (Result_Node)) = N_Compilation_Unit then

         --  For library-level subprogram instntiations we may have a
         --  problem in the tree created for the instantiation itself.

         if Nkind (Result_Node) = N_Package_Declaration and then
            not Is_Rewrite_Substitution (Result_Node)
         then
            Result_Node := Parent (Corresponding_Body (Result_Node));

            if Nkind (Result_Node) = N_Defining_Program_Unit_Name then
               Result_Node := Parent (Result_Node);
            end if;

         end if;

      elsif Nkind (Original_Node (Result_Node)) /=
            N_Formal_Package_Declaration
      then
         --  "local" instantiation, therefore - one or two steps down the
         --  declaration list to get in the instantiation node, a formal
         --  package with a box is an exception:

         Result_Node := Next_Non_Pragma (Result_Node);

         if Nkind (Result_Node) = N_Package_Body then
            --  This is an expanded generic body
            Result_Node := Next_Non_Pragma (Result_Node);
         end if;

      end if;

      if Is_Rewrite_Substitution (Result_Node) and then
         Is_Rewrite_Substitution (Original_Node (Result_Node))
      then
         Result_Node := Original_Node (Result_Node);
      end if;

      return Node_To_Element_New
               (Node          => Result_Node,
                Internal_Kind => Result_Kind,
                In_Unit       => Result_Unit);
   end Corresponding_Instantiation;

   -----------------------------------------------
   -- Enclosing_For_Explicit_Instance_Component --
   -----------------------------------------------

   function Enclosing_For_Explicit_Instance_Component
     (Element : Asis.Element)
      return Asis.Element
   is
      Result_Element   : Asis.Element;
      Result_Node      : Node_Id;
      Res_Spec_Case    : Special_Cases;

      function Is_Top_Exp_Form_Pack_With_Box
        (Potential_Enclosing_Element : Asis.Element;
         Arg_Element                 : Asis.Element)
         return                        Boolean;
      --  Checks if Potential_Enclosing_Element is the top expanded spec
      --  (??? what about body???) for a formal package declaration with box.
      --  The problem here is that when going up the tree, we can get into this
      --  argument both from components of the formal package declaration with
      --  box and from the corresponding expanded spec. So we have to check
      --  if Potential_Enclosing_Element and Arg_Element are the same level
      --  of instantiating (nested instances may be a pain! The function needs
      --  more testing ???)
      --  See the discussion in E425-007

      function Is_Top_Exp_Form_Pack_With_Box
        (Potential_Enclosing_Element : Asis.Element;
         Arg_Element                 : Asis.Element)
         return                        Boolean
      is
         EE_Inst_Level  : Natural := 0;
         Arg_Inst_Level : Natural := 0;

         Src : Source_Ptr :=
           Instantiation
             (Get_Source_File_Index
                (Sloc (R_Node (Potential_Enclosing_Element))));

         function May_Be_Exp_Pack_Def_Name
           (N_Pack : Node_Id;
            N_Name : Node_Id)
         return Boolean;
         --  In case of the defining name of an expanded package created for a
         --  formal package with the box, we have the instantiation chain one
         --  link shorter then the rest of the expanded package, so we have
         --  to detect this situation.

         function May_Be_Nested_FP_Instantiation
           (N_Pack : Node_Id;
            N_Name : Node_Id)
         return Boolean;
         --  See E430-A01. We try to detect the situation when we go out of
         --  a chain of nested instantiations created by formal packages with
         --  the box

         function May_Be_Exp_Pack_Def_Name
           (N_Pack : Node_Id;
            N_Name : Node_Id)
         return Boolean
         is
            Result : Boolean := False;
         begin

            if Nkind (N_Name) = N_Defining_Identifier
              and then
               Nkind (Original_Node (N_Pack)) = N_Formal_Package_Declaration
              and then
               Box_Present (Original_Node (N_Pack))
            then
               Result := N_Name = Defining_Unit_Name (Specification (N_Pack));
            end if;

            return Result;
         end May_Be_Exp_Pack_Def_Name;

         function May_Be_Nested_FP_Instantiation
           (N_Pack : Node_Id;
            N_Name : Node_Id)
         return Boolean
         is
            Result : Boolean := False;
         begin
            if Nkind (N_Pack) = N_Generic_Package_Declaration
              and then
               Nkind (Original_Node (N_Pack)) = N_Formal_Package_Declaration
              and then
               Box_Present (Original_Node (N_Pack))
              and then
               Nkind (N_Name) = N_Generic_Package_Declaration
              and then
               Nkind (Original_Node (N_Name)) = N_Formal_Package_Declaration
              and then
               Box_Present (Original_Node (N_Name))
            then
               Result := True;
            end if;

            return Result;
         end May_Be_Nested_FP_Instantiation;

      begin

         if not (Nkind (Node (Potential_Enclosing_Element)) =
                 N_Formal_Package_Declaration
               and then
                 Nkind (R_Node (Potential_Enclosing_Element)) =
                 N_Generic_Package_Declaration)
           or else
            (Int_Kind (Potential_Enclosing_Element) =
             A_Formal_Package_Declaration_With_Box
            and then
             Node (Arg_Element) =
             Defining_Identifier (Node (Potential_Enclosing_Element)))
         then
            return False;
         end if;

         while Src /= No_Location loop
            EE_Inst_Level := EE_Inst_Level + 1;
            Src           := Instantiation (Get_Source_File_Index (Src));
         end loop;

         Src :=
           Instantiation (Get_Source_File_Index (Sloc (R_Node (Arg_Element))));

         while Src /= No_Location loop
            Arg_Inst_Level := Arg_Inst_Level + 1;
            Src           := Instantiation (Get_Source_File_Index (Src));
         end loop;

         return (May_Be_Exp_Pack_Def_Name
                 (R_Node (Potential_Enclosing_Element),
                  R_Node (Arg_Element))
               and then
                 EE_Inst_Level = Arg_Inst_Level + 1)
              or else
                 (May_Be_Nested_FP_Instantiation
                 (R_Node (Potential_Enclosing_Element),
                  R_Node (Arg_Element))
               and then
                  EE_Inst_Level + 1 = Arg_Inst_Level)
              or else
                EE_Inst_Level = Arg_Inst_Level;

      end Is_Top_Exp_Form_Pack_With_Box;

   begin
      Result_Element := Enclosing_Element_For_Explicit (Element);
      --  and now we have to check if we are in the whole expanded
      --  declaration
      Result_Node := R_Node (Result_Element);

      if Is_Top_Of_Expanded_Generic (Result_Node) then
         --  this is an artificial package or subprogram declaration
         --  created by the compiler as an expanded generic declaration

         if Nkind (Result_Node) = N_Package_Declaration or else
            Nkind (Result_Node) = N_Package_Body
         then
            Res_Spec_Case := Expanded_Package_Instantiation;
            --  and here we have to correct the result:
            Set_Node (Result_Element, R_Node (Result_Element));

            if Nkind (Result_Node) = N_Package_Declaration then
               Set_Int_Kind (Result_Element, A_Package_Declaration);
            else
               Set_Int_Kind (Result_Element, A_Package_Body_Declaration);
            end if;

         else
            Res_Spec_Case := Expanded_Subprogram_Instantiation;
         end if;

         Set_Special_Case (Result_Element, Res_Spec_Case);

      elsif Is_Top_Exp_Form_Pack_With_Box (Result_Element, Element) then
         --  This case is somewhat special - we have not a package, but a
         --  generic package declaration as expanded code here
         Set_Int_Kind     (Result_Element, A_Package_Declaration);
         Set_Special_Case (Result_Element, Expanded_Package_Instantiation);
         --  ??? What about expanded bodies for formal packages with a box?
      end if;

      --  and we have to correct Is_Part_Of_Instance field of the result -
      --  just in case. May be, it will not be necessary, if (and when)
      --  Enclosing_Element_For_Explicit takes the corresponding fields
      --  from its argument

      if not Is_Nil (Result_Element) then
         Set_From_Instance (Result_Element, True);
      end if;

      return Result_Element;

   end Enclosing_For_Explicit_Instance_Component;

   ------------------------------------
   -- Enclosing_Element_For_Explicit --
   ------------------------------------

   function Enclosing_Element_For_Explicit
     (Element : Asis.Element)
      return Asis.Element
      renames A4G.Encl_El_Old.Enclosing_Element_For_Explicits_Old;

   ------------------------------------
   -- Enclosing_Element_For_Implicit --
   ------------------------------------

   function Enclosing_Element_For_Implicit
     (Element : Asis.Element)
      return Asis.Element
   is
      Arg_Kind        : constant Internal_Element_Kinds := Int_Kind (Element);
      Result_Node     : Node_Id                         := Empty;
      Result_Element  : Asis.Element;
      Result_Kind     : Internal_Element_Kinds          := Not_An_Element;
      Res_Spec_Case   : Special_Cases                   := Not_A_Special_Case;

   begin

      case Arg_Kind is

         when A_Procedure_Declaration      |
              A_Function_Declaration       |
              A_Discriminant_Specification |
              A_Component_Declaration      =>

            Result_Node := Original_Node (Node_Field_1 (Element));

            if Nkind (Result_Node) in N_Entity
              and then
               Arg_Kind in A_Procedure_Declaration ..
                           A_Function_Declaration
            then
               Result_Node := Original_Node (Parent (Node_Field_1 (Element)));
            end if;

            case Nkind (Result_Node) is

               when N_Private_Extension_Declaration =>
                  Result_Kind := A_Private_Extension_Definition;

               when N_Formal_Type_Declaration =>
                  Result_Node := Sinfo.Formal_Type_Definition (Result_Node);

               when others =>
                  Result_Node := Sinfo.Type_Definition (Result_Node);
            end case;

            Result_Element := Node_To_Element_New (
               Node             => Result_Node,
               Starting_Element => Element,
               Internal_Kind    => Result_Kind);

            Set_From_Implicit  (Result_Element, False);
            Set_From_Inherited (Result_Element, False);
            Set_Node_Field_1   (Result_Element, Empty);

         when Internal_Root_Type_Kinds =>
            Result_Element := Element;
            Set_Int_Kind (Result_Element, An_Ordinary_Type_Declaration);

         when An_Ordinary_Type_Declaration =>
            --  The only possible case is the declaration of a root or
            --  universal numeric type
            Result_Node   := Standard_Package_Node;
            Res_Spec_Case := Explicit_From_Standard;
            Result_Kind   := A_Package_Declaration;

            Result_Element :=
               Node_To_Element_New (Node      => Result_Node,
                                    Spec_Case => Res_Spec_Case,
                                    In_Unit   => Encl_Unit (Element));

         when An_Enumeration_Literal_Specification |
              An_Entry_Declaration                 =>

            Result_Node   :=
               Sinfo.Type_Definition (Original_Node (Node_Field_1 (Element)));
            Result_Kind   := A_Derived_Type_Definition;

            Result_Element := Node_To_Element_New (
               Node             => Result_Node,
               Starting_Element => Element,
               Internal_Kind    => Result_Kind);

            Set_From_Implicit  (Result_Element, False);
            Set_From_Inherited (Result_Element, False);
            Set_Node_Field_1   (Result_Element, Empty);

         when others =>
            Result_Element := Enclosing_Element_For_Explicit (Element);

      end case;

      if Int_Kind (Result_Element) = A_Function_Renaming_Declaration then
         --  See C125-002
         Set_Int_Kind (Result_Element, A_Function_Declaration);
      elsif Int_Kind (Result_Element) = A_Procedure_Renaming_Declaration then
         Set_Int_Kind (Result_Element, A_Procedure_Declaration);
      end if;

      return Result_Element;

   end Enclosing_Element_For_Implicit;

   --------------------------------
   -- Is_Top_Of_Expanded_Generic --
   --------------------------------

   function Is_Top_Of_Expanded_Generic (N : Node_Id) return Boolean is
      N_Kind : constant Node_Kind := Nkind (N);
      Result : Boolean            := False;
   begin

      Result :=

         ((not Comes_From_Source (N) or else
           Is_Rewrite_Insertion (N))
         and then
          (N_Kind = N_Package_Declaration    or else
           N_Kind = N_Package_Body           or else
           N_Kind = N_Subprogram_Declaration or else
           N_Kind = N_Subprogram_Body)
         and then
           Nkind (Original_Node (N)) not in  N_Renaming_Declaration)

       or else

         (Nkind (Parent (N)) = N_Package_Body and then
          not Comes_From_Source (Parent (N)))

        or else

         (Is_Rewrite_Substitution (N) and then
          Nkind (Original_Node (N)) = N_Package_Instantiation);
      --  Library-level package instantiation

      return Result;

   end Is_Top_Of_Expanded_Generic;

end A4G.Encl_El;
