------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . E N C L _ E L                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.34 $
--                                                                          --
--            Copyright (c) 1995-2001, 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.                                --
--                                                                          --
-- 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.                                      --
--                                                                          --
-- 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  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------
with System.Assertions;

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

with Asis.Set_Get;    use Asis.Set_Get;
with A4G.A_Types;     use A4G.A_Types;
with A4G.Int_Knds;    use A4G.Int_Knds;
with A4G.Mapping;     use A4G.Mapping;
with A4G.Vcheck;      use A4G.Vcheck;
with A4G.Encl_El_Old; use A4G.Encl_El_Old;

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

package body A4G.Encl_El is

   Package_Name : constant String := "A4G.Encl_El.";

   ------------------------------------------------
   -- 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 := Node (Element);
      Argument_Kind  : Internal_Element_Kinds := Int_Kind (Element);
      Result_Node    : Node_Id := Argument_Node;
      Result_Kind    : Internal_Element_Kinds;
      Result_Unit    : Asis.Compilation_Unit := Encl_Unit (Element);
   begin

      if Argument_Kind = A_Package_Declaration or else
         Argument_Kind = A_Package_Body_Declaration
      then
         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;

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

      else
         --  "local" instantiation, therefore - one or two steps down the
         --  declaration list to get in the instantiation node:
         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);
   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Element,
            Outer_Call => Package_Name & "Corresponding_Instantiation");
         raise;
      when others      =>
         Raise_ASIS_Failed (
            Argument  => Element,
            Diagnosis => Package_Name & "Corresponding_Instantiation");
   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;
      Result_Node_Kind : Node_Kind;
      Res_Spec_Case    : Special_Cases;
   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);
      Result_Node_Kind := Nkind  (Result_Node);

      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);
      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        : 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) = N_Defining_Identifier 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;

      return Result_Element;

   exception

      when System.Assertions.Assert_Failure | ASIS_Failed =>
         raise;

      when others =>
         Raise_ASIS_Failed (
            Argument  => Element,
            Diagnosis => Package_Name & "Enclosing_Element_For_Implicit");
   end Enclosing_Element_For_Implicit;

--   function Enclosing_Element_For_Implicit
--     (Element : Asis.Element)
--      return Asis.Element
--   is
--      --  Argument-related objects:
--      Arg_Kind      : Internal_Element_Kinds := Int_Kind (Element);
--      Arg_Node      : Node_Id                := Node (Element);
--      Arg_Ekind     : Entity_Kind;

--      --  Result-related objects:
--      Result_Node    : Node_Id;
--      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 Internal_Defining_Name_Kinds =>

--            case Internal_Defining_Name_Kinds (Arg_Kind) is

--               when A_Defining_Identifier =>
--                  Arg_Ekind := Ekind (Arg_Node);

--                  if Arg_Ekind = E_Procedure then
--                     Result_Kind := A_Procedure_Declaration;

--                  elsif Arg_Ekind = E_Function then
--                     Result_Kind := A_Function_Declaration;

--                  elsif Arg_Ekind = E_Component then
--                     Result_Kind := A_Component_Declaration;

--                  elsif Arg_Ekind = E_Discriminant then
--                     Result_Kind := A_Discriminant_Specification;

--                  else
--                     Not_Implemented_Yet (Diagnosis =>
--                    "Asis.Elements.Enclosing_Element: not implemented yet "
--                      & "for an implicit defining identifier representing "
--                      & Entity_Kind'Image (Arg_Ekind));
--                  end if;

--               when Internal_Defining_Operator_Kinds =>
--                  Result_Kind := A_Function_Declaration;
--               when A_Defining_Character_Literal  |
--                    A_Defining_Enumeration_Literal =>
--                  --  ???  just the same as for explicit elements.
--                  --  ???  some aggregation needed???
--                  Result_Kind := An_Enumeration_Literal_Specification;
--               when A_Defining_Expanded_Name =>
--                  --  impossible, therefore:
--                  pragma Assert (False);
--                  null;
--            end case;

--            case Result_Kind is

--               when A_Procedure_Declaration |
--                    A_Function_Declaration  |
--                    An_Enumeration_Literal_Specification =>

--                  --  the result will be based on the same node,
--               --  and the same node should be kept for Node_Field_1 as the
--                  --  associated type:
--                  Result_Element := Element;
--                  Set_Int_Kind (Result_Element, Result_Kind);

--             when A_Component_Declaration | A_Discriminant_Specification =>
--               --  this is the case of a component declaration of a derived
--                  --  type. ASIS does not clearly say, what is Enclosing
--                  --  Element in this case. What we are returning now is an
--              --  explicit component declaration/discriminant specification
--                  --  of the parent type (see also Asis.Expressions, 17.6)
--                  Result_Node := Parent (Arg_Node);

--                  Result_Element := Node_To_Element_New (
--                     Node             => Result_Node,
--                     Starting_Element => Element,
--                     Internal_Kind    => Result_Kind,
--                     Inherited        => True);  --  ???

--                  Set_Node_Field_1 (Result_Element, Node_Field_1 (Element));

--               when others =>
--                  null;
--                  --  just in case:
--                  pragma Assert (False);

--            end case;

--         when A_Component_Declaration      |
--              A_Discriminant_Specification |
--              An_Enumeration_Literal_Specification =>

--            Result_Node := Node_Field_1 (Element);

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

--            Set_From_Implicit (Result_Element, False);
--            Set_From_Inherited (Result_Element, False);

--         when A_Procedure_Declaration | A_Function_Declaration =>

--            Result_Node := Parent (Node_Field_1 (Element));

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

--            Set_From_Implicit (Result_Element, False);
--            Set_From_Inherited (Result_Element, False);

--         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 others =>
--            Not_Implemented_Yet (Diagnosis =>
--               "Asis.Elements.Enclosing_Element: not implemented yet for "
--             & "Implicit Constructs of "
--             & Internal_Element_Kinds'Image (Arg_Kind)
--             & " kind");
--      end case;

--      return Result_Element;

--   exception

--      when System.Assertions.Assert_Failure | ASIS_Failed =>
--         raise;

--      when others =>
--         Raise_ASIS_Failed (
--            Argument  => Element,
--            Diagnosis => Package_Name & "Enclosing_Element_For_Implicit");
--   end Enclosing_Element_For_Implicit;

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

   function Is_Top_Of_Expanded_Generic (N : Node_Id) return Boolean is
      N_Kind : 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))

       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;
