File : asis-extensions.adb


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                      A S I S . E X T E N S I O N S                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-1999, 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 Ada.Characters.Handling; use Ada.Characters.Handling;

with System.Assertions;

with Asis.Exceptions;         use Asis.Exceptions;
with Asis.Elements;           use Asis.Elements;
with Asis.Compilation_Units;  use Asis.Compilation_Units;
with Asis.Declarations;       use Asis.Declarations;
with Asis.Statements;         use Asis.Statements;
with Asis.Iterator;           use Asis.Iterator;

with A4G.Queries;             use A4G.Queries;

with Asis.Set_Get;            use  Asis.Set_Get;

with A4G.A_Types;             use A4G.A_Types;
with A4G.A_Sem;               use A4G.A_Sem;
with A4G.Contt;               use A4G.Contt;
with A4G.Contt.UT;            use A4G.Contt.UT;
with A4G.A_Debug;             use A4G.A_Debug;
with A4G.C_U_Info;            use A4G.C_U_Info;
with A4G.Int_Knds;            use A4G.Int_Knds;
with A4G.Mapping;             use A4G.Mapping;
with A4G.Vcheck;              use A4G.Vcheck;

with Types;                   use Types;
with Sinfo;                   use Sinfo;
with Einfo;                   use Einfo;
with Atree;                   use Atree;
with Nlists;                  use Nlists;
with Output;                  use Output;
with Stand;                   use Stand;
with Snames;                  use Snames;

package body Asis.Extensions is

   LT : String renames ASIS_Line_Terminator;
   Package_Name : String := "Asis.Extensions.";

   -----------------------
   -- Local subprograms --
   -----------------------

   function Is_Typeless_Subaggregate (Aggr : Node_Id) return Boolean;
   --  Checks if Aggr represents an inner typeless subaggregate of
   --  multi-dimensional array subaggregate

   function Is_Expanded_Subprogram (N : Node_Id) return Boolean;
   --  Checks if N corresponds to the spec of an expanded generic
   --  subprogram. Is needed because Comes_From_Source in this case is
   --  set OFF (opposite to expanded packages)

   ------------------
   -- Acts_As_Spec --
   ------------------

   function Acts_As_Spec (Declaration : Asis.Element) return Boolean is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
      Arg_Node : Node_Id;
   begin
      Arg_Node := Node (Declaration);

      if Arg_Kind = A_Procedure_Body_Declaration or else
         Arg_Kind = A_Function_Body_Declaration
      then
         return Acts_As_Spec (Arg_Node);
      elsif Arg_Kind = A_Procedure_Body_Stub or else
            Arg_Kind = A_Function_Body_Stub
      then
--         return No (Corr_Decl_For_Stub (Arg_Node));
         return not (
            Ekind (Defining_Unit_Name (Specification (Arg_Node))) =
            E_Subprogram_Body);
      else
         return False;
      end if;
   end Acts_As_Spec;

   ------------------------------
   -- Compilation_Dependencies --
   ------------------------------

   function Compilation_Dependencies
     (Main_Unit : Asis.Compilation_Unit)
      return Asis.Compilation_Unit_List
   is
      Arg_Kind    : Asis.Unit_Kinds := Kind (Main_Unit);
      Arg_Unit_Id : Unit_Id;
      Res_Cont_Id : Context_Id;
   begin
      Check_Validity (Main_Unit, Package_Name & "Compilation_Dependencies");

      if Arg_Kind not in A_Procedure .. A_Protected_Body_Subunit then
         Raise_ASIS_Inappropriate_Compilation_Unit
           (Diagnosis => Package_Name & "Compilation_Dependencies");
      end if;

      Res_Cont_Id := Encl_Cont_Id (Main_Unit);
      Reset_Context (Res_Cont_Id);
      Arg_Unit_Id := Get_Unit_Id  (Main_Unit);

      declare
         Result_Id_List : Unit_Id_List renames
            GNAT_Compilation_Dependencies (Res_Cont_Id, Arg_Unit_Id);

         Result_List : Compilation_Unit_List renames
             Get_Comp_Unit_List (Result_Id_List, Res_Cont_Id);
      begin
         if Is_Nil (Result_List) then
            Raise_ASIS_Inappropriate_Compilation_Unit
              (Diagnosis => Package_Name & "Compilation_Dependencies");
         else
            return Result_List;
         end if;

      end;

   exception
      when ASIS_Inappropriate_Compilation_Unit =>
         raise;
      when ASIS_Failed =>
         Add_Call_Information
           (Outer_Call => Package_Name & "Compilation_Dependencies");
         raise;
      when others =>
         Raise_ASIS_Failed
           (Diagnosis => Package_Name & "Compilation_Dependencies");

   end Compilation_Dependencies;

   ----------------
   -- Components --
   ----------------

   function Components (E : Asis.Element) return Asis.Element_List is
      Child_Access  : Query_Array  := Appropriate_Queries (E);
      Result_Length : Integer := 0;
   begin

      if Is_Nil (E) then
         return Nil_Element_List;
      end if;

      --  first, we compute the result's lenght:

      for Each_Query in Child_Access'Range loop
         case Child_Access (Each_Query).Query_Kind is
            when Bug =>
               null;
            when Single_Element_Query =>
               if not Is_Nil (Child_Access (Each_Query).Func_Simple (E)) then
                  Result_Length := Result_Length + 1;
               end if;
            when Element_List_Query =>
               declare
                  Child_List : Asis.Element_List :=
                     Child_Access (Each_Query).Func_List (E);
               begin
                  Result_Length := Result_Length + Child_List'Length;
               end;
            when Element_List_Query_With_Boolean =>
               declare
                  Child_List : Asis.Element_List :=
                     Child_Access (Each_Query).Func_List_Boolean
                        (E, Child_Access (Each_Query).Bool);
               begin
                  Result_Length := Result_Length + Child_List'Length;
               end;
         end case;
      end loop;

      --  and now, we define the result element list of Result_Length
      --  lemgth and fill it in by repeating the same loop. This is
      --  not effective, and this will have to be revised.

      if Result_Length = 0 then
         return Nil_Element_List;
      end if;

      declare
         Result_List : Asis.Element_List (1 .. Result_Length);
         Next_Element : Integer := 1;
      begin

         for Each_Query in Child_Access'Range loop
            case Child_Access (Each_Query).Query_Kind is
               when Bug =>
                  null;
               when Single_Element_Query =>
                  if not Is_Nil
                    (Child_Access (Each_Query).Func_Simple (E)) then
                     Result_List (Next_Element) :=
                        Child_Access (Each_Query).Func_Simple (E);
                     Next_Element := Next_Element + 1;
                  end if;
               when Element_List_Query =>
                  declare
                     Child_List : Asis.Element_List :=
                        Child_Access (Each_Query).Func_List (E);
                  begin
                     for I in Child_List'First .. Child_List'Last loop
                        Result_List (Next_Element) := Child_List (I);
                        Next_Element := Next_Element + 1;
                     end loop;
                  end;
               when Element_List_Query_With_Boolean =>
                  declare
                     Child_List : Asis.Element_List :=
                        Child_Access (Each_Query).Func_List_Boolean
                           (E, Child_Access (Each_Query).Bool);
                  begin
                     for I in Child_List'First .. Child_List'Last loop
                        Result_List (Next_Element) := Child_List (I);
                        Next_Element := Next_Element + 1;
                     end loop;
                  end;
            end case;
         end loop;
         return Result_List;
      end;
   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => E,
            Outer_Call => Package_Name & "Components");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument  => E,
            Diagnosis => Package_Name & "Components");
   end Components;

   -----------------------------------------------
   -- Corresponding_Body_Parameter_Definition --
   -----------------------------------------------

   function Corresponding_Body_Parameter_Definition
     (Defining_Name : in Asis.Defining_Name)
      return Asis.Defining_Name
   is
      Arg_Kind          : Internal_Element_Kinds := Int_Kind (Defining_Name);
      Encl_Constr       : Asis.Element;
      Encl_Constr_Kind  : Internal_Element_Kinds;

      Result            : Asis.Element := Nil_Element;

   begin
      if Arg_Kind /= A_Defining_Identifier then
         Raise_ASIS_Inappropriate_Element (Diagnosis =>
            Package_Name & "Corresponding_Body_Parameter_Definition");
      end if;

      Encl_Constr := Enclosing_Element (Enclosing_Element (Defining_Name));

      Encl_Constr_Kind := Int_Kind (Encl_Constr);

      case Encl_Constr_Kind is

         when A_Procedure_Body_Declaration |
              A_Function_Body_Declaration =>

            Result := Defining_Name;

         when A_Procedure_Body_Stub |
              A_Function_Body_Stub =>

            Encl_Constr := Corresponding_Subunit (Encl_Constr);

         when A_Procedure_Declaration        |
              A_Function_Declaration         |
              A_Generic_Function_Declaration |
              A_Generic_Procedure_Declaration =>

            Encl_Constr := Corresponding_Body (Encl_Constr);
            Encl_Constr_Kind := Int_Kind (Encl_Constr);

            if Encl_Constr_Kind = A_Procedure_Body_Stub or else
               Encl_Constr_Kind = A_Function_Body_Stub
            then
               Encl_Constr := Corresponding_Subunit (Encl_Constr);
            end if;

         when others =>
            --  For all the other situations we can not return a parameter
            --  definition in the body
            Encl_Constr := Nil_Element;
      end case;

      if not Is_Nil (Result) or else Is_Nil (Encl_Constr) then

         return Result;
      end if;

      Process_Parameter_Specifications : declare

         Def_Name_Image : String
            := To_Lower (To_String (Defining_Name_Image (Defining_Name)));

         Param_Specs : Asis.Element_List
            := Parameter_Profile (Encl_Constr);

      begin

         Through_Parameter_Specs : for I in Param_Specs'Range loop

            Process_Parameter_Names : declare
               Par_Names : Asis.Element_List := Names (Param_Specs (I));
            begin

               Through_Parameter_Names : for J in Par_Names'Range loop
                  if Def_Name_Image =
                     To_Lower (To_String (Defining_Name_Image
                       (Par_Names (J))))
                  then
                     Result := Par_Names (J);
                     exit Through_Parameter_Specs;
                  end if;

               end loop Through_Parameter_Names;

            end Process_Parameter_Names;

         end loop Through_Parameter_Specs;

      end Process_Parameter_Specifications;

      pragma Assert (not Is_Nil (Result));

      return Result;

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

   ------------------------------------------
   -- Corresponding_Called_Entity_Unwinded --
   ------------------------------------------

   function Corresponding_Called_Entity_Unwinded
     (Statement : in Asis.Statement)
      return Asis.Declaration
   is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
      Arg_Node : Node_Id;
      Arg_Node_Kind : Node_Kind;
      Result_Node   : Node_Id;
      Result_Unit   : Compilation_Unit;
      Res_Spec_Case : Special_Cases := Not_A_Special_Case;
   begin
      Check_Validity (Statement,
                     Package_Name & "Corresponding_Called_Entity_Unwinded");
      if not (Arg_Kind = An_Entry_Call_Statement or else
              Arg_Kind = A_Procedure_Call_Statement)
      then
         Raise_ASIS_Inappropriate_Element (Diagnosis =>
            Package_Name & "Corresponding_Called_Entity_Unwinded");
      end if;

      --  the implementation approach is similar to the approach taken for
      --  Asis.Expressions.Corresponding_Called_Function

      Arg_Node := R_Node (Statement);
      --  To be on the safe side, we use R_Node instead of Node, but it looks
      --  like in this case R_Node and Node should be the same
      Arg_Node_Kind := Nkind (Arg_Node);

      case Arg_Node_Kind is
         when  N_Attribute_Reference =>
            return Nil_Element;
            --  call to a procedure-attribute
         when  N_Entry_Call_Statement | N_Procedure_Call_Statement =>
            --  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;
--  ??? <tree problem 4>
--  this fragment should be revised when the problem is fixed (as it should)
            if Arg_Node_Kind = N_Entry_Call_Statement then
               Result_Node := Sinfo.Name (Arg_Node);
               --  Result_Node points to the name of the called entry
               if Nkind (Result_Node) = N_Indexed_Component then
                  --  this is the case for a call to an entry from an
                  --  entry family
                  Result_Node := Prefix (Result_Node);
               end if;
               Result_Node := Entity (Selector_Name (Result_Node));
            else
               Result_Node := Entity (Sinfo.Name (Arg_Node));
               --  only this assignment is needed if tree problem 4 is
               --  fixed
            end if;
--  ??? <tree problem 4>  - end
         when others =>
            pragma Assert (False);
            null;
      end case;

      Result_Node := Unwind_Renaming (Result_Node);

      if No (Result_Node) then
         --  renaming of a procedure-attribute
         return Nil_Element;
      end if;

      if not Comes_From_Source (Result_Node) then
         return Nil_Element;
      end if;

      Result_Unit := Enclosing_Unit (Encl_Cont_Id (Statement), Result_Node);

--      if not Is_Consistent (Result_Unit, Encl_Unit (Statement)) then
--         return Nil_Element;
--      end if;

      --  And now - fro m a defining name to a declaration itself
      Result_Node := Parent (Result_Node);
      if Arg_Node_Kind = N_Procedure_Call_Statement then
         Result_Node := Parent (Result_Node);
      end if;

      if Is_Expanded_Subprogram (Result_Node) then
         Res_Spec_Case := Expanded_Subprogram_Instantiation;
      end if;

      return Node_To_Element_New
        (Node      => Result_Node,
         Spec_Case => Res_Spec_Case,
         In_Unit   => Result_Unit);
   exception
      when Assert_Error : System.Assertions.Assert_Failure =>
         Raise_ASIS_Failed (
            Argument   => Statement,
            Diagnosis => LT & Package_Name
              & "Corresponding_Called_Entity_Unwinded - "  & LT
              & "Assert_Failure at "
              &  Ada.Exceptions.Exception_Message (Assert_Error));
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Statement,
            Outer_Call =>
               Package_Name & "Corresponding_Called_Entity_Unwinded");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument   => Statement,
            Diagnosis =>
               Package_Name & "Corresponding_Called_Entity_Unwinded");
   end Corresponding_Called_Entity_Unwinded;

   --------------------------------------------
   -- Corresponding_Called_Function_Unwinded --
   --------------------------------------------

   function Corresponding_Called_Function_Unwinded
     (Expression : in Asis.Expression)
      return Asis.Declaration
   is
      Arg_Kind      : Internal_Element_Kinds := Int_Kind (Expression);
      Arg_Node      : Node_Id;
      Arg_Node_Kind : Node_Kind;
      Result_Node   : Node_Id;
      Result_Unit   : Compilation_Unit;
      Res_Spec_Case : Special_Cases := Not_A_Special_Case;
   begin
      Check_Validity (Expression,
          Package_Name & "Corresponding_Called_Function_Unwinded");

      if not (Arg_Kind = A_Function_Call) then
         Raise_ASIS_Inappropriate_Element (Diagnosis =>
            Package_Name & "Corresponding_Called_Function_Unwinded");
      end if;

      --  first, we have to filter out the cases when a Nil_Element
      --  should be returned. For now, these cases include:
      --
      --  - calls to functions-attributes;
      --  - all forms of calls to predefined operators;
      --  - all forms of calls to inherited functions
      --
      --  We hope to implement the last case in future...

      --  First, we try the simplest approach, and then we will add patchs
      --  if needed:

      Arg_Node      := R_Node (Expression);
      Arg_Node_Kind := Nkind (Arg_Node);
      --  Rewritten node should know everything. But if this node is the
      --  result of compile-time optimisation, 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_Identifier
      then
         Arg_Node      := Node (Expression);
         Arg_Node_Kind := Nkind (Arg_Node);
      end if;

      case Arg_Node_Kind is
         when  N_Attribute_Reference =>
            return Nil_Element;
         when  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;
            else
               Result_Node := Entity (Sinfo.Name (Arg_Node));
            end if;
         when N_Op =>
            --  all the predefined operations (??)
            Result_Node := Entity (Arg_Node);
         when others =>
            pragma Assert (False);
            null;
      end case;

      --  here we have Result_Node pointed to the defininhg occurence of
      --  the corresponding caled function. Three things should be done:
      --  1. If Result_Node is defined in a renaming definition, we have
      --     to unwind all the renamings till the defining occurence of
      --     the corresponding callable entity will be riched;
      --  2. If a given callable entity is implicitly defined, Nil_Element
      --     should be returned;
      --  3. We have to come from a definng name to the correcponding
      --     declaration and then we should return the Element
      --     corresponding to this declaration

      Result_Node := Unwind_Renaming (Result_Node);

      if No (Result_Node) then
         --  renaming of a function-attribute
         return Nil_Element;
      end if;

      --  here we have Result_Node pointing to the defining occurence of the
      --  name of the corresponding called function. First, we have to
      --  filter out implicitly declared functions:

      if not Comes_From_Source (Result_Node) then
         return Nil_Element;
      end if;

      Result_Unit := Enclosing_Unit (Encl_Cont_Id (Expression), Result_Node);

--      if not Is_Consistent (Result_Unit, Encl_Unit (Expression)) then
--         return Nil_Element;
--      end if;

      Result_Node := Parent (Parent (Result_Node));
      --  to go from a defining name to a declaration itself

      if Is_Expanded_Subprogram (Result_Node) then
         Res_Spec_Case := Expanded_Subprogram_Instantiation;
      end if;

      return Node_To_Element_New
        (Node      => Result_Node,
         Spec_Case => Res_Spec_Case,
         In_Unit   => Result_Unit);

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

   ------------------------------------
   -- Corresponding_First_Definition --
   ------------------------------------

   function Corresponding_First_Definition
     (Defining_Name : in Asis.Defining_Name)
      return Asis.Defining_Name
   is
      Arg_Kind          : Internal_Element_Kinds := Int_Kind (Defining_Name);
      Is_Parameter      : Boolean := False;
      Encl_Constr       : Asis.Element;
      Encl_Constr_Kind  : Internal_Element_Kinds;
      First_Declaration : Asis.Element;

      Result            : Asis.Element := Nil_Element;

   begin
      if Arg_Kind not in Internal_Defining_Name_Kinds then
         Raise_ASIS_Inappropriate_Element (Diagnosis =>
            Package_Name & "Corresponding_First_Definition");
      end if;

      Encl_Constr := Enclosing_Element (Defining_Name);

      if Int_Kind (Encl_Constr) = A_Parameter_Specification then
         Encl_Constr := Enclosing_Element (Encl_Constr);
         Is_Parameter := True;
      end if;

      Encl_Constr_Kind := Int_Kind (Encl_Constr);

      case Encl_Constr_Kind is

         when A_Procedure_Body_Declaration     |
              A_Function_Body_Declaration      |
              A_Function_Renaming_Declaration  |
              A_Procedure_Renaming_Declaration |
              A_Procedure_Body_Stub            |
              A_Function_Body_Stub               =>

            if ((Encl_Constr_Kind = A_Procedure_Body_Declaration  or else
                 Encl_Constr_Kind = A_Function_Body_Declaration   or else
                 Encl_Constr_Kind = A_Procedure_Body_Stub         or else
                 Encl_Constr_Kind = A_Function_Body_Stub)
                and then (not (Acts_As_Spec (Encl_Constr))))
              or else
               ((Encl_Constr_Kind = A_Function_Renaming_Declaration or else
                 Encl_Constr_Kind = A_Procedure_Renaming_Declaration)
                 and then Is_Renaming_As_Body (Encl_Constr))
            then
               --  there should be a corresponding spec where the first
               --  definition should be:

               if Is_Subunit (Encl_Constr) then
                  Encl_Constr := Corresponding_Body_Stub (Encl_Constr);
               end if;

               First_Declaration := Corresponding_Declaration (Encl_Constr);

               if not Is_Parameter then
                  --  just returning a defining name from a declaration,
                  --  otherwise Result will remain nil, and we will have
                  --  to process the case of a formal parameter after this
                  --  case statement
                  Result := Names (First_Declaration) (1);
               end if;
            else
               Result := Defining_Name;
            end if;

         when A_Package_Body_Declaration      |
              A_Task_Body_Declaration         |
              A_Protected_Body_Declaration    |
              A_Package_Body_Stub             |
              A_Task_Body_Stub                |
              A_Protected_Body_Stub           |
              An_Entry_Body_Declaration       =>

            First_Declaration := Corresponding_Declaration (Encl_Constr);

            if not Is_Parameter then
               Result := Names (First_Declaration) (1);
            end if;

         when An_Accept_Statement =>

            First_Declaration := Corresponding_Entry (Encl_Constr);

         when An_Ordinary_Type_Declaration =>
            Result := Corresponding_Type_Declaration (Encl_Constr);

            if Is_Nil (Result) then
               --  Encl_Constr is not a completion of an incomplete or
               --  private type declaration
               Result := Defining_Name;
            else
               Result := Names (Result) (1);
            end if;

         when others =>
            Result := Defining_Name;
      end case;

      if Is_Nil (Result) then
         --  here we have to compute the first definition of the formal
         --  parameter in a subprogram spec/entry declaration

         Process_Parameter_Specifications : declare

            Def_Name_Image : String
               := To_Lower (To_String (Defining_Name_Image (Defining_Name)));

            Param_Specs : Asis.Element_List
               := Parameter_Profile (First_Declaration);

         begin

            Through_Parameter_Specs : for I in Param_Specs'Range loop

               Process_Parameter_Names : declare
                  Par_Names : Asis.Element_List := Names (Param_Specs (I));
               begin

                  Through_Parameter_Names : for J in Par_Names'Range loop
                     if Def_Name_Image =
                        To_Lower (To_String (Defining_Name_Image
                          (Par_Names (J))))
                     then
                        Result := Par_Names (J);
                        exit Through_Parameter_Specs;
                     end if;

                  end loop Through_Parameter_Names;

               end Process_Parameter_Names;

            end loop Through_Parameter_Specs;

         end Process_Parameter_Specifications;
      end if;

      pragma Assert (not Is_Nil (Result));

      return Result;

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

   -------------------------------
   -- Element_Image_In_Template --
   -------------------------------

   function Element_Image_In_Template
     (Element : in Asis.Element)
      return Program_Text
   is
      Tmp_Element : Asis.Element := Element;
   begin

      if Is_Part_Of_Implicit (Element) or else
         not Is_Part_Of_Instance (Element)
      then
         return "";
      else
         --  What we are doing is tricky, but it gives the fast and
         --  easy-to-maintain solution: we consider the argument as if it is
         --  NOT from the expanded template, and we use the normal ASIS
         --  Element_Span function for it. The idea is to use Sloc fields
         --  from the element node which point to the corresponding positions
         --  in the template.
         Set_From_Instance (Tmp_Element, False);
         return Element_Image (Tmp_Element);
      end if;

   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Element,
            Outer_Call => Package_Name & "Element_Image_In_Template");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument   => Element,
            Diagnosis =>  Package_Name & "Element_Image_In_Template");
   end Element_Image_In_Template;

   ------------------------------
   -- Element_Span_In_Template --
   ------------------------------

   function Element_Span_In_Template
     (Element : in Asis.Element)
      return Asis.Text.Span
   is
      Tmp_Element : Asis.Element := Element;
   begin

      if Is_Part_Of_Implicit (Element) or else
         not Is_Part_Of_Instance (Element)
      then
         return Nil_Span;
      else
         --  What we are doing is tricky, but it gives the fast and
         --  easy-to-maintain solution: we consider the argument as if it is
         --  NOT from the expanded template, and we use the normal ASIS
         --  Element_Span function for it. The idea is to use Sloc fields
         --  from the element node which point to the corresponding positions
         --  in the template.
         Set_From_Instance (Tmp_Element, False);
         return Element_Span (Tmp_Element);
      end if;

   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Element,
            Outer_Call => Package_Name & "Element_Span_In_Template");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument   => Element,
            Diagnosis =>  Package_Name & "Element_Span_In_Template");
   end Element_Span_In_Template;

   -------------------------------
   -- Formal_Subprogram_Default --
   -------------------------------

   function Formal_Subprogram_Default
     (Declaration : in Asis.Generic_Formal_Parameter)
      return Asis.Expression
   is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
      Arg_Node : Node_Id;
   begin
      Arg_Node := Node (Declaration);

      Check_Validity (Declaration, Package_Name & "Formal_Subprogram_Default");

      if not (Arg_Kind = A_Formal_Procedure_Declaration or else
              Arg_Kind = A_Formal_Function_Declaration)
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Formal_Subprogram_Default");
      end if;

      if not Present (Default_Name (Arg_Node)) then
         return Nil_Element;
      end if;

      return Node_To_Element (Node    => Default_Name (Arg_Node),
                              In_Unit => Encl_Unit (Declaration));
   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => Declaration,
            Outer_Call => Package_Name & "Formal_Subprogram_Default");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument   => Declaration,
            Diagnosis => Package_Name & "Formal_Subprogram_Default");
   end Formal_Subprogram_Default;

   ------------------------
   -- Get_Last_Component --
   ------------------------

   function Get_Last_Component (E : Asis.Element) return Asis.Element is
      Child_Access : Query_Array  := Appropriate_Queries (E);
      Child        : Asis.Element := Asis.Nil_Element;
   begin

      if Debug_Flag_X then
         Write_Str ("   Get_Last_Component - called for ");
         Write_Str (Internal_Element_Kinds'Image (Int_Kind (E)));
         Write_Eol;
      end if;

      for Each_Query in reverse Child_Access'Range loop
         case Child_Access (Each_Query).Query_Kind is
            when Bug =>
               null;
            when Single_Element_Query =>
               Child := Child_Access (Each_Query).Func_Simple (E);
            when Element_List_Query =>
               declare
                  Child_List : Asis.Element_List :=
                     Child_Access (Each_Query).Func_List (E);
               begin
                  if not Is_Nil (Child_List) then
                     Child := Child_List (Child_List'Last);
                  end if;
               end;
            when Element_List_Query_With_Boolean =>
               declare
                  Child_List : Asis.Element_List :=
                     Child_Access (Each_Query).Func_List_Boolean
                        (E, Child_Access (Each_Query).Bool);
               begin
                  if not Is_Nil (Child_List) then
                     Child := Child_List (Child_List'Last);
                  end if;
               end;
         end case;

         exit when not Is_Nil (Child);

      end loop;

      if Debug_Flag_X then
         Write_Str ("   Get_Last_Component - returns ");
         Write_Str (Internal_Element_Kinds'Image (Int_Kind (Child)));
         Write_Eol;
      end if;
      return Child;
   exception
      when ASIS_Failed =>
         Add_Call_Information (
            Argument   => E,
            Outer_Call => Package_Name & "Get_Last_Component");
         raise;
      when others =>
         Raise_ASIS_Failed (
            Argument   => E,
            Diagnosis => Package_Name & "Get_Last_Component");
   end Get_Last_Component;

   ------------------
   -- Is_Completed --
   ------------------

   function Is_Completed (Declaration : Asis.Element) return Boolean
   is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
      Arg_Node : Node_Id;
      Result   : Boolean := False;
   begin
      --  JUNK IMPLEMENTATION!!!
      if not (Arg_Kind = A_Procedure_Declaration or else
              Arg_Kind = A_Function_Declaration)
        or else
          Is_Part_Of_Inherited (Declaration)
      then
         return False;
      end if;

      Arg_Node := Defining_Unit_Name (Specification (Node (Declaration)));

      Result := Has_Completion (Arg_Node);

      return Result;

   end Is_Completed;

   ----------------------------
   -- Is_Expanded_Subprogram --
   ----------------------------

   function Is_Expanded_Subprogram (N : Node_Id) return Boolean is
      Result : Boolean := False;
   begin
      if Nkind (N) = N_Subprogram_Declaration and then
         Is_Generic_Instance (Defining_Unit_Name (Specification (N)))
      then
         Result := True;
      end if;

      return Result;
   end Is_Expanded_Subprogram;

   --------------------------
   -- Is_Main_Unit_In_Tree --
   --------------------------

   function Is_Main_Unit_In_Tree
     (Right : Asis.Compilation_Unit)
      return Boolean
   is
      Arg_Kind     : Unit_Kinds := Kind (Right);
      Arg_Unit_Id  : Unit_Id;
      Arg_Cont_Id  : Context_Id;
   begin

      Check_Validity (Right, Package_Name & "Is_Main_Unit_In_Tree");

      Arg_Cont_Id := Encl_Cont_Id (Right);
      Reset_Context (Arg_Cont_Id);

      Arg_Unit_Id := Get_Unit_Id  (Right);

      if Arg_Kind in A_Procedure .. A_Protected_Body_Subunit then

         return GNAT_Compilation_Dependencies (Arg_Cont_Id, Arg_Unit_Id) /=
                Nil_Unit_Id_List;

      else
         return False;
      end if;

   end Is_Main_Unit_In_Tree;

   -----------------
   -- Is_Obsolete --
   -----------------

   function Is_Obsolete (Right : Asis.Compilation_Unit) return Boolean
   is
      Arg_Kind : Unit_Kinds := Kind (Right);
      Arg_Id   : Unit_Id;
      Result   : Boolean := True;
   begin
      case Arg_Kind is
         when Not_A_Unit                |
              A_Nonexistent_Declaration |
              A_Nonexistent_Body        |
              An_Unknown_Unit =>

            Result := Result;
         when others =>
            Arg_Id := Get_Unit_Id (Right);

            if Arg_Id = Standard_Id then
               Result := False;
            else
               Result := not (Source_Status (Right) = Up_To_Date);
            end if;

      end case;

      return Result;

   end Is_Obsolete;

   ----------------------------
   -- Is_Primitive_Operation --
   ----------------------------

   function Is_Primitive_Operation
     (Declaration : Asis.Element)
      return Boolean
   is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
   begin

      --  ??? NOT IMPLEMENTED

      if not (Arg_Kind = A_Procedure_Declaration   or else
              Arg_Kind = A_Function_Declaration    or else
              Arg_Kind = A_Procedure_Renaming_Declaration or else
              Arg_Kind = A_Function_Renaming_Declaration)
      then
         return False;
      end if;

      Not_Implemented_Yet
        (Diagnosis => Package_Name & "Is_Primitive_Operation");

   end Is_Primitive_Operation;

   -------------------------
   -- Is_Renaming_As_Body --
   -------------------------

   function Is_Renaming_As_Body (Declaration : Asis.Element) return Boolean is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
      Arg_Node : Node_Id;
   begin
      if not (Arg_Kind = A_Procedure_Renaming_Declaration or else
              Arg_Kind = A_Function_Renaming_Declaration)
      then
         return False;
      end if;

      Arg_Node := Node (Declaration);
      return Present (Corresponding_Spec (Arg_Node));
   end Is_Renaming_As_Body;

   ---------------
   -- Is_Static --
   ---------------

   function Is_Static (Expression : Asis.Expression) return Boolean is
      Result : Boolean := False;
   begin
      if Is_True_Expression (Expression) then
         Result := Sinfo.Is_Static_Expression (R_Node (Expression));
      end if;

      return Result;
   end Is_Static;

   ------------------------
   -- Is_True_Expression --
   ------------------------

   function Is_True_Expression
     (Expression : Asis.Expression)
      return Boolean
   is
      Arg_Node    : Node_Id                := Node   (Expression);
      Arg_Kind    : Internal_Element_Kinds := Int_Kind (Expression);
      Expr_Chars  : Name_Id;
      Entity_Node : Entity_Id;

      Result      : Boolean                := True;
      --  the idea of the implementation is to find out the cases when
      --  Expression is NOT a true exception, so we initialize Result
      --  as True
   begin

      if Arg_Kind not in Internal_Expression_Kinds then
         return False;
      end if;

      if Nkind (Arg_Node) not in N_Has_Etype                or else
         No (Etype (Arg_Node))                              or else
         Ekind (Etype (Arg_Node)) = E_Anonymous_Access_Type or else
         Ekind (Etype (Arg_Node)) = E_Subprogram_Type
      then
         --  Expression may be a true expression, but it may have a type which
         --  cannot be represented in ASIS (such as an anonymous access type),
         --  in such cases we also classify it as being not true expression
         Result := False;

      else
         --  in some cases more detailed analysis is required.
         --  ???  This part may require some more analysis - it may be
         --  somewhat redundant

         case Arg_Kind is
            when An_Identifier | A_Selected_Component =>
               --  and here we have to investigate whether or not this
               --  Expression is a "naming expression"

               if Nkind (Arg_Node) = N_Identifier             and then
                  Nkind (Parent (Arg_Node)) = N_Expanded_Name and then
                  Arg_Node = Selector_Name (Parent (Arg_Node))
               then
                  --  selector in an expanded name - all the semantic fields
                  --  are set for the whole name, but not for this selector.
                  --  So:
                  Arg_Node := Parent (Arg_Node);
               end if;

--  ??? <tree problem 1>
--  this fragment should be revised when the problem is fixed (as it should)
               if Nkind (Arg_Node) = N_Selected_Component and then
                  Etype (Arg_Node) = Any_Type
                  --  for now (GNAT 3.05) this means, that Expression is an
                  --  expanded name of the character literal of ether a
                  --  predefined character type or of the type derived from a
                  --  predefined character type; the problem is that the
                  --  Entity field is not set for such a node
               then
                  return True;
               end if;
--  ??? <tree problem 1> - end

               --  now taking the Entity field (if any) and looking,
               --  what we have:

               if Nkind (Arg_Node) = N_Selected_Component then
                  Entity_Node := Entity (Selector_Name (Arg_Node));
               elsif Nkind (Arg_Node) = N_Attribute_Definition_Clause then
                  --  the attribute designator in an attribute definition
                  --  clause
                  Entity_Node := Empty;
               else
                  Entity_Node := Entity (Arg_Node);
               end if;

               if No (Entity_Node) then
                  Result := False;
               elsif Ekind (Entity_Node) = E_Enumeration_Literal then
                  null;
               else
                  case Ekind (Entity_Node) is
                     --  the first choice in this case statement should
                     --  filter in entities which *ARE* expressions in Ada
                     --  sense
                     when E_Variable =>
                        --  tasks and protected objects declared by _single_
                        --  task/protected declarations do not have
                        --  corresponding type declarations which can be
                        --  represented in ASIS
                        Result := Comes_From_Source (Parent (Entity_Node));
                     when E_Component .. E_Named_Real |
                        --  variables and constants (including formal
                        --  parameters and generic formal parameters
                        E_Enumeration_Literal |  --  ??? (see elsif path)
                        --  enumeration literals are not treated as functions
                        --  in ASIS
                        E_Entry_Index_Parameter |
                        E_Protected_Object =>
                        null;
                        --  simply keeping the initialization of Result
                     when others =>
                        Result := False;
                  end case;
               end if;

            when Internal_Operator_Symbol_Kinds =>
               Result := False;
            when Internal_Attribute_Reference_Kinds =>

               case Internal_Attribute_Reference_Kinds (Arg_Kind) is
                  when An_Adjacent_Attribute          |
                       A_Base_Attribute               |
                       A_Ceiling_Attribute            |
                       A_Class_Attribute              |
                       A_Compose_Attribute            |
                       A_Copy_Sign_Attribute          |
                       An_Exponent_Attribute          |
                       A_Floor_Attribute              |
                       A_Fraction_Attribute           |
                       An_Image_Attribute             |
                       An_Input_Attribute             |
                       A_Leading_Part_Attribute       |
                       A_Machine_Attribute            |
                       A_Max_Attribute                |
                       A_Min_Attribute                |
                       A_Model_Attribute              |
                       An_Output_Attribute            |
                       A_Pos_Attribute                |
                       A_Pred_Attribute               |
                       A_Range_Attribute              |
                       A_Read_Attribute               |
                       A_Remainder_Attribute          |
                       A_Round_Attribute              |
                       A_Rounding_Attribute           |
                       A_Scaling_Attribute            |
                       A_Succ_Attribute               |
                       A_Truncation_Attribute         |
                       An_Unbiased_Rounding_Attribute |
                       A_Val_Attribute                |
                       A_Value_Attribute              |
                       A_Wide_Image_Attribute         |
                       A_Wide_Value_Attribute         |
                       A_Write_Attribute              =>

                     Result := False;
                  when An_Implementation_Defined_Attribute =>
                     Expr_Chars := Attribute_Name (Arg_Node);
                     if Expr_Chars = Name_Abort_Signal or else
                        Expr_Chars = Name_Elab_Body    or else
                        Expr_Chars = Name_Elab_Spec
                     then
                        Result := False;
                     end if;
                  when others =>
                     null;
               end case;

            when A_Positional_Array_Aggregate | A_Named_Array_Aggregate =>

               if Nkind (Parent (Arg_Node)) =
                     N_Enumeration_Representation_Clause
                 or else
                  Is_Typeless_Subaggregate (Arg_Node)
               then
                  Result := False;
               end if;

            when others =>
               null;
         end case;

      end if;

      return Result;

   exception
      when others =>
         Raise_ASIS_Failed (
            Argument  => Expression,
            Diagnosis => "A4G.Expr_Sem.Is_True_Expression");
   end Is_True_Expression;

   ------------------------------
   -- Is_Typeless_Subaggregate --
   ------------------------------

   function Is_Typeless_Subaggregate (Aggr : Node_Id) return Boolean is
      Parent_Node : Node_Id := Parent (Aggr);
      Result      : Boolean := False;
   begin

      if Nkind (Parent_Node) = N_Component_Association then
         Parent_Node := Parent (Parent_Node);
      end if;

      if Nkind (Parent_Node) = N_Aggregate then

         if No (Etype (Parent_Node)) or else
            Ekind (Etype (Parent_Node)) = E_Array_Subtype
         then
            Result := True;
         end if;

      end if;

      return Result;

   end Is_Typeless_Subaggregate;

   -----------
   -- No_Op --
   -----------

   procedure No_Op
     (Element : in     Asis.Element;
      Control : in out Traverse_Control;
      State   : in out No_State)
   is
   begin
      null;
   end No_Op;

   -------------------
   -- Primary_Owner --
   -------------------

   function Primary_Owner
     (Declaration : Asis.Declaration)
      return Asis.Declaration
   is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
   begin

      if not (Arg_Kind = A_Procedure_Declaration          or else
              Arg_Kind = A_Function_Declaration           or else
              Arg_Kind = A_Procedure_Renaming_Declaration or else
              Arg_Kind = A_Function_Renaming_Declaration)
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Primary_Owner");
      end if;

      return Nil_Element;

      Not_Implemented_Yet
        (Diagnosis => Package_Name & "Primary_Owner");

--   exception
--      when ASIS_Failed =>
--         Add_Call_Information (
--            Argument   => E,
--            Outer_Call => Package_Name & "Primary_Owner");
--         raise;
--      when others =>
--         Raise_ASIS_Failed (
--            Argument   => E,
--            Diagnosis => Package_Name & "Primary_Owner");
   end Primary_Owner;

   ------------------------
   -- Source_File_Status --
   ------------------------

   function Source_File_Status
     (Right : Asis.Compilation_Unit)
      return Source_File_Statuses
   is
      Arg_Kind : Unit_Kinds := Kind (Right);
      Result   : Source_File_Statuses;
   begin
      case Arg_Kind is
         when Not_A_Unit                |
              A_Nonexistent_Declaration |
              A_Nonexistent_Body        |
              An_Unknown_Unit =>

            Result := Absent;
         when others =>
            Result := Source_Status (Right);
      end case;

      return Result;

   end Source_File_Status;

   -------------------
   -- Traverse_Unit --
   -------------------

   procedure Traverse_Unit
     (Unit    : in     Asis.Compilation_Unit;
      Control : in out Traverse_Control;
      State   : in out State_Information)
   is
      Arg_Kind : Unit_Kinds := Unit_Kind (Unit);

      procedure Process_Element is new Asis.Iterator.Traverse_Element
        (State_Information => State_Information,
         Pre_Operation     => Pre_Operation,
         Post_Operation    => Post_Operation);

   begin

      if not (Arg_Kind in A_Procedure .. A_Protected_Body_Subunit) then
         Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
            Package_Name & "Traverse_Unit");
      end if;

      declare
         Cont_Clause_Elements : Element_List :=
            Asis.Elements.Context_Clause_Elements
              (Compilation_Unit => Unit,
               Include_Pragmas  => True);

         Unit_Element : Asis.Element := Asis.Elements.Unit_Declaration (Unit);

      begin

         for I in Cont_Clause_Elements'Range loop
            Process_Element (Cont_Clause_Elements (I), Control, State);
         end loop;

         Process_Element (Unit_Element, Control, State);
      end;

   exception
      when ASIS_Inappropriate_Compilation_Unit =>
         raise;

      when ASIS_Inappropriate_Context     |
           ASIS_Inappropriate_Container   |
           ASIS_Inappropriate_Element     |
           ASIS_Inappropriate_Line        |
           ASIS_Inappropriate_Line_Number |
           ASIS_Failed
         =>
         Add_Call_Information (Outer_Call => Package_Name & "Traverse_Unit");
         raise;

      when Storage_Error =>
         Raise_ASIS_Failed (Diagnosis => Package_Name & "Traverse_Unit");
      when others =>
         Raise_ASIS_Failed (Diagnosis => Package_Name & "Traverse_Unit");
   end Traverse_Unit;

end Asis.Extensions