------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . N E N C L _ E L                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.17 $
--                                                                          --
--            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 Ada.Exceptions;

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

with Asis.Set_Get;    use Asis.Set_Get;
with A4G.Int_Knds;    use A4G.Int_Knds;
with A4G.Queries;     use A4G.Queries;
with A4G.A_Types;     use A4G.A_Types;
with A4G.Mapping;     use A4G.Mapping;
with A4G.Vcheck;      use A4G.Vcheck;
with A4G.Encl_El;     use A4G.Encl_El;

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

package body A4G.Nencl_El is

   LT : String renames ASIS_Line_Terminator;
   Package_Name : String := "A4G.Nencl_El.";

   -----------------------------
   -- An_Expression_Enclosing --
   -----------------------------

   function An_Expression_Enclosing
     (Element : Asis.Element)
      return Asis.Element
   is
      Start_Elem           : Asis.Element := Element;
      Rough_Result_Node    : Node_Id;
      Rough_Result_Element : Asis.Element;
      Rough_Res_Spec_Case  : Special_Cases;
      Result_Element       : Asis.Element;
   begin
      Rough_Result_Node    := Get_Rough_Enclosing_Node (Element);

      if not (Sloc (Node (Start_Elem)) <= Standard_Location) then
         Set_Special_Case (Start_Elem, Not_A_Special_Case);
      end if;

      Rough_Result_Element := Node_To_Element_New
                                (Node             => Rough_Result_Node,
                                 Starting_Element => Start_Elem);

      if Is_Top_Of_Expanded_Generic (Rough_Result_Node) and then
         Is_From_Instance (Element)
      then
         --  ??? The content of this if statement is just a slightly edited
         --  ??? fragment of Enclosing_For_Explicit_Instance_Component

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

            if Nkind (Rough_Result_Node) = N_Package_Declaration then
               Set_Int_Kind (Rough_Result_Element, A_Package_Declaration);
            else
               Set_Int_Kind (Rough_Result_Element, A_Package_Body_Declaration);
            end if;

         else
            Rough_Res_Spec_Case := Expanded_Subprogram_Instantiation;
         end if;

         Set_Special_Case (Rough_Result_Element, Rough_Res_Spec_Case);

      end if;

      Result_Element       :=  Get_Enclosing
                                 (Approximation => Rough_Result_Element,
                                  Element       => Element);
      return Result_Element;
   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Element,
            Outer_Call => Package_Name & "An_Expression_Enclosing");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument  => Element,
            Diagnosis => Package_Name & "An_Expression_Enclosing");
   end An_Expression_Enclosing;

   ------------------------------
   -- Get_Rough_Enclosing_Node --
   ------------------------------

   function Get_Rough_Enclosing_Node (Element : Asis.Element) return Node_Id
   is
      Arg_Node    : Node_Id := R_Node (Element);
      Result_Node : Node_Id;
      Res_Nkind   : Node_Kind;

      function Is_Acceptable_As_Rough_Enclosing_Node
        (N : Node_Id)
         return Boolean;
      --  this function encapsulates the condition for choosing
      --  the rough enclosing node

      function Is_Acceptable_As_Rough_Enclosing_Node
        (N : Node_Id)
         return Boolean
      is
         N_K    : Node_Kind := Nkind (N);
         Result : Boolean   := True;
      begin

         if not (Is_List_Member (N)
              or else
                (Nkind (Parent (N)) = N_Compilation_Unit or else
                 Nkind (Parent (N)) = N_Subunit))
         then

            Result := False;

         elsif N_K = N_Range                 or else
               N_K = N_Component_Association or else
               N_K = N_Subtype_Indication
         then
            Result := False;

         elsif N_K = N_Procedure_Call_Statement and then
               Nkind (Parent (N)) = N_Pragma
         then
            Result := False;

         elsif not Comes_From_Source (N) and then
               Sloc (N) > Standard_Location
         then

            if not (Is_From_Instance (Element)
                and then
                    Is_Top_Of_Expanded_Generic (N))
            then
               Result := False;
            end if;

         end if;

         return Result;

      end Is_Acceptable_As_Rough_Enclosing_Node;

   begin
      Result_Node := Parent (Arg_Node);

      while Present (Result_Node) and then
            not Is_Acceptable_As_Rough_Enclosing_Node (Result_Node)
      loop
         Result_Node := Parent (Result_Node);

         if Nkind (Result_Node) = N_Compilation_Unit then
            --  this means that there is no node list on the way up
            --  the tree, and we have to go back to the node
            --  for the unit declaration:
            if Is_Standard (Encl_Unit (Element)) then
               Result_Node := Standard_Package_Node;
            else
               Result_Node := Unit (Result_Node);
            end if;

            if Nkind (Result_Node) = N_Subunit then
               Result_Node := Proper_Body (Result_Node);
            end if;

            exit;
         end if;

      end loop;

      --  and here we have to take into account possible normalization
      --  of multi-identifier declarations:
      Res_Nkind := Nkind (Result_Node);

      if Res_Nkind = N_Object_Declaration         or else
         Res_Nkind = N_Number_Declaration         or else
         Res_Nkind = N_Discriminant_Specification or else
         Res_Nkind = N_Component_Declaration      or else
         Res_Nkind = N_Parameter_Specification    or else
         Res_Nkind = N_Exception_Declaration      or else
         Res_Nkind = N_Formal_Object_Declaration  or else
         Res_Nkind = N_With_Clause
      then
         Skip_Normalized_Declarations_Back (Result_Node);
      end if;

      --  If we've got Result_Node pointing to the artificial package
      --  declaration created for library-level generic instantiation,
      --  we have to to the body for which we have this instantiatio as
      --  the original node

      if Nkind  (Result_Node) = N_Package_Declaration      and then
         not Comes_From_Source (Result_Node)               and then
         Nkind (Parent (Result_Node)) = N_Compilation_Unit and then
         not Is_From_Instance (Element)                    and then
         not Is_Rewrite_Substitution (Result_Node)
      then
         Result_Node := Corresponding_Body (Result_Node);

         while Nkind (Result_Node) /= N_Package_Body loop
            Result_Node := Parent (Result_Node);
         end loop;

      end if;


      --  Below is the patch for 8706-003. It is needed when we are looking
      --  for the enclosing element for actual parameter in subprogram
      --  instantiation. In this case esult_Node points to the spec of a
      --  wrapper package, so we have to go to the instantiation (not sure
      --  that this patch is complete???):

      if Nkind (Result_Node) = N_Package_Declaration        and then
         not Comes_From_Source (Result_Node)                and then
         (Nkind (Parent (Arg_Node)) = N_Subprogram_Renaming_Declaration
            and then
         not Comes_From_Source (Parent (Arg_Node)))         and then
         Instantiation_Depth (Sloc (Result_Node)) =
         Instantiation_Depth (Sloc (Arg_Node))
      then

         while not Comes_From_Source (Result_Node) loop
            Result_Node := Next_Non_Pragma (Result_Node);
         end loop;

      end if;

      return Result_Node;

   end Get_Rough_Enclosing_Node;

   -------------------
   -- Get_Enclosing --
   -------------------

   function Get_Enclosing
     (Approximation : Asis.Element;
      Element       : Asis.Element)
      return Asis.Element
   is
      --  we need two-level traversiong for searching for Enclosing Element:
      --  first, we go through the direct children of an approximate
      --  result, and none of them Is_Identical to Element, we repeat
      --  the search process for each direct child. We may implement
      --  this on top of Traverse_Element, but we prefer to code
      --  it manually on top ofA4G.Queries

      Result_Element : Asis.Element;
      Result_Found   : Boolean := False;
      --  needed to simulate the effect of Terminate_Immediatelly

      procedure Check_Possible_Enclosing
        (Appr_Enclosing : in Asis.Element);
      --  implements the first level of the search. Appr_Enclosing is
      --  the "approximate" Enclosing Element, and this procedure
      --  checks if some of its componets Is_Identical to Element
      --  (Element here is the parameter of Get_Enclosing function,
      --  as a global constant value inside Get_Enclosing, it is the
      --  same for all the (recursive) calls of Check_Possible_Enclosing

      ------------------------------
      -- Check_Possible_Enclosing --
      -------------------------------
      procedure Check_Possible_Enclosing
        (Appr_Enclosing : in Asis.Element)
      is
         Child_Access : Query_Array  := Appropriate_Queries (Appr_Enclosing);
         --  this is the way to traverse the direct childs
         Next_Child : Asis.Element;

         procedure Check_List (L : Asis.Element_List);
         --  checks if L contains a component which Is_Identical
         --  to (global) Element. Sets Result_Found ON if such a
         --  component is found

         procedure Check_List_Down (L : Asis.Element_List);
         --  calls Get_Enclosing for every component of L, by
         --  this the recursion and the second level of the search
         --  is implemented

         procedure Check_List (L : Asis.Element_List) is
         begin

            for L_El_Index in L'Range loop

               if Is_Identical (Element, L (L_El_Index)) then
                  Result_Found := True;

                  return;
               end if;

            end loop;

         end Check_List;

         procedure Check_List_Down (L : Asis.Element_List) is
         begin

            if Result_Found then

               return;
               --  it seems that we do not need this if... ???
            end if;

            for L_El_Index in L'Range loop
               Check_Possible_Enclosing (L (L_El_Index));

               if Result_Found then

                  return;
               end if;

            end loop;

         end Check_List_Down;

      begin  -- Check_Possible_Enclosing

         if Result_Found then

            return;
            --  now the only goal is to not disturb the setting of the
            --  global variable Result_Element to be returned as a result
         end if;

         --  first, setting the (global for this procedure) Result_Element:
         Result_Element := Appr_Enclosing;
         --  the first level of the search - checking all the direct
         --  childs:
         for Each_Query in Child_Access'Range loop

            case Child_Access (Each_Query).Query_Kind is
               when Bug =>
                  null;
               when Single_Element_Query =>
                  Next_Child :=
                     Child_Access (Each_Query).Func_Simple (Appr_Enclosing);

                  if Is_Identical (Element, Next_Child) then
                     Result_Found := True;

                     return;
                  end if;

               when Element_List_Query =>

                  declare
                     Child_List : Asis.Element_List :=
                        Child_Access (Each_Query).Func_List (Appr_Enclosing);
                  begin
                     Check_List (Child_List);

                     if Result_Found then

                        return;
                     end if;

                  end;
               when Element_List_Query_With_Boolean =>

                  declare
                     Child_List : Asis.Element_List :=
                        Child_Access (Each_Query).Func_List_Boolean
                           (Appr_Enclosing, Child_Access (Each_Query).Bool);
                  begin
                     Check_List (Child_List);

                     if Result_Found then

                        return;
                     end if;

                  end;
            end case;
         end loop;

         --  if we are here, we have hot found Element among the direct
         --  childs of Appr_Enclosing. So we have to traverse the direct
         --  childs again, but this time we have to go one step down,
         --  so here we have the second level of the search:

         for Each_Query in Child_Access'Range loop

            case Child_Access (Each_Query).Query_Kind is
               when Bug =>
                  null;
               when Single_Element_Query =>
                  Next_Child :=
                     Child_Access (Each_Query).Func_Simple (Appr_Enclosing);

                  --  and here - recursively one step down

                  if not Is_Nil (Next_Child) then
                     Check_Possible_Enclosing (Next_Child);

                     if Result_Found then

                        return;
                     end if;

                  end if;

               when Element_List_Query =>

                  declare
                     Child_List : Asis.Element_List :=
                        Child_Access (Each_Query).Func_List (Appr_Enclosing);
                  begin
                     --  and here - recursively one step down
                     Check_List_Down (Child_List);

                     if Result_Found then

                        return;
                     end if;

                  end;
               when Element_List_Query_With_Boolean =>

                  declare
                     Child_List : Asis.Element_List :=
                        Child_Access (Each_Query).Func_List_Boolean
                           (Appr_Enclosing, Child_Access (Each_Query).Bool);
                  begin
                     --  and here - recursively one step down
                     Check_List_Down (Child_List);

                     if Result_Found then

                        return;
                     end if;

                  end;

            end case;
         end loop;
      end Check_Possible_Enclosing;

   begin  -- Get_Enclosing
      Check_Possible_Enclosing (Approximation);
      pragma Assert (Result_Found);

      return Result_Element;

   exception
      when Assert_Error : System.Assertions.Assert_Failure =>
         Raise_ASIS_Failed (
            Argument  => Element,
            Diagnosis =>
                 Package_Name & "Get_Enclosing - "  & LT
               & "Assert_Failure at "
               &  Ada.Exceptions.Exception_Message (Assert_Error));
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Element,
            Outer_Call => Package_Name & "Get_Enclosing");
         raise;
      when others =>
         Raise_ASIS_Failed (Package_Name & "Get_Enclosing");
   end Get_Enclosing;

   ---------------------------------------
   -- Skip_Normalized_Declarations_Back --
   ---------------------------------------

   procedure Skip_Normalized_Declarations_Back (Node : in out Node_Id) is
      Arg_Kind : Node_Kind := Nkind (Node);
   begin
      loop
         if Arg_Kind = N_Object_Declaration         or else
            Arg_Kind = N_Number_Declaration         or else
            Arg_Kind = N_Discriminant_Specification or else
            Arg_Kind = N_Component_Declaration      or else
            Arg_Kind = N_Parameter_Specification    or else
            Arg_Kind = N_Exception_Declaration      or else
            Arg_Kind = N_Formal_Object_Declaration
         then

            if Prev_Ids (Node) then
               Node := Prev (Node);

               while Nkind (Node) /= Arg_Kind loop
                  --  some implicit subtype decarations may be inserted by
                  --  the compiler in between the normalized declarations, so:
                  Node := Prev (Node);
               end loop;

            else

               return;
            end if;
         elsif Arg_Kind = N_With_Clause then

            if First_Name (Node) then

               return;
            else
               Node := Prev (Node);
            end if;

         else

            return;
            --  nothing to do!
         end if;

      end loop;

   end Skip_Normalized_Declarations_Back;

end A4G.Nencl_El;
