------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . N 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  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

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;     use A4G.Encl_El;
with A4G.Int_Knds;    use A4G.Int_Knds;
with A4G.Mapping;     use A4G.Mapping;
with A4G.Queries;     use A4G.Queries;

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.Nencl_El is

   ------------------------------
   -- An_Association_Enclosing --
   ------------------------------

   function An_Association_Enclosing
     (Element : Asis.Element)
      return    Asis.Element
   is
      Result : Asis.Element;
   begin

      if Normalization_Case (Element) = Is_Not_Normalized then
         Result := An_Expression_Enclosing (Element);
      else
         Result := Node_To_Element_New
                     (Node             => Parent (Node (Element)),
                      Starting_Element => Element);
      end if;

      return Result;
   end An_Association_Enclosing;

   -----------------------------
   -- 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 or else
              Special_Case (Start_Elem) = Configuration_File_Pragma)
      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;
   end An_Expression_Enclosing;

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

   function Get_Rough_Enclosing_Node (Element : Asis.Element) return Node_Id
   is
      Arg_Node    : constant 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    : constant 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))
            or else
              Nkind (N) in N_Subexpr
            or else
              Nkind (N) =  N_Parameter_Association
         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);

      if Nkind (Result_Node) = N_Object_Renaming_Declaration
        and then
         Special_Case (Element) = Is_From_Gen_Association
        and then
         Present (Corresponding_Generic_Association (Result_Node))
      then
         Result_Node := Corresponding_Generic_Association (Result_Node);
      end if;

      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_Object_Renaming_Declaration
           and then
            Special_Case (Element) = Is_From_Gen_Association
           and then
            Present (Corresponding_Generic_Association (Result_Node))
         then
            Result_Node := Corresponding_Generic_Association (Result_Node);
         end if;

         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 the body for which we have this instantiation 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 (Nkind (Original_Node (Result_Node)) = N_Package_Instantiation
           or else
               Nkind (Original_Node (Result_Node)) = N_Package_Body)
        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 traversing 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 of A4G.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 components 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 : constant Query_Array :=
           Appropriate_Queries (Appr_Enclosing);
         --  this is the way to traverse the direct children
         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
         --  children:
         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 : constant 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 : constant 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
         --  children of Appr_Enclosing. So we have to traverse the direct
         --  children 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 : constant 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 : constant 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;

   end Get_Enclosing;

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

   procedure Skip_Normalized_Declarations_Back (Node : in out Node_Id) is
      Arg_Kind : constant 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 declarations 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;
