-------------------------------------------------------------------------------
--
--  This file is part of AdaBrowse.
--
-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG>
-- <BLOCKQUOTE>
--    AdaBrowse is free software; you can redistribute it and/or modify it
--    under the terms of the  GNU General Public License as published by the
--    Free Software  Foundation; either version 2, or (at your option) any
--    later version. AdaBrowse is distributed in the hope that it will be
--    useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
-- </BLOCKQUOTE>
--
-- <DL><DT><STRONG>
-- Author:</STRONG><DD>
--   Thomas Wolf  (TW)
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
--
-- <DL><DT><STRONG>
-- Purpose:</STRONG><DD>
--   Complex ASIS queries.</DL>
--
-- <!--
-- Revision History
--
--   02-FEB-2002   TW  First release.
--   05-FEB-2002   TW  Added handling of subprogram renamings in
--                     'Primitive_Operations'.
--   02-MAR-2002   TW  Correction (parameter 'Handled' in 'Get_Primitive_Ops')
--                     to avoid handling types derived from Natural etc.
--                     ASIS-for-GNAT 3.14p doesn't give us the predefined ops,
--                     so it doesn't work as it should for these types.
--   04-MAR-2002   TW  Correction in 'Primitive_Operations': use first subtypes
--                     for type comparisons!
--                        Also added 'Full_Unit_Name'.
--   21-MAR-2002   TW  Corrected 'Type_Of': we need to explicitly maintain
--                     attributes like 'Class, 'Base, or 'Range, for which
--                     ASIS-for-GNAT 3.14p (and maybe other ASIS
--                     implementations, too) returns a Nil_Element because
--                     there is no declaration.
--   27-AUG-2002   TW  Added 'Real_Declaration' to find the explicit
--                     declarations of implicitly inherited enumeration
--                     literals.
--                       'Expand_Generic' loops now until the found element is
--                     not part of an instance anymore. This should handle
--                     nested generics properly.
--   22-NOV-2002   TW  New operation 'Container_Name'.
--   04-JUN-2003   TW  New operations 'Has_Private', 'Visible_Items' and.
--                     'Private_Items'.
--   05-JUN-2003   TW  Changed 'Enclosing_Declaration' such that it works
--                     for any element, not just defining names.
--   06-JUN-2003   TW  'Verify_Defining_Name', 'Name_Definition_Image', and
--                     'Name_Expression_Image' are new.
--                        Also changed 'Full_Unit_Name' to construct the unit
--                     name from scratch to get consistent casing.
--                        Moved 'Set_Standard_Units' and 'Crossref_To_Unit'
--                     to AD.Crossrefs.
--   08-JUL-2003   TW  New operation 'Fully_Qualified_Name'; change in function
--                     'Name_Expression_Image' to also handle attribute
--                     references.
--   18-JUL-2003   TW  Moved most operations to the @Asis2@ library.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Unchecked_Deallocation;

with Asis;
with Asis.Compilation_Units.Relations;
with Asis.Definitions;
with Asis.Declarations;
with Asis.Elements;
with Asis.Expressions;

with Asis2.Declarations;
with Asis2.Naming;
with Asis2.Text;

with AD.Text_Utilities;

with GAL.Containers.Hash_Tables;
with GAL.Storage.Standard;
with GAL.Support.Hashing;

pragma Elaborate_All (GAL.Containers.Hash_Tables);

package body AD.Queries is

   package A_D   renames Asis.Declarations;
   package A_DEF renames Asis.Definitions;

   use Asis;
   use Asis.Definitions;
   use Asis.Declarations;
   use Asis.Elements;
   use Asis.Expressions;

   type Op_Ptr is access all Operation_List;

   procedure Free is
      new Ada.Unchecked_Deallocation (Operation_List, Op_Ptr);

   type Type_Attribute is (Base_Attr, Class_Attr, Range_Attr);
   --  Possible combinations:
   --  'Range'Base, 'Base'Range, 'Class, 'Base'Class (?)

   type Attribute_Set is array (Type_Attribute) of Boolean;
   pragma Pack (Attribute_Set);

   No_Attributes : constant Attribute_Set := (others => False);

   type Type_Descriptor is
      record
         Decl  : Asis.Declaration;
         Attrs : Attribute_Set;
      end record;

   No_Type : constant Type_Descriptor := (Nil_Element, No_Attributes);

   function Type_Of
     (Element : in Asis.Expression)
     return Type_Descriptor
   is
      --  Asis sometimes works ok with Corresponding_Name_Declaration, but
      --  in some other cases (e.g. for parameter types), it sometimes fails.
      --    Note that Asis doesn't seem to have a way to determine whether
      --  a particular type is a class-wide type! If 'Class_Wide_To_Specific'
      --  is True, we return in such cases the corresponding specific type,
      --  otherwise, we return a Nil_Element ('Corresponding_Expression_Type'
      --  is defined to return a Nil_Element for class-wide types).
      Result : Type_Descriptor := No_Type;
   begin
      case Expression_Kind (Element) is
         when A_Selected_Component =>
            Result.Decl := Corresponding_Name_Declaration (Selector (Element));

         when An_Identifier =>
            Result.Decl := Corresponding_Name_Declaration (Element);

         when An_Attribute_Reference =>
            case Attribute_Kind (Element) is
               when A_Class_Attribute =>
                  Result := Type_Of (Prefix (Element));
                  Result.Attrs (Class_Attr) := True;
               when A_Base_Attribute =>
                  Result := Type_Of (Prefix (Element));
                  Result.Attrs (Base_Attr) := True;
               when A_Range_Attribute =>
                  Result := Type_Of (Prefix (Element));
                  Result.Attrs (Range_Attr) := True;
               when others =>
                  Result.Decl := Corresponding_Expression_Type (Element);
            end case;

         when others =>
            Result.Decl := Corresponding_Expression_Type (Element);

      end case;
      return Result;
   exception
      when others =>
         return No_Type;
   end Type_Of;

   function First_Subtype
     (The_Type : in Type_Descriptor)
     return Type_Descriptor
   is
   begin
      if not Is_Nil (The_Type.Decl) and then
         The_Type.Attrs = No_Attributes
      then
         return (Corresponding_First_Subtype (The_Type.Decl), No_Attributes);
      else
         return The_Type;
      end if;
   end First_Subtype;

   function Ancestor_Type
     (The_Type : in Declaration)
     return Declaration
   is
      --  Return the ancestor type (if any) of the type declared by the given
      --  declaration. Returns a Nil_Element if the type has no ancestor.

      Def : constant Definition := Type_Declaration_View (The_Type);

   begin --  Ancestor_Type
      case Definition_Kind (Def) is
         when A_Subtype_Indication =>
            --  Can happen in generic instantiations, for the actual parameter
            --  of a formal derived type definition.
            return Type_Of (A_DEF.Subtype_Mark (Def)).Decl;

         when A_Private_Extension_Definition =>
            return
              Type_Of (A_DEF.Subtype_Mark
                         (Ancestor_Subtype_Indication (Def))).Decl;

         when A_Formal_Type_Definition =>
            if Formal_Type_Kind (Def) = A_Formal_Derived_Type_Definition then
               return Type_Of (A_DEF.Subtype_Mark (Def)).Decl;
            end if;

         when A_Type_Definition =>
            case Type_Kind (Def) is
               when A_Derived_Type_Definition |
                    A_Derived_Record_Extension_Definition =>
                  return Corresponding_Parent_Subtype (Def);
               when others =>
                  null;
            end case;

         when others =>
            null;

      end case;
      return Nil_Element;
   end Ancestor_Type;

   function Is_Ancestor
     (Ancestor : in Declaration;
      Child    : in Declaration)
     return Boolean
   is
      --  Return True if 'Child' is derived directly or indirectly from
      --  'Ancestor'.

   begin --  Is_Ancestor
      if Is_Nil (Child)             then return False; end if;
      if Is_Equal (Ancestor, Child) then return True;  end if;
      return Is_Ancestor (Ancestor, Ancestor_Type (Child));
   end Is_Ancestor;

   function Is_Tagged
     (The_Type : in Declaration)
     return Boolean
   is
      Def : constant Definition := Type_Declaration_View (The_Type);
   begin
      case Definition_Kind (Def) is
         when A_Subtype_Indication =>
            return Is_Tagged (Corresponding_First_Subtype (The_Type));

         when A_Private_Extension_Definition |
              A_Tagged_Private_Type_Definition =>
            return True;

         when A_Type_Definition =>
            case Type_Kind (Def) is
               when A_Derived_Record_Extension_Definition |
                    A_Tagged_Record_Type_Definition =>
                  return True;

               when others =>
                  null;

            end case;

         when others =>
            null;

      end case;
      return False;
   end Is_Tagged;

   function Is_Primitive
     (Decl     : in Declaration;
      The_Type : in Declaration)
     return Boolean
   is
      --  'Decl' is the declaration of a function or procedure. Returns
      --  True if it is a primitive operation of 'The_Type'.
      --
      --  Must have a parameter or a return type that equals 'The_Type'.

      Kind : constant Declaration_Kinds := Declaration_Kind (Decl);
   begin
      if (Kind = A_Function_Renaming_Declaration or else
          Kind = A_Procedure_Renaming_Declaration)
         and then
         Is_Tagged (The_Type) and then
         not Is_Dispatching_Operation (Decl)
      then
         return False;
      end if;
      if Kind = A_Function_Declaration or else
         Kind = A_Function_Renaming_Declaration
      then
         declare
            T : constant Type_Descriptor := Type_Of (Result_Profile (Decl));
         begin
            if T.Attrs = No_Attributes and then
               Is_Equal (T.Decl, The_Type)
            then
               return True;
            end if;
         end;
      end if;
      declare
         Params : constant Parameter_Specification_List :=
           Parameter_Profile (Decl);
      begin
         for I in Params'Range loop
            declare
               T : constant Type_Descriptor :=
                 Type_Of (Declaration_Subtype_Mark (Params (I)));
            begin
               if T.Attrs = No_Attributes and then
                  Is_Equal (T.Decl, The_Type)
               then
                  return True;
               end if;
            end;
         end loop;
      end;
      return False;
   end Is_Primitive;

   function Primitive_Operations
     (The_Type : in Declaration)
     return Operation_List
   is

      procedure Get_Primitive_Ops
        (The_Type : in     Declaration;
         Result   : in out Op_Ptr;
         Length   : in out Natural;
         Used     : in out Natural;
         Handled  :    out Boolean)
      is

         function Find
           (Table    : in Op_Ptr;
            Used     : in Natural;
            Decl     : in Declaration;
            The_Type : in Declaration)
           return Natural
         is

            function Equals
              (Original : in Operation_Description;
               New_One  : in Declaration;
               The_Type : in Declaration)
              return Boolean
            is
               --  Return true if the names are equal and all types and modes
               --  are equal for all parameters except those where 'New_One'
               --  has a 'The_Type', in which case only the mode must match.

               type Parameter_Description is
                  record
                     Mode      : Mode_Kinds;
                     Is_Access : Boolean;
                     The_Type  : Type_Descriptor;
                  end record;

               type Subprogram_Profile is
                 array (Positive range <>) of Parameter_Description;

               function Normalize
                 (List : in Parameter_Specification_List)
                 return Subprogram_Profile
               is
                  --  Two-pass strategy: first count the names, the reserve
                  --  a large-enough result array, then fill it in.

                  N : Natural;

               begin --  Normalize
                  if List'Last < List'First then
                     declare
                        Nil_Result : constant Subprogram_Profile (1 .. 0) :=
                          (others => (A_Default_In_Mode, False, No_Type));
                     begin
                        return Nil_Result;
                     end;
                  end if;
                  --  First pass:
                  N := 0;
                  for I in List'Range loop
                     declare
                        Names : constant Name_List := A_D.Names (List (I));
                     begin
                        N := N + Names'Length;
                     end;
                  end loop;
                  declare
                     Result : Subprogram_Profile (1 .. N);
                  begin
                     N := 1;
                     for I in List'Range loop
                        declare
                           Names : constant Name_List := A_D.Names (List (I));
                        begin
                           Result (N).Mode      :=
                             Mode_Kind (List (I));
                           if Result (N).Mode = An_In_Mode then
                              --  We don't care about this distinction!
                              Result (N).Mode := A_Default_In_Mode;
                           end if;
                           Result (N).Is_Access :=
                             (Trait_Kind (List (I)) =
                              An_Access_Definition_Trait);
                           declare
                              ST : constant Asis.Element :=
                                Declaration_Subtype_Mark (List (I));
                              T : constant Type_Descriptor :=
                                First_Subtype (Type_Of (ST));
                           begin
                              Result (N).The_Type := T;
                           end;
                           for J in N + 1 .. N + Names'Length - 1 loop
                              Result (N + 1) := Result (N);
                              N := N + 1;
                           end loop;
                           N := N + 1;
                        end;
                     end loop;
                     return Result;
                  end;
               end Normalize;

               function Is_Equal
                 (Old_Param : in Parameter_Description;
                  New_Param : in Parameter_Description;
                  The_Type  : in Declaration)
                 return Boolean
               is
               begin
                  if Old_Param.Mode /= New_Param.Mode or else
                     Old_Param.Is_Access /= New_Param.Is_Access or else
                     Old_Param.The_Type.Attrs /= New_Param.The_Type.Attrs
                  then
                     return False;
                  end if;
                  if Is_Equal (New_Param.The_Type.Decl, The_Type) and then
                     New_Param.The_Type.Attrs = No_Attributes
                  then
                     --  This is not 100% correct (we'd actually need to
                     --  do the substitutions on the way down and check here
                     --  that 'The_Type' is a direct descendant of the old
                     --  type), but it's good enough.
                     return Is_Ancestor (Old_Param.The_Type.Decl, The_Type);
                  else
                     return Is_Equal (New_Param.The_Type.Decl,
                                      Old_Param.The_Type.Decl);
                  end if;
               end Is_Equal;

               D_K_New     : constant Declaration_Kinds :=
                 Declaration_Kind (New_One);
               D_K_Old     : constant Declaration_Kinds :=
                 Declaration_Kind (Original.Decl);
               Is_Func_New : constant Boolean :=
                 D_K_New = A_Function_Declaration or else
                 D_K_New = A_Function_Renaming_Declaration;
               Is_Func_Old : constant Boolean :=
                 D_K_Old = A_Function_Declaration or else
                 D_K_Old = A_Function_Renaming_Declaration;

            begin --  Equals
               if Is_Func_New /= Is_Func_Old then
                  --  Either both are functions, or both are procedures.
                  return False;
               end if;
               --  Name equivalence:
               declare
                  use Asis2.Naming;
                  Name_Orig : constant Wide_String :=
                    Asis2.Text.To_Lower
                      (Name_Definition_Image (Get_Name (Original.Decl)));
                  Name_New  : constant Wide_String :=
                    Asis2.Text.To_Lower
                      (Name_Definition_Image (Get_Name (New_One)));
               begin
                  if Name_Orig /= Name_New then return False; end if;
               end;
               --  Parameters
               declare
                  New_Profile : constant Subprogram_Profile :=
                    Normalize (Parameter_Profile (New_One));
                  Old_Profile : constant Subprogram_Profile :=
                    Normalize (Parameter_Profile (Original.Decl));
                  J : Natural;
               begin
                  if New_Profile'Length /= Old_Profile'Length then
                     return False;
                  end if;
                  J := Old_Profile'First;
                  for I in New_Profile'Range loop
                     if not Is_Equal
                              (Old_Profile (J), New_Profile (I), The_Type)
                     then
                        return False;
                     end if;
                     J := J + 1;
                  end loop;
               end;
               --  Return type, if any.
               if Is_Func_New then
                  declare
                     New_Type   : constant Type_Descriptor :=
                       First_Subtype (Type_Of (Result_Profile (New_One)));
                     Old_Type   : constant Type_Descriptor :=
                       First_Subtype
                         (Type_Of (Result_Profile (Original.Decl)));
                  begin
                     if Is_Equal (The_Type, New_Type.Decl) and then
                        New_Type.Attrs = No_Attributes
                     then
                        return Original.Is_Controlling_Result;
                     else
                        return New_Type.Attrs = Old_Type.Attrs and then
                               Is_Equal (New_Type.Decl, Old_Type.Decl);
                     end if;
                  end;
               else
                  return True;
               end if;
            end Equals;

            Result : Natural := 0;

         begin --  Find
            for I in 1 .. Used loop
               if Equals (Table (I), Decl, The_Type) then
                  Result := I; exit;
               end if;
            end loop;
            return Result;
         end Find;

         procedure Check_Primitive
           (Decl     : in     Declaration;
            The_Type : in     Declaration;
            Result   : in out Op_Ptr;
            Length   : in out Natural;
            Used     : in out Natural)
         is
         begin
            if Is_Primitive (Decl, The_Type) then
               declare
                  J : constant Natural :=
                    Find (Result, Used, Decl, The_Type);
               begin
                  if J /= 0 then
                     --  Found!!
                     Result (J).Kind := Overridden_Operation;
                     Result (J).Decl := Decl;
                  else
                     --  Not found: this is a new operation
                     if Used = Length then
                        declare
                           Q : constant Op_Ptr :=
                             new Operation_List (1 .. Length + 10);
                        begin
                           if Result /= null then
                              Q (1 .. Length) := Result.all;
                              Free (Result);
                           end if;
                           Result := Q;
                           Length := Length + 10;
                        end;
                     end if;
                     Used := Used + 1;
                     Result (Used) :=
                       (False, New_Operation, Decl);
                     if Declaration_Kind (Decl) =
                        A_Function_Declaration
                     then
                        declare
                           Result_Type : constant Type_Descriptor :=
                             Type_Of (Result_Profile (Decl));
                        begin
                           Result (Used).Is_Controlling_Result :=
                             Result_Type.Attrs = No_Attributes and then
                             Is_Equal (Result_Type.Decl, The_Type);
                        end;
                     end if;
                  end if; --  Found?
               end;
            end if;
         end Check_Primitive;

         Def       : Definition;
         D_K       : Definition_Kinds;
         T_K       : Type_Kinds;
         Is_Tagged : Boolean          := False;

      begin --  Get_Primitive_Ops
         Handled := False;
         if Is_Nil (The_Type) then return; end if;
         Def := Type_Declaration_View (The_Type);
         D_K := Definition_Kind (Def);
         T_K := Type_Kind (Def);
         case D_K is
            when A_Private_Type_Definition |
                 A_Tagged_Private_Type_Definition =>
               Is_Tagged := D_K = A_Tagged_Private_Type_Definition;

            when A_Private_Extension_Definition =>
               --  Do the ancestor.
               Get_Primitive_Ops
                 (Ancestor_Type (The_Type), Result, Length, Used, Handled);
               Is_Tagged := True;

            when A_Formal_Type_Definition =>
               if
                  Formal_Type_Kind (Def) = A_Formal_Derived_Type_Definition
               then
                  --  Do the ancestor.
                  Get_Primitive_Ops
                    (Ancestor_Type (The_Type), Result, Length, Used, Handled);
               end if;
               return;

            when A_Subtype_Indication =>
               --  Actual parameter for a formal derived type in an
               --  instantiation
               Get_Primitive_Ops
                 (Ancestor_Type (The_Type), Result, Length, Used, Handled);
               --  Hmmm... if I do "subtype X is Some_Tagged_Type;" and then
               --  add operations to type 'X', GNAT treats them as primitive
               --  operations of 'Some_Tagged_Type' (they are inherited even
               --  if I do "type Other is new Some_Tagged_Type with null
               --  record;"), at least if they're both in the same package
               --  spec... Is this actually correct?
               return;

            when A_Type_Definition =>
               case T_K is
                  when A_Record_Type_Definition |
                       A_Tagged_Record_Type_Definition =>
                     Is_Tagged := T_K = A_Tagged_Record_Type_Definition;

                  when A_Derived_Type_Definition |
                       A_Derived_Record_Extension_Definition =>
                     --  Do the parent.
                     Get_Primitive_Ops
                       (Ancestor_Type (The_Type),
                        Result, Length, Used, Handled);
                     if not Handled then
                        --  It was a derived type from some type we don't
                        --  handle.
                        return;
                     end if;
                     Is_Tagged := T_K = A_Derived_Record_Extension_Definition;

                  when others =>
                     return;
                     --  Hook for future development: get it right for types
                     --  derived from standard types such as Natural.
                     --  null;

               end case;

            when others =>
               return;
               --  Hook for future development: get it right for types
               --  derived from standard types such as Natural.
               --  null;

         end case;
         --  We have only private types, (tagged) record types, and types
         --  derived from such types here. Note that we do not have formal
         --  types anymore, here! Do ourselves now.
         Handled := True;
         for I in 1 .. Used loop
            --  Hook for future development: get it right for types derived
            --  from standard types such as Natural.
            --  if Result (I).Kind = New_Operation then
            --   Result (I).Kind := Inherited_Original_Operation;
            --  elsif Result (I).Kind = Overridden_Operation then
            Result (I).Kind := Inherited_Operation;
            --  end if;
         end loop;
         Traverse_Declarations :
         declare
            Enclosing_Package : constant Element :=
              Enclosing_Element (The_Type);
            --  We *know* that the enclosing element must be a package: we
            --  only handle specs, and therefore all types are declared in
            --  a package, not within body declarative parts.
            Decls             : constant Declarative_Item_List :=
              Visible_Part_Declarative_Items (Enclosing_Package, False);
            --  Without pragmas and the like.
            Index             : Natural := 0;
         begin
            for I in Decls'Range loop
               if Is_Equal (Decls (I), The_Type) then
                  Index := I; exit;
               end if;
            end loop;
            if Index = 0 then
               --  Not found??? Hey, what's going on?
               raise Program_Error;
            end if;
            for I in Index + 1 .. Decls'Last loop
               if Element_Kind (Decls (I)) = A_Declaration then
                  case Declaration_Kind (Decls (I)) is
                     when A_Function_Declaration |
                          A_Procedure_Declaration |
                          A_Function_Renaming_Declaration |
                          A_Procedure_Renaming_Declaration =>
                        if not Is_Tagged or else
                           Is_Dispatching_Operation (Decls (I))
                        then
                           Check_Primitive
                             (Decls (I), The_Type, Result, Length, Used);
                        end if;

                     when others =>
                        --  Primitive operations of tagged types shall be
                        --  declared before the type is frozen; RM 3.9.2(13),
                        --  RM 13.14 (16). Therefore we can stop.
                        --    Note that the RM says "shall", and a compiler is
                        --  thus forced to issue an error message if the
                        --  source indeed has something looking like a
                        --  primitive operation of a tagged type after that
                        --  type already had been frozen.
                        --    As a consequence, we don't even have to check
                        --  for this condition!
                        null;

                  end case;
               end if;
            end loop;
         end Traverse_Declarations;
      end Get_Primitive_Ops;

      P       : Op_Ptr;
      Length  : Natural := 0;
      Used    : Natural := 0;
      Handled : Boolean;
   begin
      Get_Primitive_Ops (The_Type, P, Length, Used, Handled);
      if Handled and then P /= null then
         declare
            Result : constant Operation_List (1 .. Used) := P (1 .. Used);
         begin
            Free (P);
            return Result;
         end;
      else
         if P /= null then Free (P); end if;
         declare
            Nil_Result : constant Operation_List (1 .. 0) :=
              (others => (False, Inherited_Operation, Nil_Element));
         begin
            return Nil_Result;
         end;
      end if;
   end Primitive_Operations;

   ----------------------------------------------------------------------------

   function Hash_Unit
     (Unit : in Asis.Compilation_Unit)
     return GAL.Support.Hashing.Hash_Type
   is
   begin
      return GAL.Support.Hashing.Hash_Case_Insensitive
               (AD.Text_Utilities.To_String
                  (Asis2.Naming.Full_Unit_Name (Unit)));
   end Hash_Unit;

   package Unit_Tables is
     new GAL.Containers.Hash_Tables
           (Item   => Asis.Compilation_Unit,
            Memory => GAL.Storage.Standard,
            Hash   => Hash_Unit,
            "="    => Asis.Compilation_Units.Is_Equal);

   function Get_Dependents
     (Unit : in Asis.Compilation_Unit)
     return Asis.Compilation_Unit_List
   is
      use Asis.Compilation_Units;
      use Asis.Compilation_Units.Relations;

      Rel : constant Relationship :=
        Semantic_Dependence_Order
          (Compilation_Unit_List'(1 => (Unit)),
           Nil_Compilation_Unit_List,
           Enclosing_Context (Unit),
           Supporters);

      function Use_Unit
        (Unit : in Compilation_Unit)
        return Boolean
      is
      begin
         if Is_Nil (Unit) then return False; end if;
         if Unit_Origin (Unit) /= An_Application_Unit then
            return False;
         end if;
         case Unit_Class (Unit) is
            when A_Public_Declaration |
                 A_Public_Declaration_And_Body |
                 A_Private_Declaration =>
               declare
                  Kind : constant Unit_Kinds := Unit_Kind (Unit);
               begin
                  if Kind = Not_A_Unit or else
                     Kind >= A_Procedure_Body_Subunit
                  then
                     return False;
                  else
                     return True;
                  end if;
               end;
            when others =>
               null;
         end case;
         return False;
      end Use_Unit;

   begin
      --  There is a bug in ASIS-for-GNAT 3.16a: it doesn't include parents
      --  of withed units unless they are withed explicitly. Compensate for
      --  that. Note: we use a hash table to avoid repeatedly inserting parents
      --  that already exist. This is important, because the transitive
      --  closure of withed units may be large!
      if Rel.Consistent_Length < 1 then return Rel.Consistent; end if;
      declare
         Units : Unit_Tables.Hash_Table;
      begin
         Unit_Tables.Set_Resize (Units, 0.75);
         declare
            Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (20);
         begin
            Unit_Tables.Set_Growth_Policy (Units, Linear_Growth);
         end;
         for I in 1 .. Rel.Consistent_Length loop
            declare
               Unit : Compilation_Unit := Rel.Consistent (I);
            begin
               while Use_Unit (Unit) loop
                  begin
                     Unit_Tables.Insert (Units, Unit);
                  exception
                     when Unit_Tables.Duplicate_Key =>
                        exit;
                  end;
                  Unit := Corresponding_Parent_Declaration (Unit);
               end loop;
            end;
         end loop;
         --  Ok, we have them all.
         declare
            Result : Compilation_Unit_List
              (1 .. Natural (Unit_Tables.Nof_Elements (Units)));
            N      : Natural := 1;

            procedure Add_Item
              (Value : in     Compilation_Unit;
               Quit  : in out Boolean)
            is
               pragma Warnings (Off, Quit); --  silence -gnatwa
            begin
               Result (N) := Value;
               N := N + 1;
            end Add_Item;

            procedure Collect is new Unit_Tables.Traverse_G (Add_Item);

         begin
            Collect (Units);
            return Result;
         end;
      end;
   end Get_Dependents;

   ----------------------------------------------------------------------------

   function Get_Pragmas
     (Unit : in Asis.Compilation_Unit)
     return Asis.Pragma_Element_List
   is

      procedure Filter
        (Decl     : in     Declaration;
         List     : in out Pragma_Element_List;
         N        :    out Natural)
      is
         --  Filter out anything that cannot possibly apply to a library unit
         --  declaration. In other words, keep all library unit pragmas, plus
         --  a few selected pragmas that can apply to library unit subprograms:
         --  Inline, Asynchronous, Convention, and Import and Export.

         function Check
           (Decl  : in Declaration;
            Param : in Association)
           return Boolean
         is
         begin
            return Asis2.Declarations.References
                     (Actual_Parameter (Param), Decl);
         end Check;

         procedure Swap is
            new GAL.Support.Swap (Asis.Element);

         I    : Natural := List'First;
         Keep : Boolean;

      begin --  Filter
         N := List'Last;
         while I <= N loop
            case Pragma_Kind (List (I)) is
               when An_All_Calls_Remote_Pragma |
                    An_Elaborate_Body_Pragma |
                    A_Preelaborate_Pragma |
                    A_Pure_Pragma |
                    A_Remote_Call_Interface_Pragma |
                    A_Remote_Types_Pragma |
                    A_Shared_Passive_Pragma |
                    An_Inline_Pragma |
                    An_Asynchronous_Pragma =>
                  declare
                     Params : constant Association_List :=
                       Pragma_Argument_Associations (List (I));
                  begin
                     if Params'Last = Params'First then
                        Keep := Check (Decl, Params (Params'First));
                     else
                        Keep := Params'Last < Params'First;
                     end if;
                  end;

               when A_Convention_Pragma |
                    An_Import_Pragma |
                    An_Export_Pragma =>
                  declare
                     Params : constant Association_List :=
                       Pragma_Argument_Associations (List (I));
                  begin
                     if Params'Last < Params'First + 1 then
                        Keep := False;
                     else
                        Keep := Check (Decl, Params (Params'First + 1));
                     end if;
                  end;

               when others =>
                  Keep := False;

            end case;
            if Keep then
               I := I + 1;
            else
               if I < N then Swap (List (I), List (N)); end if;
               N := N - 1;
            end if;
         end loop;
      end Filter;

      Outer : Pragma_Element_List := Compilation_Pragmas (Unit);

      N : Natural;

   begin
      Filter (Unit_Declaration (Unit), Outer, N);
      return Outer (Outer'First .. N);
   end Get_Pragmas;

   function Expand_Generic
     (Element  : in     Asis.Element;
      Reporter : access AD.Messages.Error_Reporter'Class)
     return Asis.Element
   is
      Result : Asis.Element := Element;
   begin
      while Is_Part_Of_Instance (Result) loop
         declare
            Temp : Asis.Element;
         begin
            begin
               Temp := Corresponding_Generic_Element (Result);
            exception
               when others =>
                  --  ASIS-for-GNAT 3.14p sometimes fails here. Happens for
                  --  instance in the simple_test, if ASIS chooses to use the
                  --  tree in 'test-ch.adt' to traverse the generic unit
                  --  'Test.Use_Signature'. It appears that in this case, the
                  --  selector 'X' in the parameter type 'X_Formal.X' has
                  --  'Is_Part_Of_Instance' set (which it hasn't if there is
                  --  only a tree file 'test-use_signature.adt'!), and that
                  --  seems to trigger an ASIS bug. It raises an exception
                  --  ('Inappropriate_Element') somewhere in Enclosing_Element,
                  --  which certainly is bogus.
                  --
                  --  We do the next best thing and just swallow the exception.
                  --  This means we'll just return the non-template name.
                  AD.Messages.Report_Error
                    (Reporter.all, "Cannot find item from generic template");
                  exit;
            end;
            Result := Temp;
         end;
      end loop;
      return Result;
   end Expand_Generic;

end AD.Queries;