------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                            A 4 G . A _ S E M                             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.56 $
--                                                                          --
--            Copyright (c) 1995-2002, 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 Ada.Exceptions;

with System.Assertions;

with Asis.Exceptions;   use Asis.Exceptions;
with Asis.Iterator;     use Asis.Iterator;
with Asis.Elements;     use Asis.Elements;
with Asis.Extensions;   use Asis.Extensions;

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.Contt.TT;      use A4G.Contt.TT; use A4G.Contt;
with A4G.Contt.UT;      use A4G.Contt.UT;

with Atree;             use Atree;
with Sinfo;             use Sinfo;
with Einfo;             use Einfo;
with Nlists;            use Nlists;
with Sinput;            use Sinput;
with Snames;            use Snames;

package body A4G.A_Sem is

   LT : String renames ASIS_Line_Terminator;
   Package_Name : constant String := "A4G.A_Sem.";

   ------------------------------
   -- Char_Defined_In_Standard --
   ------------------------------

   function Char_Defined_In_Standard (N : Node_Id) return Boolean is
      N_Etype  : Node_Id;
   begin
      N_Etype := Etype  (N);

      if No (N_Etype) then
         --  It may happen for array literal rewritten into a string literal,
         --  so some additional digging is needed
         N_Etype := Parent (N);

         if Nkind (N_Etype) = N_String_Literal then
            N_Etype := Etype (N_Etype);

            if Ekind (N_Etype) = E_String_Literal_Subtype then
               N_Etype := Component_Type (N_Etype);
            end if;

         else
            N_Etype := Empty;
         end if;

      end if;

      return Present (N_Etype) and then
             Sloc    (N_Etype) <= Standard_Location;
   end Char_Defined_In_Standard;

   ------------------------
   -- Corr_Decl_For_Stub --
   ------------------------

   function Corr_Decl_For_Stub (Stub_Node : Node_Id) return Node_Id is
      Result_Node       : Node_Id := Empty;
      Stub_Entity_Node  : Node_Id;
      Scope_Node        : Node_Id;
      Search_Node       : Node_Id;
      Search_Node_Kind  : Node_Kind;
      List_To_Search    : List_Id;
      Search_In_Package : Boolean;
      Decl_Found        : Boolean := False;
      Priv_Decl_Passed  : Boolean := False;
      Body_Passed       : Boolean := False;

      procedure Search_In_List;
      --  looks for a possible subprogram declaration node for which
      --  the given stub is a completion, using global settings for
      --  List_To_Search and Search_Node

      function Is_Spec_For_Stub
        (Search_Node      : Node_Id;
         Stub_Node        : Node_Id;
         Stub_Entity_Node : Node_Id)
         return Boolean;
      --  check if the current Search_Node is a corresponding definition
      --  for a given stub. We cannot directly use the Corresponding_Body
      --  field here, because in case when subunits are around, this field
      --  will point to a proper body of a subunit, but not to a stub
      --  This function is called only for those nodes for which
      --  Corresponding_Body field makes sense

      function Is_Spec_For_Stub
        (Search_Node      : Node_Id;
         Stub_Node        : Node_Id;
         Stub_Entity_Node : Node_Id)
         return Boolean
      is
         Corr_Body_Node : Node_Id := Corresponding_Body (Search_Node);
         N              : Node_Id;
      begin

         if Corr_Body_Node = Stub_Entity_Node then
            return True;
         else
            --  we have to check if we are in the proper body of a subunit
            N := Parent (Corr_Body_Node);

            if Nkind (N) = N_Procedure_Specification or else
               Nkind (N) = N_Function_Specification
            then
               N := Parent (N);
            end if;

            N := Parent (N);
            --  now, in case of subunit's parent body, we should be in
            --  N_Subunit node

            if Nkind (N) = N_Subunit then
               return Corresponding_Stub (N) = Stub_Node;
            else
               return False;
            end if;

         end if;

      end Is_Spec_For_Stub;

      procedure Search_In_List is
      begin

         while Present (Search_Node) loop
            Search_Node_Kind := Nkind (Search_Node);

            if   (Search_Node_Kind = N_Subprogram_Declaration         or else
                  Search_Node_Kind = N_Generic_Subprogram_Declaration or else
                  Search_Node_Kind = N_Package_Declaration            or else
                  Search_Node_Kind = N_Generic_Package_Declaration    or else
                  Search_Node_Kind = N_Single_Task_Declaration        or else
                  Search_Node_Kind = N_Task_Type_Declaration          or else
                  Search_Node_Kind = N_Single_Protected_Declaration   or else
                  Search_Node_Kind = N_Protected_Type_Declaration)
               and then
                  Is_Spec_For_Stub (Search_Node, Stub_Node, Stub_Entity_Node)
                  --  ???Corresponding_Body (Search_Node) = Stub_Entity_Node
            then
               --  the corresponding declaration for the stub is found
               Result_Node := Search_Node;
               Decl_Found := True;

               return;

            elsif Search_Node = Stub_Node then
               --  no need to search any mode, no declaration exists,
               --  the stub itself works as a declaration
               Decl_Found := True;

               return;

            end if;

            Search_Node := Next_Non_Pragma (Search_Node);
         end loop;

      end Search_In_List;

   begin  --  Corr_Decl_For_Stub

      --  first, setting Stub_Entity_Node:
      if Nkind (Stub_Node) = N_Subprogram_Body_Stub then
         Stub_Entity_Node := Defining_Unit_Name (Specification (Stub_Node));
      else
         Stub_Entity_Node := Defining_Identifier (Stub_Node);
      end if;

      --  then, defining the scope node and list to search in:
      Scope_Node := Scope (Stub_Entity_Node);

      if No (Scope_Node) then
         --  Unfortunately, this is the case for stubs of generic units
         --  with no (non-generic) parameters
         Scope_Node := Stub_Entity_Node;

         while not (Nkind (Scope_Node) = N_Package_Body or else
                    Nkind (Scope_Node) = N_Subprogram_Body)
         loop
            Scope_Node := Parent (Scope_Node);
         end loop;

         if Nkind (Scope_Node) = N_Package_Body then
            Scope_Node := Corresponding_Spec (Scope_Node);
         else
            Scope_Node := Defining_Unit_Name (Specification (Scope_Node));
         end if;

      end if;

      if Ekind (Scope_Node) = E_Generic_Package or else
         Ekind (Scope_Node) = E_Package
      then
         Search_In_Package := True;
         Scope_Node := Parent (Scope_Node);

         if Nkind (Scope_Node) = N_Defining_Program_Unit_Name then
            --  we are in a child library package
            Scope_Node := Parent (Scope_Node);
         end if;

         --  now we are in the package spec
         List_To_Search := Visible_Declarations (Scope_Node);

         if No (List_To_Search) then
            List_To_Search := Private_Declarations (Scope_Node);
            Priv_Decl_Passed := True;

            if No (List_To_Search) then
               List_To_Search := List_Containing (Stub_Node);
               --  what else could it be?
               Body_Passed := True;
            end if;

         end if;

      else
         --  The situation of the stub for generic subprogram having
         --  (non-generic) parameters makes a special case:
         if Ekind (Scope_Node) in Generic_Unit_Kind and then
            Corresponding_Stub (Parent (Parent (Parent (Corresponding_Body
              (Parent (Parent (Scope_Node))))))) =
            Stub_Node
         then
            return Parent (Parent (Scope_Node));
         else
            Search_In_Package := False;
            List_To_Search := List_Containing (Stub_Node);
         end if;

      end if;

      Search_Node := First_Non_Pragma (List_To_Search);
      Search_In_List;

      --  now, if we are in a package, and if we have not found the result
      --  (or passed the stub node), we have to continue:

      if Search_In_Package and then not Decl_Found then
         --  where should we continue the search?

         if not Priv_Decl_Passed then
            List_To_Search := Private_Declarations (Scope_Node);
            Priv_Decl_Passed := True;

            if No (List_To_Search) then
               List_To_Search := List_Containing (Stub_Node);
               Body_Passed := True;
            end if;

         elsif not Body_Passed then
            List_To_Search := List_Containing (Stub_Node);
            Body_Passed := True;
         end if;

         Search_Node := First_Non_Pragma (List_To_Search);
         Search_In_List;

         if not Decl_Found then
            --  if we are here, we have to search the package body,
            --  where the stub itself is
            List_To_Search := List_Containing (Stub_Node);
            Search_Node := First_Non_Pragma (List_To_Search);
            Search_In_List;
         end if;

      end if;

      return Result_Node;

   end Corr_Decl_For_Stub;

   -------------------------
   -- Defined_In_Standard --
   -------------------------

   function Defined_In_Standard (N : Node_Id) return Boolean is
      N_Entity : Node_Id := Entity (N);
      N_Etype  : Node_Id := Etype  (N);
   begin
      return Present (N_Entity)                      and then
             Present (N_Etype)                       and then
             Sloc    (N_Entity) <= Standard_Location and then
             Sloc    (N_Etype)  <= Standard_Location;
   end Defined_In_Standard;

   --------------------------
   -- Get_Actual_Type_Name --
   --------------------------

   function Get_Actual_Type_Name (Type_Mark_Node : Node_Id) return Node_Id is
      Result   : Node_Id := Type_Mark_Node;
      Tmp_Node : Node_Id;
   begin

      if Is_From_Instance (Type_Mark_Node) then
         Tmp_Node := Entity (Type_Mark_Node);

         if Present (Tmp_Node) then
            Tmp_Node := Parent (Tmp_Node);
         end if;

         if Nkind (Tmp_Node) = N_Subtype_Declaration and then
            not Comes_From_Source (Tmp_Node)
         then
            Result := Sinfo.Subtype_Indication (Tmp_Node);
            --  In case of nesed instantiations, we have to traverse
            --  the chain of subtype declarations created by the compiler
            --  for actual types
            while Is_From_Instance (Result)
               and then
                  Nkind (Parent (Entity (Result))) = N_Subtype_Declaration
               and then
                  not Comes_From_Source (Parent (Entity (Result)))
            loop
               Result := Parent (Entity (Result));

               if Is_Rewrite_Substitution (Result) then
                  --  The case when the actal type is a derived type. Here
                  --  the chain of subtypes leads to the artificial internal
                  --  type created by the compiler, but not to the actual type
                  --  (8924-006)
                  Result := Sinfo.Defining_Identifier (Result);

                  while Present (Homonym (Result)) loop
                     Result := Homonym (Result);
                  end loop;

                  exit;

               end if;

               Result := Sinfo.Subtype_Indication (Result);
            end loop;

         end if;

      end if;

      return Result;

   end Get_Actual_Type_Name;

   ----------------------------
   -- Get_Corr_Called_Entity --
   ----------------------------

   function Get_Corr_Called_Entity
     (Call : Asis.Element)
      return Asis.Declaration
   is
      Arg_Node          : Node_Id;
      Arg_Node_Kind     : Node_Kind;
      Result_Node       : Node_Id;
      Result_Unit       : Compilation_Unit;
      Special_Case      : Special_Cases := Not_A_Special_Case;
      Result_Kind       : Internal_Element_Kinds := Not_An_Element;
      Inherited         : Boolean := False;
      Res_Node_Field_1  : Node_Id := Empty;

      Tmp_Node          : Node_Id;
   begin

      --  The general implementation approach is:
      --
      --  1. First, we try to define Result_Node as pointing to the tree
      --     node on which the resulting ASIS Element should be based.
      --     During this step Arg_Node is also set (and probably adjusted)
      --
      --  2. If the result looks like representing an Ada implicit construct
      --     (for now the main and the only check is
      --     Comes_From_Source (Result_Node)), at the second step we
      --     form the representation of the implicit inherited user-defined
      --     subprogram by setting Result_Node pointing to the explicit
      --     declaration of the subprogram being inherited, and
      --     Res_Node_Field_1 pointing to the defining identifier node
      --     corresponding to the given implicit subprogram. Note, that
      --     at the moment implicit predefined operations are not
      --     implemented.
      --
      --  3. On the last step we compute additional attributes of the
      --     resulting Element.

      ------------------------------------------------------------------
      --  1. Defining Result_Node (and adjusting Arg_Node, if needed) --
      ------------------------------------------------------------------

      Arg_Node := R_Node (Call);
      Arg_Node_Kind := Nkind (Arg_Node);
      --  Rewritten node should know everything. But if in case of a function
      --  call this node is the result of compile-time optimization,
      --  we have to work with original node only:

      if Arg_Node_Kind = N_String_Literal         or else
         Arg_Node_Kind = N_Integer_Literal        or else
         Arg_Node_Kind = N_Real_Literal           or else
         Arg_Node_Kind = N_Character_Literal      or else
         Arg_Node_Kind = N_Raise_Constraint_Error or else
         Arg_Node_Kind = N_Raise_Program_Error    or else
         Arg_Node_Kind = N_Conditional_Expression or else
         Arg_Node_Kind = N_Explicit_Dereference   or else
         Arg_Node_Kind = N_Type_Conversion        or else
         Arg_Node_Kind = N_Identifier             or else
         (Arg_Node_Kind in N_Op and then
          Nkind (Original_Node (Arg_Node)) = N_Function_Call)
         --  the last condition really is a temporary fix
         --  for a known bug
      then
         Arg_Node      := Node (Call);
         Arg_Node_Kind := Nkind (Arg_Node);
      end if;

      case Arg_Node_Kind is

         when  N_Attribute_Reference =>

            return Nil_Element;

            --  call to a procedure-attribute or to a function-attribute
            --  but in case when a representation clause was applied
            --  to define stream IO attributes, we can return something
            --  more interesting, then Nil_Element, see the corresponding
            --  Alain's message

         when  N_Entry_Call_Statement     |
               N_Procedure_Call_Statement |
               N_Function_Call =>
            --  here we have to filter out the case when Nil_Element
            --  should be returned for a call through access-to-function:

            if Nkind (Sinfo.Name (Arg_Node)) = N_Explicit_Dereference then

               return Nil_Element;
            end if;

            if Arg_Node_Kind = N_Entry_Call_Statement then
               Arg_Node := Sinfo.Name (Arg_Node);
               --  Arg_Node points to the name of the called entry

               if Nkind (Arg_Node) = N_Indexed_Component then
                  --  this is the case for a call to an entry from an
                  --  entry family
                  Arg_Node := Prefix (Arg_Node);
               end if;

               Result_Node := Entity (Selector_Name (Arg_Node));

            else
               --  here we have Arg_Node_Kind equal to
               --  N_Procedure_Call_Statement or to N_Function_Call, and this
               --  is the right place to check if this is a dispatching call.
               --  We do not want to use Asis.Extensions.Is_Dispatching_Call
               --  query here to avoid introducing dependency on
               --  Asis.Extensions

               if Present (Controlling_Argument (Arg_Node)) then
                  return Nil_Element;
               end if;

               Arg_Node := Sinfo.Name (Arg_Node);

               if Nkind (Arg_Node) = N_Selected_Component then
                  --  this is the case for calls to protected subprograms
                  Result_Node := Entity (Selector_Name (Arg_Node));
               else
                  Result_Node := Entity (Arg_Node);
               end if;

            end if;

            if No (Result_Node)                and then
               Arg_Node_Kind = N_Function_Call and then
               Is_From_Unknown_Pragma (R_Node (Call))
            then
               return Nil_Element;
            end if;

         when N_Op =>
            --  all the predefined operations (??)
            Result_Node := Entity (Arg_Node);

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

      pragma Assert (Present (Result_Node));

      --  it is possible, that for a subprogram defined by a stub, the
      --  subprogram body declaration from the corresponding subunit is
      --  returned. In this case we have to go to the corresponding
      --  stub (the subprogram body which is the proper body from a
      --  subunit can never be returned as a corresponding called entity)

      Set_Stub_For_Subunit_If_Any (Result_Node);

      if Is_Generic_Instance (Result_Node) then
         Result_Node := Get_Instance_Name (Result_Node);
      end if;

      Tmp_Node := Parent (Parent (Result_Node));

      while Nkind (Tmp_Node) = N_Subprogram_Renaming_Declaration and then
            not (Comes_From_Source (Tmp_Node))
      loop
         --  If we are here, there are two (?) possibilities:
         --  (1) Result_Node is a defining name from the artificial renaming
         --      declarations created by the compiler in the for wrapper
         --      package for expanded subprogram instantiation. We
         --      have to go to expanded subprogram spec which is renamed.
         --  (2) Result_Node is a defining name from the artificial renaming
         --      declaration created as a way to pass actiual subprogram
         --      in the expanded code. We have to go to the declaration of
         --      this actual subprogram
         --
         --  We have to do this in a loop in case of nested instantiations

         Result_Node := Sinfo.Name   (Tmp_Node);
         Result_Node := Entity (Result_Node);

         Tmp_Node := Parent (Parent (Result_Node));
      end loop;

      --  the code below is very similar to what we have in
      --  A4G.Expr_Sem.Identifier_Name_Definition (this name may be changed)!
      --  In future we'll probably have to re-study this again (???)

      --  first, defining the Enclosing Unit and doing the consistency check

      -----------------------------------------------------------
      -- 2. Defining Association_Etype as the type "producing" --
      --    a given implicit construct (if needed)             --
      -----------------------------------------------------------

      --  We have to turn off for a while the full processing of the
      --  implicit elements (Hope to fix this soon).

      if not Comes_From_Source (Result_Node) then

         if Present (Alias (Result_Node)) and then
            not (Is_Intrinsic_Subprogram (Result_Node))
         then
            --  ???Is this the right test for implicit inherited user-defined
            --  subprogram???
            Inherited         := True;
            Res_Node_Field_1  := Result_Node;

            while Present (Alias (Result_Node)) and then
                 not Comes_From_Source (Result_Node)
            loop
               Result_Node := Alias (Result_Node);
            end loop;

         elsif Is_Generic_Instance (Result_Node) then

            Special_Case := Expanded_Subprogram_Instantiation;

         else

            return Nil_Element;
            --  ???!!! this turns off all the predefined operations!!!

         end if;

      end if;

      --  Now, checking if we have a call to an entry/procedure/function of
      --  derived task/protected type
      Tmp_Node := Arg_Node;

      if Nkind (Tmp_Node) = N_Selected_Component then
         Tmp_Node := Prefix (Tmp_Node);
         Tmp_Node := Etype (Tmp_Node);

         if Ekind (Tmp_Node) in Concurrent_Kind then

            while not Comes_From_Source (Original_Node (Parent (Tmp_Node)))
            loop
               Tmp_Node := Etype (Tmp_Node);
            end loop;

            Tmp_Node := Parent (Tmp_Node);

            if Nkind (Tmp_Node) = N_Full_Type_Declaration and then
               Nkind (Sinfo.Type_Definition (Tmp_Node)) =
               N_Derived_Type_Definition
            then
               Inherited         := True;
               Res_Node_Field_1  := Tmp_Node;
            end if;

         end if;

      end if;

      if Present (Res_Node_Field_1) then
         Result_Unit :=
            Enclosing_Unit (Encl_Cont_Id (Call), Res_Node_Field_1);
      else
         Result_Unit :=
            Enclosing_Unit (Encl_Cont_Id (Call), Result_Node);
      end if;
      --  ???  should be changed when full processing of implicit elements
      --  will be ready

      --  And now - from a defining name to a declaration itself
      --  (this also may need adjustment for the full implementation
      --  of the implicit stuff)

      if Inherited then

         --  For inherited subprograms we have to set the result kind manually
         --  to get subprogram declarations in case of inheriting from
         --  subprogram renamings (8728-023)

         if Ekind (Result_Node) = E_Function or else
            Ekind (Result_Node) = E_Operator
         then
            Result_Kind := A_Function_Declaration;
         elsif Ekind (Result_Node) = E_Procedure then
            Result_Kind := A_Procedure_Declaration;
         end if;

      end if;

      if Special_Case not in Predefined then
         Result_Node := Parent (Result_Node);

         if Nkind (Result_Node) = N_Procedure_Specification or else
            Nkind (Result_Node) = N_Function_Specification
         then
            Result_Node := Parent (Result_Node);
         end if;

      elsif Special_Case in Predefined then
         Result_Kind := A_Function_Declaration;

      end if;

      return Node_To_Element_New
        (Node          => Result_Node,
         Node_Field_1  => Res_Node_Field_1,
         Internal_Kind => Result_Kind,
         Spec_Case     => Special_Case,
         Inherited     => Inherited,
         In_Unit       => Result_Unit);

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

   end Get_Corr_Called_Entity;

   ----------------------
   -- Get_Derived_Type --
   ----------------------

   function Get_Derived_Type
     (Type_Entity     : Entity_Id;
      Inherited_Subpr : Entity_Id)
      return            Entity_Id
   is
      Result            : Entity_Id := Type_Entity;
      Derived_Type      : Entity_Id;
      Next_Derived_Type : Entity_Id;
   begin
      Derived_Type      := Original_Node (Parent (Inherited_Subpr));

      Next_Derived_Type := Derived_Type;

      if Nkind (Next_Derived_Type) = N_Full_Type_Declaration then
         Next_Derived_Type := Sinfo.Type_Definition (Next_Derived_Type);
      end if;

      Next_Derived_Type := Sinfo.Subtype_Indication (Next_Derived_Type);

      Derived_Type      := Defining_Identifier (Derived_Type);

      if Nkind (Next_Derived_Type) = N_Subtype_Indication then
         Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type);
      end if;

      Next_Derived_Type := Entity (Next_Derived_Type);

      loop

         if Next_Derived_Type = Type_Entity then
            Result := Derived_Type;
            exit;

         elsif Is_Derived_Type (Next_Derived_Type) then

            Next_Derived_Type := Original_Node (Parent (Next_Derived_Type));

            if Nkind (Next_Derived_Type) = N_Full_Type_Declaration then
               Next_Derived_Type := Sinfo.Type_Definition (Next_Derived_Type);
            end if;

            Next_Derived_Type := Sinfo.Subtype_Indication (Next_Derived_Type);

            if Nkind (Next_Derived_Type) = N_Subtype_Indication then
               Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type);
            end if;

            Next_Derived_Type := Entity (Next_Derived_Type);

         else
            exit;
         end if;

      end loop;

      return Result;

   end Get_Derived_Type;

   -----------------------
   -- Get_Instance_Name --
   -----------------------

   function Get_Instance_Name (Int_Name : Node_Id) return Node_Id is
      Result_Node : Node_Id := Empty;
      Decl_Node   : Node_Id;
   begin
      Decl_Node := Parent (Parent (Int_Name));

      if Nkind (Decl_Node) = N_Subprogram_Declaration then
         Decl_Node := Parent (Parent (Decl_Node));
      end if;

      if (not Is_List_Member (Decl_Node) and then
          not Is_Rewrite_Substitution (Decl_Node))
         or else
          (Is_List_Member (Decl_Node) and then
           Nkind (Next (Decl_Node)) = N_Formal_Package_Declaration)
      then
         --  The first condition corresponds to the case when a library
         --  package is instantiated at library level - no artificial package
         --  is created in this case.
         --  The second condition corresponds to the defining name from
         --  a formal package declaration (it is also classified as
         --  Is_Generic_Instance)

         return Int_Name;

      end if;
      --  now Decl_Node points to the declaration of an artificial package
      --  created by the compiler for the instantiation

      if Is_Rewrite_Substitution (Decl_Node) then
         Decl_Node := Original_Node (Decl_Node);

         if Is_Rewrite_Substitution (Decl_Node) then
            --  The node can be rewritten twice in case when a library-level
            --  instantiation is a supporter of a main unit, and the expanded
            --  body of this instantiation is required according to Lib (h),
            --  see 9418-015, 9416-A01 and 9426-A13
            Decl_Node := Original_Node (Decl_Node);
         end if;

         Result_Node := Defining_Unit_Name (Original_Node (Decl_Node));
      else

         Decl_Node := Next_Non_Pragma (Decl_Node);

         while Present (Decl_Node) loop
            if Nkind (Decl_Node) in N_Generic_Instantiation then
               Result_Node := Defining_Unit_Name (Decl_Node);
               exit;

            else
               Decl_Node := Next_Non_Pragma (Decl_Node);
            end if;

         end loop;

      end if;

      pragma Assert (Present (Result_Node));

      return Result_Node;

   end Get_Instance_Name;

   -------------------------
   -- Is_Derived_Rep_Item --
   -------------------------

   function Is_Derived_Rep_Item
     (Type_Entity : Entity_Id;
      Rep_Item :    Node_Id)
      return        Boolean
   is
      Result   : Boolean := True;
      Type_Ard : Node_Id := Empty;
   begin

      case Nkind (Rep_Item) is

         when N_Attribute_Definition_Clause =>

            if Entity (Sinfo.Name (Rep_Item)) = Type_Entity then
               Result := False;
            end if;

         when N_Pragma =>

            Type_Ard := Sinfo.Expression
                          (First (Pragma_Argument_Associations (Rep_Item)));

            if Entity (Type_Ard) = Type_Entity then
               Result := False;
            end if;

         when N_Enumeration_Representation_Clause |
              N_Record_Representation_Clause =>

            if Entity (Sinfo.Identifier (Rep_Item)) = Type_Entity then
               Result := False;
            end if;

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

      return Result;
   end Is_Derived_Rep_Item;

   ----------------------
   -- Is_From_Instance --
   ----------------------

   function Is_From_Instance (Node : Node_Id) return Boolean is
   begin

      return Sloc (Node) > Standard_Location and then
             Instantiation (Get_Source_File_Index (Sloc (Node))) /=
                No_Location;

   end Is_From_Instance;

   ----------------------------
   -- Is_From_Unknown_Pragma --
   ----------------------------

   function Is_From_Unknown_Pragma (Node : Node_Id) return Boolean is
      Result : Boolean := False;
      Tmp    : Node_Id := Parent (Node);
   begin
      while Nkind (Tmp) /= N_Compilation_Unit loop

         case Nkind (Tmp) is

            when N_Pragma =>

               if Chars (Tmp) not in First_Pragma_Name .. Last_Pragma_Name then
                  Result := True;
               end if;

               exit;

            when N_Statement_Other_Than_Procedure_Call |
                 N_Procedure_Call_Statement            |
                 N_Representation_Clause               |
                 N_Component_Declaration ..
                 N_Generic_Procedure_Renaming_Declaration =>

               exit;

            when others =>
               Tmp := Parent (Tmp);
         end case;

      end loop;

      return Result;
   end Is_From_Unknown_Pragma;

   -------------------
   -- Is_Predefined --
   -------------------

   function Is_Predefined (Def_Op : Node_Id) return Boolean is
   begin
      --  ???
      return ((Ekind (Def_Op) = E_Operator or else
              (Ekind (Def_Op) = E_Function))
           and then
              (not Comes_From_Source (Def_Op))
           and then
              (Sloc (Def_Op) <= Standard_Location or else
               No (Alias (Def_Op))                or else
               No (Parent (Def_Op))));
   end Is_Predefined;

   --------------------
   -- Reset_For_Body --
   --------------------

   procedure Reset_For_Body
     (El        : in out Asis.Element;
      Body_Unit : Asis.Compilation_Unit)
   is
      Spec_CU   : Unit_Id    := Encl_Unit_Id (El);
      Arg_Tree  : Tree_Id    := Encl_Tree (El);
      Body_Tree : Tree_Id;
      Result_El : Asis.Element := Nil_Element;

      --  and the rest of the local declarations is needed for traversal
      Spec_El  : Asis.Element;

      My_State : No_State              := Not_Used;
      Control  : Asis.Traverse_Control := Continue;

      procedure Pre_Op
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out No_State);

      procedure Pre_Op
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out No_State)
      is
         pragma Unreferenced (State);

         El_Kind : Internal_Element_Kinds := Int_Kind (Element);
      begin

         case El_Kind is
            when A_Task_Type_Declaration         |
                 A_Single_Task_Declaration       |
                 An_Incomplete_Type_Declaration  |
                 A_Procedure_Declaration         |
                 A_Function_Declaration          |
                 A_Generic_Procedure_Declaration |
                 A_Generic_Function_Declaration
               =>
               --  here we have declarations which may have completion in the
               --  package body, but their subcomponents cannot have a
               --  completion

               if Is_Equal (Element, El) then
                  Result_El := Element;
                  Control := Terminate_Immediately;
               else
                  Control := Abandon_Children;
               end if;

            when A_Protected_Type_Declaration    |
                 A_Single_Protected_Declaration  |
                 A_Package_Declaration           |
                 A_Generic_Package_Declaration
               =>
               --  here we have declarations which may have completion in the
               --  package body, their subcomponents also can have a completion

               if Is_Equal (Element, El) then
                  Result_El := Element;
                  Control := Terminate_Immediately;
               end if;

            when A_Protected_Definition =>
               Control := Continue;
               --  To look for protected etries and subprograms

            when others =>
               Control := Abandon_Children;
         end case;

      end Pre_Op;

      procedure Find_For_Reset is new Traverse_Element
        (State_Information => No_State,
         Pre_Operation     => Pre_Op,
         Post_Operation    => No_Op);

   begin
      Reset_Tree_For_Unit (Body_Unit);
      Body_Tree := Get_Current_Tree;

      if Arg_Tree = Body_Tree then
         return;
      end if;

      Spec_El := Node_To_Element_New
                   (Node             => Unit (Top (Spec_CU)),
                    Starting_Element => El);

      Find_For_Reset (Spec_El, Control, My_State);

      pragma Assert (not Is_Nil (Result_El));

      El := Result_El;

   end Reset_For_Body;

   ---------------------------------
   -- Set_Stub_For_Subunit_If_Any --
   ---------------------------------

   procedure Set_Stub_For_Subunit_If_Any (Def_Name : in out Node_Id)
   is
      Stub_Node : Node_Id;
      Decl_Node : Node_Id;
      Node_Context : Node_Id := Parent (Parent (Parent (Def_Name)));
   begin

      if not (Nkind (Def_Name) = N_Defining_Identifier               and then
              Nkind (Node_Context) = N_Subunit                       and then
              Nkind (Proper_Body (Node_Context)) = N_Subprogram_Body and then
              Def_Name =  Defining_Unit_Name (Specification
                (Proper_Body (Node_Context))))
      then
         --  nothing to change
         return;

      else
         Def_Name := Defining_Unit_Name
                       (Specification (Corresponding_Stub (Node_Context)));
         Stub_Node := Parent (Parent (Def_Name));
         Decl_Node := Corr_Decl_For_Stub (Stub_Node);

         if Present (Decl_Node) then
            Def_Name := Defining_Unit_Name (Specification (Decl_Node));
         end if;

      end if;

   end Set_Stub_For_Subunit_If_Any;

   ---------------------
   -- Unwind_Renaming --
   ---------------------

   function Unwind_Renaming (Def_Name : Node_Id) return Node_Id is
      Parent_Decl : Node_Id;
      Result_Node : Node_Id;
   begin
      --  a recursive algorithm is probably not the most effective,
      --  but it is easy-to-maintain. Moreover, we do not really
      --  expect long renaming chains in not-crazy programs
      --  When the implementation of this function is stable, we probably
      --  should replace the recursive code by the iteration-based code

      Result_Node := Def_Name;
      Parent_Decl := Parent (Result_Node);

      case Nkind (Parent_Decl) is

         when N_Renaming_Declaration =>
            --  unwinding once again
            Result_Node := Sinfo.Name (Entity (Parent_Decl));

            return Unwind_Renaming (Result_Node);

         when N_Function_Specification | N_Procedure_Specification =>
            --  two cases are possible: if this subprogram specification
            --  is the component of another (subprogram) renaming
            --  declaration, we should unwind again,
            --  otherwise we have got the result:

            if Nkind (Parent (Parent_Decl)) =
               N_Subprogram_Renaming_Declaration
            then
               --  unwinding once again
               --  Result_Node := Sinfo.Name (Entity (Parent (Parent_Decl)));
               Result_Node := Entity (Sinfo.Name (Parent (Parent_Decl)));

               return Unwind_Renaming (Result_Node);

            else

               if Is_Rewrite_Substitution (Parent (Parent_Decl)) and then
                  Nkind (Original_Node (Parent (Parent_Decl))) =
                                        N_Subprogram_Renaming_Declaration
               then
                  --  this means, that we have met the renaming of a
                  --  subprogram-attribute, so
                  return Empty;

               else
                  --  all the renamings (if any) have already been unwounded
                  return Result_Node;

               end if;

            end if;

         when others =>

            return Result_Node;

      end case;

   end Unwind_Renaming;

end A4G.A_Sem;
