path: root/gcc/ada/sem_aux.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              S E M _ A U X                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
--                                                                          --
-- 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 Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- 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 GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- 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.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;  use Atree;
with Einfo;  use Einfo;
with Snames; use Snames;
with Stand;  use Stand;
with Uintp;  use Uintp;

package body Sem_Aux is

   ----------------------
   -- Ancestor_Subtype --
   ----------------------

   function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is
   begin
      --  If this is first subtype, or is a base type, then there is no
      --  ancestor subtype, so we return Empty to indicate this fact.

      if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
         return Empty;
      end if;

      declare
         D : constant Node_Id := Declaration_Node (Typ);

      begin
         --  If we have a subtype declaration, get the ancestor subtype

         if Nkind (D) = N_Subtype_Declaration then
            if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
               return Entity (Subtype_Mark (Subtype_Indication (D)));
            else
               return Entity (Subtype_Indication (D));
            end if;

         --  If not, then no subtype indication is available

         else
            return Empty;
         end if;
      end;
   end Ancestor_Subtype;

   --------------------
   -- Available_View --
   --------------------

   function Available_View (Ent : Entity_Id) return Entity_Id is
   begin
      --  Obtain the non-limited view (if available)

      if Has_Non_Limited_View (Ent) then
         return Get_Full_View (Non_Limited_View (Ent));

      --  In all other cases, return entity unchanged

      else
         return Ent;
      end if;
   end Available_View;

   --------------------
   -- Constant_Value --
   --------------------

   function Constant_Value (Ent : Entity_Id) return Node_Id is
      D      : constant Node_Id := Declaration_Node (Ent);
      Full_D : Node_Id;

   begin
      --  If we have no declaration node, then return no constant value. Not
      --  clear how this can happen, but it does sometimes and this is the
      --  safest approach.

      if No (D) then
         return Empty;

      --  Normal case where a declaration node is present

      elsif Nkind (D) = N_Object_Renaming_Declaration then
         return Renamed_Object (Ent);

      --  If this is a component declaration whose entity is a constant, it is
      --  a prival within a protected function (and so has no constant value).

      elsif Nkind (D) = N_Component_Declaration then
         return Empty;

      --  If there is an expression, return it

      elsif Present (Expression (D)) then
         return Expression (D);

      --  For a constant, see if we have a full view

      elsif Ekind (Ent) = E_Constant
        and then Present (Full_View (Ent))
      then
         Full_D := Parent (Full_View (Ent));

         --  The full view may have been rewritten as an object renaming

         if Nkind (Full_D) = N_Object_Renaming_Declaration then
            return Name (Full_D);
         else
            return Expression (Full_D);
         end if;

      --  Otherwise we have no expression to return

      else
         return Empty;
      end if;
   end Constant_Value;

   ---------------------------------
   -- Corresponding_Unsigned_Type --
   ---------------------------------

   function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is
      pragma Assert (Is_Signed_Integer_Type (Typ));
      Siz : constant Uint := Esize (Base_Type (Typ));
   begin
      if Siz = Esize (Standard_Short_Short_Integer) then
         return Standard_Short_Short_Unsigned;
      elsif Siz = Esize (Standard_Short_Integer) then
         return Standard_Short_Unsigned;
      elsif Siz = Esize (Standard_Unsigned) then
         return Standard_Unsigned;
      elsif Siz = Esize (Standard_Long_Integer) then
         return Standard_Long_Unsigned;
      elsif Siz = Esize (Standard_Long_Long_Integer) then
         return Standard_Long_Long_Unsigned;
      else
         raise Program_Error;
      end if;
   end Corresponding_Unsigned_Type;

   -----------------------------
   -- Enclosing_Dynamic_Scope --
   -----------------------------

   function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
      S : Entity_Id;

   begin
      --  The following test is an error defense against some syntax errors
      --  that can leave scopes very messed up.

      if Ent = Standard_Standard then
         return Ent;
      end if;

      --  Normal case, search enclosing scopes

      --  Note: the test for Present (S) should not be required, it defends
      --  against an ill-formed tree.

      S := Scope (Ent);
      loop
         --  If we somehow got an empty value for Scope, the tree must be
         --  malformed. Rather than blow up we return Standard in this case.

         if No (S) then
            return Standard_Standard;

         --  Quit if we get to standard or a dynamic scope. We must also
         --  handle enclosing scopes that have a full view; required to
         --  locate enclosing scopes that are synchronized private types
         --  whose full view is a task type.

         elsif S = Standard_Standard
           or else Is_Dynamic_Scope (S)
           or else (Is_Private_Type (S)
                     and then Present (Full_View (S))
                     and then Is_Dynamic_Scope (Full_View (S)))
         then
            return S;

         --  Otherwise keep climbing

         else
            S := Scope (S);
         end if;
      end loop;
   end Enclosing_Dynamic_Scope;

   ------------------------
   -- First_Discriminant --
   ------------------------

   function First_Discriminant (Typ : Entity_Id) return Entity_Id is
      Ent : Entity_Id;

   begin
      pragma Assert
        (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ));

      Ent := First_Entity (Typ);

      --  The discriminants are not necessarily contiguous, because access
      --  discriminants will generate itypes. They are not the first entities
      --  either because the tag must be ahead of them.

      if Chars (Ent) = Name_uTag then
         Ent := Next_Entity (Ent);
      end if;

      --  Skip all hidden stored discriminants if any

      while Present (Ent) loop
         exit when Ekind (Ent) = E_Discriminant
           and then not Is_Completely_Hidden (Ent);

         Ent := Next_Entity (Ent);
      end loop;

      --  Call may be on a private type with unknown discriminants, in which
      --  case Ent is Empty, and as per the spec, we return Empty in this case.

      --  Historical note: The assertion in previous versions that Ent is a
      --  discriminant was overly cautious and prevented convenient application
      --  of this function in the gnatprove context.

      return Ent;
   end First_Discriminant;

   -------------------------------
   -- First_Stored_Discriminant --
   -------------------------------

   function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is
      Ent : Entity_Id;

      function Has_Completely_Hidden_Discriminant
        (Typ : Entity_Id) return Boolean;
      --  Scans the Discriminants to see whether any are Completely_Hidden
      --  (the mechanism for describing non-specified stored discriminants)
      --  Note that the entity list for the type may contain anonymous access
      --  types created by expressions that constrain access discriminants.

      ----------------------------------------
      -- Has_Completely_Hidden_Discriminant --
      ----------------------------------------

      function Has_Completely_Hidden_Discriminant
        (Typ : Entity_Id) return Boolean
      is
         Ent : Entity_Id;

      begin
         pragma Assert (Ekind (Typ) = E_Discriminant);

         Ent := Typ;
         while Present (Ent) loop

            --  Skip anonymous types that may be created by expressions
            --  used as discriminant constraints on inherited discriminants.

            if Is_Itype (Ent) then
               null;

            elsif Ekind (Ent) = E_Discriminant
              and then Is_Completely_Hidden (Ent)
            then
               return True;
            end if;

            Ent := Next_Entity (Ent);
         end loop;

         return False;
      end Has_Completely_Hidden_Discriminant;

   --  Start of processing for First_Stored_Discriminant

   begin
      pragma Assert
        (Has_Discriminants (Typ)
          or else Has_Unknown_Discriminants (Typ));

      Ent := First_Entity (Typ);

      if Chars (Ent) = Name_uTag then
         Ent := Next_Entity (Ent);
      end if;

      if Has_Completely_Hidden_Discriminant (Ent) then
         while Present (Ent) loop
            exit when Ekind (Ent) = E_Discriminant
              and then Is_Completely_Hidden (Ent);
            Ent := Next_Entity (Ent);
         end loop;
      end if;

      pragma Assert (Ekind (Ent) = E_Discriminant);

      return Ent;
   end First_Stored_Discriminant;

   -------------------
   -- First_Subtype --
   -------------------

   function First_Subtype (Typ : Entity_Id) return Entity_Id is
      B   : constant Entity_Id := Base_Type (Typ);
      F   : constant Node_Id   := Freeze_Node (B);
      Ent : Entity_Id;

   begin
      --  If the base type has no freeze node, it is a type in Standard, and
      --  always acts as its own first subtype, except where it is one of the
      --  predefined integer types. If the type is formal, it is also a first
      --  subtype, and its base type has no freeze node. On the other hand, a
      --  subtype of a generic formal is not its own first subtype. Its base
      --  type, if anonymous, is attached to the formal type decl. from which
      --  the first subtype is obtained.

      if No (F) then
         if B = Base_Type (Standard_Integer) then
            return Standard_Integer;

         elsif B = Base_Type (Standard_Long_Integer) then
            return Standard_Long_Integer;

         elsif B = Base_Type (Standard_Short_Short_Integer) then
            return Standard_Short_Short_Integer;

         elsif B = Base_Type (Standard_Short_Integer) then
            return Standard_Short_Integer;

         elsif B = Base_Type (Standard_Long_Long_Integer) then
            return Standard_Long_Long_Integer;

         elsif Is_Generic_Type (Typ) then
            if Present (Parent (B)) then
               return Defining_Identifier (Parent (B));
            else
               return Defining_Identifier (Associated_Node_For_Itype (B));
            end if;

         else
            return B;
         end if;

      --  Otherwise we check the freeze node, if it has a First_Subtype_Link
      --  then we use that link, otherwise (happens with some Itypes), we use
      --  the base type itself.

      else
         Ent := First_Subtype_Link (F);

         if Present (Ent) then
            return Ent;
         else
            return B;
         end if;
      end if;
   end First_Subtype;

   -------------------------
   -- First_Tag_Component --
   -------------------------

   function First_Tag_Component (Typ : Entity_Id) return Entity_Id is
      Comp : Entity_Id;
      Ctyp : Entity_Id;

   begin
      Ctyp := Typ;
      pragma Assert (Is_Tagged_Type (Ctyp));

      if Is_Class_Wide_Type (Ctyp) then
         Ctyp := Root_Type (Ctyp);
      end if;

      if Is_Private_Type (Ctyp) then
         Ctyp := Underlying_Type (Ctyp);

         --  If the underlying type is missing then the source program has
         --  errors and there is nothing else to do (the full-type declaration
         --  associated with the private type declaration is missing).

         if No (Ctyp) then
            return Empty;
         end if;
      end if;

      Comp := First_Entity (Ctyp);
      while Present (Comp) loop
         if Is_Tag (Comp) then
            return Comp;
         end if;

         Comp := Next_Entity (Comp);
      end loop;

      --  No tag component found

      return Empty;
   end First_Tag_Component;

   ---------------------
   -- Get_Binary_Nkind --
   ---------------------

   function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
   begin
      case Chars (Op) is
         when Name_Op_Add =>
            return N_Op_Add;
         when Name_Op_Concat =>
            return N_Op_Concat;
         when Name_Op_Expon =>
            return N_Op_Expon;
         when Name_Op_Subtract =>
            return N_Op_Subtract;
         when Name_Op_Mod =>
            return N_Op_Mod;
         when Name_Op_Multiply =>
            return N_Op_Multiply;
         when Name_Op_Divide =>
            return N_Op_Divide;
         when Name_Op_Rem =>
            return N_Op_Rem;
         when Name_Op_And =>
            return N_Op_And;
         when Name_Op_Eq =>
            return N_Op_Eq;
         when Name_Op_Ge =>
            return N_Op_Ge;
         when Name_Op_Gt =>
            return N_Op_Gt;
         when Name_Op_Le =>
            return N_Op_Le;
         when Name_Op_Lt =>
            return N_Op_Lt;
         when Name_Op_Ne =>
            return N_Op_Ne;
         when Name_Op_Or =>
            return N_Op_Or;
         when Name_Op_Xor =>
            return N_Op_Xor;
         when others =>
            raise Program_Error;
      end case;
   end Get_Binary_Nkind;

   -------------------
   -- Get_Low_Bound --
   -------------------

   function Get_Low_Bound (E : Entity_Id) return Node_Id is
   begin
      if Ekind (E) = E_String_Literal_Subtype then
         return String_Literal_Low_Bound (E);
      else
         return Type_Low_Bound (E);
      end if;
   end Get_Low_Bound;

   ------------------
   -- Get_Rep_Item --
   ------------------

   function Get_Rep_Item
     (E             : Entity_Id;
      Nam           : Name_Id;
      Check_Parents : Boolean := True) return Node_Id
   is
      N : Node_Id;

   begin
      N := First_Rep_Item (E);
      while Present (N) loop

         --  Only one of Priority / Interrupt_Priority can be specified, so
         --  return whichever one is present to catch illegal duplication.

         if Nkind (N) = N_Pragma
           and then
             (Pragma_Name (N) = Nam
               or else (Nam = Name_Priority
                         and then Pragma_Name (N) = Name_Interrupt_Priority)
               or else (Nam = Name_Interrupt_Priority
                         and then Pragma_Name (N) = Name_Priority))
         then
            if Check_Parents then
               return N;

            --  If Check_Parents is False, return N if the pragma doesn't
            --  appear in the Rep_Item chain of the parent.

            else
               declare
                  Par : constant Entity_Id := Nearest_Ancestor (E);
                  --  This node represents the parent type of type E (if any)

               begin
                  if No (Par) then
                     return N;

                  elsif not Present_In_Rep_Item (Par, N) then
                     return N;
                  end if;
               end;
            end if;

         elsif Nkind (N) = N_Attribute_Definition_Clause
           and then
             (Chars (N) = Nam
               or else (Nam = Name_Priority
                         and then Chars (N) = Name_Interrupt_Priority))
         then
            if Check_Parents or else Entity (N) = E then
               return N;
            end if;

         elsif Nkind (N) = N_Aspect_Specification
           and then
             (Chars (Identifier (N)) = Nam
               or else
                 (Nam = Name_Priority
                   and then Chars (Identifier (N)) = Name_Interrupt_Priority))
         then
            if Check_Parents then
               return N;

            elsif Entity (N) = E then
               return N;
            end if;
         end if;

         Next_Rep_Item (N);
      end loop;

      return Empty;
   end Get_Rep_Item;

   function Get_Rep_Item
     (E             : Entity_Id;
      Nam1          : Name_Id;
      Nam2          : Name_Id;
      Check_Parents : Boolean := True) return Node_Id
   is
      Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents);
      Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents);

      N : Node_Id;

   begin
      --  Check both Nam1_Item and Nam2_Item are present

      if No (Nam1_Item) then
         return Nam2_Item;
      elsif No (Nam2_Item) then
         return Nam1_Item;
      end if;

      --  Return the first node encountered in the list

      N := First_Rep_Item (E);
      while Present (N) loop
         if N = Nam1_Item or else N = Nam2_Item then
            return N;
         end if;

         Next_Rep_Item (N);
      end loop;

      return Empty;
   end Get_Rep_Item;

   --------------------
   -- Get_Rep_Pragma --
   --------------------

   function Get_Rep_Pragma
     (E             : Entity_Id;
      Nam           : Name_Id;
      Check_Parents : Boolean := True) return Node_Id
   is
      N : Node_Id;

   begin
      N := Get_Rep_Item (E, Nam, Check_Parents);

      if Present (N) and then Nkind (N) = N_Pragma then
         return N;
      end if;

      return Empty;
   end Get_Rep_Pragma;

   function Get_Rep_Pragma
     (E             : Entity_Id;
      Nam1          : Name_Id;
      Nam2          : Name_Id;
      Check_Parents : Boolean := True) return Node_Id
   is
      Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents);
      Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents);

      N : Node_Id;

   begin
      --  Check both Nam1_Item and Nam2_Item are present

      if No (Nam1_Item) then
         return Nam2_Item;
      elsif No (Nam2_Item) then
         return Nam1_Item;
      end if;

      --  Return the first node encountered in the list

      N := First_Rep_Item (E);
      while Present (N) loop
         if N = Nam1_Item or else N = Nam2_Item then
            return N;
         end if;

         Next_Rep_Item (N);
      end loop;

      return Empty;
   end Get_Rep_Pragma;

   ---------------------
   -- Get_Unary_Nkind --
   ---------------------

   function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
   begin
      case Chars (Op) is
         when Name_Op_Abs =>
            return N_Op_Abs;
         when Name_Op_Subtract =>
            return N_Op_Minus;
         when Name_Op_Not =>
            return N_Op_Not;
         when Name_Op_Add =>
            return N_Op_Plus;
         when others =>
            raise Program_Error;
      end case;
   end Get_Unary_Nkind;

   ---------------------------------
   -- Has_External_Tag_Rep_Clause --
   ---------------------------------

   function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
   begin
      pragma Assert (Is_Tagged_Type (T));
      return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
   end Has_External_Tag_Rep_Clause;

   ------------------
   -- Has_Rep_Item --
   ------------------

   function Has_Rep_Item
     (E             : Entity_Id;
      Nam           : Name_Id;
      Check_Parents : Boolean := True) return Boolean
   is
   begin
      return Present (Get_Rep_Item (E, Nam, Check_Parents));
   end Has_Rep_Item;

   function Has_Rep_Item
     (E             : Entity_Id;
      Nam1          : Name_Id;
      Nam2          : Name_Id;
      Check_Parents : Boolean := True) return Boolean
   is
   begin
      return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
   end Has_Rep_Item;

   --------------------
   -- Has_Rep_Pragma --
   --------------------

   function Has_Rep_Pragma
     (E             : Entity_Id;
      Nam           : Name_Id;
      Check_Parents : Boolean := True) return Boolean
   is
   begin
      return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
   end Has_Rep_Pragma;

   function Has_Rep_Pragma
     (E             : Entity_Id;
      Nam1          : Name_Id;
      Nam2          : Name_Id;
      Check_Parents : Boolean := True) return Boolean
   is
   begin
      return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
   end Has_Rep_Pragma;

   --------------------------------
   -- Has_Unconstrained_Elements --
   --------------------------------

   function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
      U_T : constant Entity_Id := Underlying_Type (T);
   begin
      if No (U_T) then
         return False;
      elsif Is_Record_Type (U_T) then
         return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
      elsif Is_Array_Type (U_T) then
         return Has_Unconstrained_Elements (Component_Type (U_T));
      else
         return False;
      end if;
   end Has_Unconstrained_Elements;

   ----------------------
   -- Has_Variant_Part --
   ----------------------

   function Has_Variant_Part (Typ : Entity_Id) return Boolean is
      FSTyp : Entity_Id;
      Decl  : Node_Id;
      TDef  : Node_Id;
      CList : Node_Id;

   begin
      if not Is_Type (Typ) then
         return False;
      end if;

      FSTyp := First_Subtype (Typ);

      if not Has_Discriminants (FSTyp) then
         return False;
      end if;

      --  Proceed with cautious checks here, return False if tree is not
      --  as expected (may be caused by prior errors).

      Decl := Declaration_Node (FSTyp);

      if Nkind (Decl) /= N_Full_Type_Declaration then
         return False;
      end if;

      TDef := Type_Definition (Decl);

      if Nkind (TDef) /= N_Record_Definition then
         return False;
      end if;

      CList := Component_List (TDef);

      if Nkind (CList) /= N_Component_List then
         return False;
      else
         return Present (Variant_Part (CList));
      end if;
   end Has_Variant_Part;

   ---------------------
   -- In_Generic_Body --
   ---------------------

   function In_Generic_Body (Id : Entity_Id) return Boolean is
      S : Entity_Id;

   begin
      --  Climb scopes looking for generic body

      S := Id;
      while Present (S) and then S /= Standard_Standard loop

         --  Generic package body

         if Ekind (S) = E_Generic_Package
           and then In_Package_Body (S)
         then
            return True;

         --  Generic subprogram body

         elsif Is_Subprogram (S)
           and then Nkind (Unit_Declaration_Node (S)) =
                      N_Generic_Subprogram_Declaration
         then
            return True;
         end if;

         S := Scope (S);
      end loop;

      --  False if top of scope stack without finding a generic body

      return False;
   end In_Generic_Body;

   -------------------------------
   -- Initialization_Suppressed --
   -------------------------------

   function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
   begin
      return Suppress_Initialization (Typ)
        or else Suppress_Initialization (Base_Type (Typ));
   end Initialization_Suppressed;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Obsolescent_Warnings.Init;
   end Initialize;

   -------------
   -- Is_Body --
   -------------

   function Is_Body (N : Node_Id) return Boolean is
   begin
      return
        Nkind (N) in N_Body_Stub
          or else Nkind_In (N, N_Entry_Body,
                               N_Package_Body,
                               N_Protected_Body,
                               N_Subprogram_Body,
                               N_Task_Body);
   end Is_Body;

   ---------------------
   -- Is_By_Copy_Type --
   ---------------------

   function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is
   begin
      --  If Id is a private type whose full declaration has not been seen,
      --  we assume for now that it is not a By_Copy type. Clearly this
      --  attribute should not be used before the type is frozen, but it is
      --  needed to build the associated record of a protected type. Another
      --  place where some lookahead for a full view is needed ???

      return
        Is_Elementary_Type (Ent)
          or else (Is_Private_Type (Ent)
                     and then Present (Underlying_Type (Ent))
                     and then Is_Elementary_Type (Underlying_Type (Ent)));
   end Is_By_Copy_Type;

   --------------------------
   -- Is_By_Reference_Type --
   --------------------------

   function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is
      Btype : constant Entity_Id := Base_Type (Ent);

   begin
      if Error_Posted (Ent) or else Error_Posted (Btype) then
         return False;

      elsif Is_Private_Type (Btype) then
         declare
            Utyp : constant Entity_Id := Underlying_Type (Btype);
         begin
            if No (Utyp) then
               return False;
            else
               return Is_By_Reference_Type (Utyp);
            end if;
         end;

      elsif Is_Incomplete_Type (Btype) then
         declare
            Ftyp : constant Entity_Id := Full_View (Btype);
         begin
            if No (Ftyp) then
               return False;
            else
               return Is_By_Reference_Type (Ftyp);
            end if;
         end;

      elsif Is_Concurrent_Type (Btype) then
         return True;

      elsif Is_Record_Type (Btype) then
         if Is_Limited_Record (Btype)
           or else Is_Tagged_Type (Btype)
           or else Is_Volatile (Btype)
         then
            return True;

         else
            declare
               C : Entity_Id;

            begin
               C := First_Component (Btype);
               while Present (C) loop

                  --  For each component, test if its type is a by reference
                  --  type and if its type is volatile. Also test the component
                  --  itself for being volatile. This happens for example when
                  --  a Volatile aspect is added to a component.

                  if Is_By_Reference_Type (Etype (C))
                    or else Is_Volatile (Etype (C))
                    or else Is_Volatile (C)
                  then
                     return True;
                  end if;

                  C := Next_Component (C);
               end loop;
            end;

            return False;
         end if;

      elsif Is_Array_Type (Btype) then
         return
           Is_Volatile (Btype)
             or else Is_By_Reference_Type (Component_Type (Btype))
             or else Is_Volatile (Component_Type (Btype))
             or else Has_Volatile_Components (Btype);

      else
         return False;
      end if;
   end Is_By_Reference_Type;

   -------------------------
   -- Is_Definite_Subtype --
   -------------------------

   function Is_Definite_Subtype (T : Entity_Id) return Boolean is
      pragma Assert (Is_Type (T));
      K : constant Entity_Kind := Ekind (T);

   begin
      if Is_Constrained (T) then
         return True;

      elsif K in Array_Kind
        or else K in Class_Wide_Kind
        or else Has_Unknown_Discriminants (T)
      then
         return False;

      --  Known discriminants: definite if there are default values. Note that
      --  if any discriminant has a default, they all do.

      elsif Has_Discriminants (T) then
         return Present (Discriminant_Default_Value (First_Discriminant (T)));

      else
         return True;
      end if;
   end Is_Definite_Subtype;

   ---------------------
   -- Is_Derived_Type --
   ---------------------

   function Is_Derived_Type (Ent : E) return B is
      Par : Node_Id;

   begin
      if Is_Type (Ent)
        and then Base_Type (Ent) /= Root_Type (Ent)
        and then not Is_Class_Wide_Type (Ent)

        --  An access_to_subprogram whose result type is a limited view can
        --  appear in a return statement, without the full view of the result
        --  type being available. Do not interpret this as a derived type.

        and then Ekind (Ent) /= E_Subprogram_Type
      then
         if not Is_Numeric_Type (Root_Type (Ent)) then
            return True;

         else
            Par := Parent (First_Subtype (Ent));

            return Present (Par)
              and then Nkind (Par) = N_Full_Type_Declaration
              and then Nkind (Type_Definition (Par)) =
                         N_Derived_Type_Definition;
         end if;

      else
         return False;
      end if;
   end Is_Derived_Type;

   -----------------------
   -- Is_Generic_Formal --
   -----------------------

   function Is_Generic_Formal (E : Entity_Id) return Boolean is
      Kind : Node_Kind;
   begin
      if No (E) then
         return False;
      else
         Kind := Nkind (Parent (E));
         return
           Nkind_In (Kind, N_Formal_Object_Declaration,
                           N_Formal_Package_Declaration,
                           N_Formal_Type_Declaration)
             or else Is_Formal_Subprogram (E);
      end if;
   end Is_Generic_Formal;

   -------------------------------
   -- Is_Immutably_Limited_Type --
   -------------------------------

   function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
      Btype : constant Entity_Id := Available_View (Base_Type (Ent));

   begin
      if Is_Limited_Record (Btype) then
         return True;

      elsif Ekind (Btype) = E_Limited_Private_Type
        and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
      then
         return not In_Package_Body (Scope ((Btype)));

      elsif Is_Private_Type (Btype) then

         --  AI05-0063: A type derived from a limited private formal type is
         --  not immutably limited in a generic body.

         if Is_Derived_Type (Btype)
           and then Is_Generic_Type (Etype (Btype))
         then
            if not Is_Limited_Type (Etype (Btype)) then
               return False;

            --  A descendant of a limited formal type is not immutably limited
            --  in the generic body, or in the body of a generic child.

            elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
               return not In_Package_Body (Scope (Btype));

            else
               return False;
            end if;

         else
            declare
               Utyp : constant Entity_Id := Underlying_Type (Btype);
            begin
               if No (Utyp) then
                  return False;
               else
                  return Is_Immutably_Limited_Type (Utyp);
               end if;
            end;
         end if;

      elsif Is_Concurrent_Type (Btype) then
         return True;

      else
         return False;
      end if;
   end Is_Immutably_Limited_Type;

   ---------------------
   -- Is_Limited_Type --
   ---------------------

   function Is_Limited_Type (Ent : Entity_Id) return Boolean is
      Btype : constant E := Base_Type (Ent);
      Rtype : constant E := Root_Type (Btype);

   begin
      if not Is_Type (Ent) then
         return False;

      elsif Ekind (Btype) = E_Limited_Private_Type
        or else Is_Limited_Composite (Btype)
      then
         return True;

      elsif Is_Concurrent_Type (Btype) then
         return True;

         --  The Is_Limited_Record flag normally indicates that the type is
         --  limited. The exception is that a type does not inherit limitedness
         --  from its interface ancestor. So the type may be derived from a
         --  limited interface, but is not limited.

      elsif Is_Limited_Record (Ent)
        and then not Is_Interface (Ent)
      then
         return True;

      --  Otherwise we will look around to see if there is some other reason
      --  for it to be limited, except that if an error was posted on the
      --  entity, then just assume it is non-limited, because it can cause
      --  trouble to recurse into a murky entity resulting from other errors.

      elsif Error_Posted (Ent) then
         return False;

      elsif Is_Record_Type (Btype) then

         if Is_Limited_Interface (Ent) then
            return True;

         --  AI-419: limitedness is not inherited from a limited interface

         elsif Is_Limited_Record (Rtype) then
            return not Is_Interface (Rtype)
              or else Is_Protected_Interface (Rtype)
              or else Is_Synchronized_Interface (Rtype)
              or else Is_Task_Interface (Rtype);

         elsif Is_Class_Wide_Type (Btype) then
            return Is_Limited_Type (Rtype);

         else
            declare
               C : E;

            begin
               C := First_Component (Btype);
               while Present (C) loop
                  if Is_Limited_Type (Etype (C)) then
                     return True;
                  end if;

                  C := Next_Component (C);
               end loop;
            end;

            return False;
         end if;

      elsif Is_Array_Type (Btype) then
         return Is_Limited_Type (Component_Type (Btype));

      else
         return False;
      end if;
   end Is_Limited_Type;

   ---------------------
   -- Is_Limited_View --
   ---------------------

   function Is_Limited_View (Ent : Entity_Id) return Boolean is
      Btype : constant Entity_Id := Available_View (Base_Type (Ent));

   begin
      if Is_Limited_Record (Btype) then
         return True;

      elsif Ekind (Btype) = E_Limited_Private_Type
        and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
      then
         return not In_Package_Body (Scope ((Btype)));

      elsif Is_Private_Type (Btype) then

         --  AI05-0063: A type derived from a limited private formal type is
         --  not immutably limited in a generic body.

         if Is_Derived_Type (Btype)
           and then Is_Generic_Type (Etype (Btype))
         then
            if not Is_Limited_Type (Etype (Btype)) then
               return False;

            --  A descendant of a limited formal type is not immutably limited
            --  in the generic body, or in the body of a generic child.

            elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
               return not In_Package_Body (Scope (Btype));

            else
               return False;
            end if;

         else
            declare
               Utyp : constant Entity_Id := Underlying_Type (Btype);
            begin
               if No (Utyp) then
                  return False;
               else
                  return Is_Limited_View (Utyp);
               end if;
            end;
         end if;

      elsif Is_Concurrent_Type (Btype) then
         return True;

      elsif Is_Record_Type (Btype) then

         --  Note that we return True for all limited interfaces, even though
         --  (unsynchronized) limited interfaces can have descendants that are
         --  nonlimited, because this is a predicate on the type itself, and
         --  things like functions with limited interface results need to be
         --  handled as build in place even though they might return objects
         --  of a type that is not inherently limited.

         if Is_Class_Wide_Type (Btype) then
            return Is_Limited_View (Root_Type (Btype));

         else
            declare
               C : Entity_Id;

            begin
               C := First_Component (Btype);
               while Present (C) loop

                  --  Don't consider components with interface types (which can
                  --  only occur in the case of a _parent component anyway).
                  --  They don't have any components, plus it would cause this
                  --  function to return true for nonlimited types derived from
                  --  limited interfaces.

                  if not Is_Interface (Etype (C))
                    and then Is_Limited_View (Etype (C))
                  then
                     return True;
                  end if;

                  C := Next_Component (C);
               end loop;
            end;

            return False;
         end if;

      elsif Is_Array_Type (Btype) then
         return Is_Limited_View (Component_Type (Btype));

      else
         return False;
      end if;
   end Is_Limited_View;

   ----------------------
   -- Nearest_Ancestor --
   ----------------------

   function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
      D : constant Node_Id := Declaration_Node (Typ);

   begin
      --  If we have a subtype declaration, get the ancestor subtype

      if Nkind (D) = N_Subtype_Declaration then
         if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
            return Entity (Subtype_Mark (Subtype_Indication (D)));
         else
            return Entity (Subtype_Indication (D));
         end if;

      --  If derived type declaration, find who we are derived from

      elsif Nkind (D) = N_Full_Type_Declaration
        and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
      then
         declare
            DTD : constant Entity_Id := Type_Definition (D);
            SI  : constant Entity_Id := Subtype_Indication (DTD);
         begin
            if Is_Entity_Name (SI) then
               return Entity (SI);
            else
               return Entity (Subtype_Mark (SI));
            end if;
         end;

      --  If derived type and private type, get the full view to find who we
      --  are derived from.

      elsif Is_Derived_Type (Typ)
        and then Is_Private_Type (Typ)
        and then Present (Full_View (Typ))
      then
         return Nearest_Ancestor (Full_View (Typ));

      --  Otherwise, nothing useful to return, return Empty

      else
         return Empty;
      end if;
   end Nearest_Ancestor;

   ---------------------------
   -- Nearest_Dynamic_Scope --
   ---------------------------

   function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is
   begin
      if Is_Dynamic_Scope (Ent) then
         return Ent;
      else
         return Enclosing_Dynamic_Scope (Ent);
      end if;
   end Nearest_Dynamic_Scope;

   ------------------------
   -- Next_Tag_Component --
   ------------------------

   function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is
      Comp : Entity_Id;

   begin
      pragma Assert (Is_Tag (Tag));

      --  Loop to look for next tag component

      Comp := Next_Entity (Tag);
      while Present (Comp) loop
         if Is_Tag (Comp) then
            pragma Assert (Chars (Comp) /= Name_uTag);
            return Comp;
         end if;

         Comp := Next_Entity (Comp);
      end loop;

      --  No tag component found

      return Empty;
   end Next_Tag_Component;

   -----------------------
   -- Number_Components --
   -----------------------

   function Number_Components (Typ : Entity_Id) return Nat is
      N    : Int;
      Comp : Entity_Id;

   begin
      N := 0;

      --  We do not call Einfo.First_Component_Or_Discriminant, as this
      --  function does not skip completely hidden discriminants, which we
      --  want to skip here.

      if Has_Discriminants (Typ) then
         Comp := First_Discriminant (Typ);
      else
         Comp := First_Component (Typ);
      end if;

      while Present (Comp) loop
         N := N + 1;
         Comp := Next_Component_Or_Discriminant (Comp);
      end loop;

      return N;
   end Number_Components;

   --------------------------
   -- Number_Discriminants --
   --------------------------

   function Number_Discriminants (Typ : Entity_Id) return Pos is
      N     : Int;
      Discr : Entity_Id;

   begin
      N := 0;
      Discr := First_Discriminant (Typ);
      while Present (Discr) loop
         N := N + 1;
         Discr := Next_Discriminant (Discr);
      end loop;

      return N;
   end Number_Discriminants;

   ----------------------------------------------
   -- Object_Type_Has_Constrained_Partial_View --
   ----------------------------------------------

   function Object_Type_Has_Constrained_Partial_View
     (Typ  : Entity_Id;
      Scop : Entity_Id) return Boolean
   is
   begin
      return Has_Constrained_Partial_View (Typ)
        or else (In_Generic_Body (Scop)
                  and then Is_Generic_Type (Base_Type (Typ))
                  and then Is_Private_Type (Base_Type (Typ))
                  and then not Is_Tagged_Type (Typ)
                  and then not (Is_Array_Type (Typ)
                                 and then not Is_Constrained (Typ))
                  and then Has_Discriminants (Typ));
   end Object_Type_Has_Constrained_Partial_View;

   ------------------
   -- Package_Body --
   ------------------

   function Package_Body (E : Entity_Id) return Node_Id is
      N : Node_Id;

   begin
      if Ekind (E) = E_Package_Body then
         N := Parent (E);

         if Nkind (N) = N_Defining_Program_Unit_Name then
            N := Parent (N);
         end if;

      else
         N := Package_Spec (E);

         if Present (Corresponding_Body (N)) then
            N := Parent (Corresponding_Body (N));

            if Nkind (N) = N_Defining_Program_Unit_Name then
               N := Parent (N);
            end if;
         else
            N := Empty;
         end if;
      end if;

      return N;
   end Package_Body;

   ------------------
   -- Package_Spec --
   ------------------

   function Package_Spec (E : Entity_Id) return Node_Id is
   begin
      return Parent (Package_Specification (E));
   end Package_Spec;

   ---------------------------
   -- Package_Specification --
   ---------------------------

   function Package_Specification (E : Entity_Id) return Node_Id is
      N : Node_Id;

   begin
      N := Parent (E);

      if Nkind (N) = N_Defining_Program_Unit_Name then
         N := Parent (N);
      end if;

      return N;
   end Package_Specification;

   ---------------------
   -- Subprogram_Body --
   ---------------------

   function Subprogram_Body (E : Entity_Id) return Node_Id is
      Body_E : constant Entity_Id := Subprogram_Body_Entity (E);

   begin
      if No (Body_E) then
         return Empty;
      else
         return Parent (Subprogram_Specification (Body_E));
      end if;
   end Subprogram_Body;

   ----------------------------
   -- Subprogram_Body_Entity --
   ----------------------------

   function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
      N : Node_Id;

   begin
      --  Retrieve the declaration for E

      N := Parent (Subprogram_Specification (E));

      --  If this declaration is not a subprogram body, then it must be a
      --  subprogram declaration or body stub, from which we can retrieve the
      --  entity for the corresponding subprogram body if any, or an abstract
      --  subprogram declaration, for which we return Empty.

      case Nkind (N) is
         when N_Subprogram_Body =>
            return E;

         when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
            return Corresponding_Body (N);

         when others =>
            return Empty;
      end case;
   end Subprogram_Body_Entity;

   ---------------------
   -- Subprogram_Spec --
   ---------------------

   function Subprogram_Spec (E : Entity_Id) return Node_Id is
      N : Node_Id;

   begin
      --  Retrieve the declaration for E

      N := Parent (Subprogram_Specification (E));

      --  This declaration is either subprogram declaration or a subprogram
      --  body, in which case return Empty.

      if Nkind (N) = N_Subprogram_Declaration then
         return N;
      else
         return Empty;
      end if;
   end Subprogram_Spec;

   ------------------------------
   -- Subprogram_Specification --
   ------------------------------

   function Subprogram_Specification (E : Entity_Id) return Node_Id is
      N : Node_Id;

   begin
      N := Parent (E);

      if Nkind (N) = N_Defining_Program_Unit_Name then
         N := Parent (N);
      end if;

      --  If the Parent pointer of E is not a subprogram specification node
      --  (going through an intermediate N_Defining_Program_Unit_Name node
      --  for subprogram units), then E is an inherited operation. Its parent
      --  points to the type derivation that produces the inheritance: that's
      --  the node that generates the subprogram specification. Its alias
      --  is the parent subprogram, and that one points to a subprogram
      --  declaration, or to another type declaration if this is a hierarchy
      --  of derivations.

      if Nkind (N) not in N_Subprogram_Specification then
         pragma Assert (Present (Alias (E)));
         N := Subprogram_Specification (Alias (E));
      end if;

      return N;
   end Subprogram_Specification;

   ---------------
   -- Tree_Read --
   ---------------

   procedure Tree_Read is
   begin
      Obsolescent_Warnings.Tree_Read;
   end Tree_Read;

   ----------------
   -- Tree_Write --
   ----------------

   procedure Tree_Write is
   begin
      Obsolescent_Warnings.Tree_Write;
   end Tree_Write;

   --------------------
   -- Ultimate_Alias --
   --------------------

   function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
      E : Entity_Id := Prim;

   begin
      while Present (Alias (E)) loop
         pragma Assert (Alias (E) /= E);
         E := Alias (E);
      end loop;

      return E;
   end Ultimate_Alias;

   --------------------------
   -- Unit_Declaration_Node --
   --------------------------

   function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
      N : Node_Id := Parent (Unit_Id);

   begin
      --  Predefined operators do not have a full function declaration

      if Ekind (Unit_Id) = E_Operator then
         return N;
      end if;

      --  Isn't there some better way to express the following ???

      while Nkind (N) /= N_Abstract_Subprogram_Declaration
        and then Nkind (N) /= N_Entry_Body
        and then Nkind (N) /= N_Entry_Declaration
        and then Nkind (N) /= N_Formal_Package_Declaration
        and then Nkind (N) /= N_Function_Instantiation
        and then Nkind (N) /= N_Generic_Package_Declaration
        and then Nkind (N) /= N_Generic_Subprogram_Declaration
        and then Nkind (N) /= N_Package_Declaration
        and then Nkind (N) /= N_Package_Body
        and then Nkind (N) /= N_Package_Instantiation
        and then Nkind (N) /= N_Package_Renaming_Declaration
        and then Nkind (N) /= N_Procedure_Instantiation
        and then Nkind (N) /= N_Protected_Body
        and then Nkind (N) /= N_Subprogram_Declaration
        and then Nkind (N) /= N_Subprogram_Body
        and then Nkind (N) /= N_Subprogram_Body_Stub
        and then Nkind (N) /= N_Subprogram_Renaming_Declaration
        and then Nkind (N) /= N_Task_Body
        and then Nkind (N) /= N_Task_Type_Declaration
        and then Nkind (N) not in N_Formal_Subprogram_Declaration
        and then Nkind (N) not in N_Generic_Renaming_Declaration
      loop
         N := Parent (N);

         --  We don't use Assert here, because that causes an infinite loop
         --  when assertions are turned off. Better to crash.

         if No (N) then
            raise Program_Error;
         end if;
      end loop;

      return N;
   end Unit_Declaration_Node;

end Sem_Aux;