Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S E M _ R E S                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, 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.          --

--                                                                          --

-- 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 Checks;   use Checks;

with Debug;    use Debug;

with Debug_A;  use Debug_A;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Expander; use Expander;

with Exp_Disp; use Exp_Disp;

with Exp_Ch6;  use Exp_Ch6;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Fname;    use Fname;

with Freeze;   use Freeze;

with Itypes;   use Itypes;

with Lib;      use Lib;

with Lib.Xref; use Lib.Xref;

with Namet;    use Namet;

with Nmake;    use Nmake;

with Nlists;   use Nlists;

with Opt;      use Opt;

with Output;   use Output;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Aggr; use Sem_Aggr;

with Sem_Attr; use Sem_Attr;

with Sem_Cat;  use Sem_Cat;

with Sem_Ch4;  use Sem_Ch4;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch13; use Sem_Ch13;

with Sem_Dim;  use Sem_Dim;

with Sem_Disp; use Sem_Disp;

with Sem_Dist; use Sem_Dist;

with Sem_Elim; use Sem_Elim;

with Sem_Elab; use Sem_Elab;

with Sem_Eval; use Sem_Eval;

with Sem_Intr; use Sem_Intr;

with Sem_Util; use Sem_Util;

with Targparm; use Targparm;

with Sem_Type; use Sem_Type;

with Sem_Warn; use Sem_Warn;

with Sinfo;    use Sinfo;

with Sinfo.CN; use Sinfo.CN;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Style;    use Style;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

with Urealp;   use Urealp;

package body Sem_Res is

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

   -- Local Subprograms --

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

   --  Second pass (top-down) type checking and overload resolution procedures

   --  Typ is the type required by context. These procedures propagate the type

   --  information recursively to the descendants of N. If the node is not

   --  overloaded, its Etype is established in the first pass. If overloaded,

   --  the Resolve routines set the correct type. For arith. operators, the

   --  Etype is the base type of the context.

   --  Note that Resolve_Attribute is separated off in Sem_Attr

   function Bad_Unordered_Enumeration_Reference

     (N : Node_Id;

      T : Entity_Id) return Boolean;

   --  Node N contains a potentially dubious reference to type T, either an

   --  explicit comparison, or an explicit range. This function returns True

   --  if the type T is an enumeration type for which No pragma Order has been

   --  given, and the reference N is not in the same extended source unit as

   --  the declaration of T.

   procedure Check_Discriminant_Use (N : Node_Id);

   --  Enforce the restrictions on the use of discriminants when constraining

   --  a component of a discriminated type (record or concurrent type).

   procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);

   --  Given a node for an operator associated with type T, check that

   --  the operator is visible. Operators all of whose operands are

   --  universal must be checked for visibility during resolution

   --  because their type is not determinable based on their operands.

   procedure Check_Fully_Declared_Prefix

     (Typ  : Entity_Id;

      Pref : Node_Id);

   --  Check that the type of the prefix of a dereference is not incomplete

   function Check_Infinite_Recursion (N : Node_Id) return Boolean;

   --  Given a call node, N, which is known to occur immediately within the

   --  subprogram being called, determines whether it is a detectable case of

   --  an infinite recursion, and if so, outputs appropriate messages. Returns

   --  True if an infinite recursion is detected, and False otherwise.

   procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);

   --  If the type of the object being initialized uses the secondary stack

   --  directly or indirectly, create a transient scope for the call to the

   --  init proc. This is because we do not create transient scopes for the

   --  initialization of individual components within the init proc itself.

   --  Could be optimized away perhaps?

   procedure Check_No_Direct_Boolean_Operators (N : Node_Id);

   --  N is the node for a logical operator. If the operator is predefined, and

   --  the root type of the operands is Standard.Boolean, then a check is made

   --  for restriction No_Direct_Boolean_Operators. This procedure also handles

   --  the style check for Style_Check_Boolean_And_Or.

   function Is_Definite_Access_Type (E : Entity_Id) return Boolean;

   --  Determine whether E is an access type declared by an access declaration,

   --  and not an (anonymous) allocator type.

   function Is_Predefined_Op (Nam : Entity_Id) return Boolean;

   --  Utility to check whether the entity for an operator is a predefined

   --  operator, in which case the expression is left as an operator in the

   --  tree (else it is rewritten into a call). An instance of an intrinsic

   --  conversion operation may be given an operator name, but is not treated

   --  like an operator. Note that an operator that is an imported back-end

   --  builtin has convention Intrinsic, but is expected to be rewritten into

   --  a call, so such an operator is not treated as predefined by this

   --  predicate.

   procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);

   --  If a default expression in entry call N depends on the discriminants

   --  of the task, it must be replaced with a reference to the discriminant

   --  of the task being called.

   procedure Resolve_Op_Concat_Arg

     (N       : Node_Id;

      Arg     : Node_Id;

      Typ     : Entity_Id;

      Is_Comp : Boolean);

   --  Internal procedure for Resolve_Op_Concat to resolve one operand of

   --  concatenation operator.  The operand is either of the array type or of

   --  the component type. If the operand is an aggregate, and the component

   --  type is composite, this is ambiguous if component type has aggregates.

   procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id);

   --  Does the first part of the work of Resolve_Op_Concat

   procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id);

   --  Does the "rest" of the work of Resolve_Op_Concat, after the left operand

   --  has been resolved. See Resolve_Op_Concat for details.

   procedure Resolve_Allocator                 (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Arithmetic_Op             (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Call                      (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Case_Expression           (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Character_Literal         (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Comparison_Op             (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Conditional_Expression    (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Equality_Op               (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Expression_With_Actions   (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Membership_Op             (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Null                      (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Operator_Symbol           (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Op_Concat                 (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Op_Expon                  (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Op_Not                    (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Qualified_Expression      (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Quantified_Expression     (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Range                     (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Real_Literal              (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Reference                 (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Selected_Component        (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Shift                     (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Short_Circuit             (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Slice                     (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_String_Literal            (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Subprogram_Info           (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Type_Conversion           (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Unary_Op                  (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Unchecked_Expression      (N : Node_Id; Typ : Entity_Id);

   procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);

   function Operator_Kind

     (Op_Name   : Name_Id;

      Is_Binary : Boolean) return Node_Kind;

   --  Utility to map the name of an operator into the corresponding Node. Used

   --  by other node rewriting procedures.

   procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);

   --  Resolve actuals of call, and add default expressions for missing ones.

   --  N is the Node_Id for the subprogram call, and Nam is the entity of the

   --  called subprogram.

   procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);

   --  Called from Resolve_Call, when the prefix denotes an entry or element

   --  of entry family. Actuals are resolved as for subprograms, and the node

   --  is rebuilt as an entry call. Also called for protected operations. Typ

   --  is the context type, which is used when the operation is a protected

   --  function with no arguments, and the return value is indexed.

   procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);

   --  A call to a user-defined intrinsic operator is rewritten as a call to

   --  the corresponding predefined operator, with suitable conversions. Note

   --  that this applies only for intrinsic operators that denote predefined

   --  operators, not ones that are intrinsic imports of back-end builtins.

   procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);

   --  Ditto, for unary operators (arithmetic ones and "not" on signed

   --  integer types for VMS).

   procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);

   --  If an operator node resolves to a call to a user-defined operator,

   --  rewrite the node as a function call.

   procedure Make_Call_Into_Operator

     (N     : Node_Id;

      Typ   : Entity_Id;

      Op_Id : Entity_Id);

   --  Inverse transformation: if an operator is given in functional notation,

   --  then after resolving the node, transform into an operator node, so

   --  that operands are resolved properly. Recall that predefined operators

   --  do not have a full signature and special resolution rules apply.

   procedure Rewrite_Renamed_Operator

     (N   : Node_Id;

      Op  : Entity_Id;

      Typ : Entity_Id);

   --  An operator can rename another, e.g. in  an instantiation. In that

   --  case, the proper operator node must be constructed and resolved.

   procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);

   --  The String_Literal_Subtype is built for all strings that are not

   --  operands of a static concatenation operation. If the argument is

   --  not a N_String_Literal node, then the call has no effect.

   procedure Set_Slice_Subtype (N : Node_Id);

   --  Build subtype of array type, with the range specified by the slice

   procedure Simplify_Type_Conversion (N : Node_Id);

   --  Called after N has been resolved and evaluated, but before range checks

   --  have been applied. Currently simplifies a combination of floating-point

   --  to integer conversion and Truncation attribute.

   function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;

   --  A universal_fixed expression in an universal context is unambiguous if

   --  there is only one applicable fixed point type. Determining whether there

   --  is only one requires a search over all visible entities, and happens

   --  only in very pathological cases (see 6115-006).

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

   -- Ambiguous_Character --

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

   procedure Ambiguous_Character (C : Node_Id) is

      E : Entity_Id;

   begin

      if Nkind (C) = N_Character_Literal then

         Error_Msg_N ("ambiguous character literal", C);

         --  First the ones in Standard

         Error_Msg_N ("\\possible interpretation: Character!", C);

         Error_Msg_N ("\\possible interpretation: Wide_Character!", C);

         --  Include Wide_Wide_Character in Ada 2005 mode

         if Ada_Version >= Ada_2005 then

            Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C);

         end if;

         --  Now any other types that match

         E := Current_Entity (C);

         while Present (E) loop

            Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));

            E := Homonym (E);

         end loop;

      end if;

   end Ambiguous_Character;

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

   -- Analyze_And_Resolve --

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

   procedure Analyze_And_Resolve (N : Node_Id) is

   begin

      Analyze (N);

      Resolve (N);

   end Analyze_And_Resolve;

   procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is

   begin

      Analyze (N);

      Resolve (N, Typ);

   end Analyze_And_Resolve;

   --  Version withs check(s) suppressed

   procedure Analyze_And_Resolve

     (N        : Node_Id;

      Typ      : Entity_Id;

      Suppress : Check_Id)

   is

      Scop : constant Entity_Id := Current_Scope;

   begin

      if Suppress = All_Checks then

         declare

            Svg : constant Suppress_Array := Scope_Suppress;

         begin

            Scope_Suppress := (others => True);

            Analyze_And_Resolve (N, Typ);

            Scope_Suppress := Svg;

         end;

      else

         declare

            Svg : constant Boolean := Scope_Suppress (Suppress);

         begin

            Scope_Suppress (Suppress) := True;

            Analyze_And_Resolve (N, Typ);

            Scope_Suppress (Suppress) := Svg;

         end;

      end if;

      if Current_Scope /= Scop

        and then Scope_Is_Transient

      then

         --  This can only happen if a transient scope was created for an inner

         --  expression, which will be removed upon completion of the analysis

         --  of an enclosing construct. The transient scope must have the

         --  suppress status of the enclosing environment, not of this Analyze

         --  call.

         Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=

           Scope_Suppress;

      end if;

   end Analyze_And_Resolve;

   procedure Analyze_And_Resolve

     (N        : Node_Id;

      Suppress : Check_Id)

   is

      Scop : constant Entity_Id := Current_Scope;

   begin

      if Suppress = All_Checks then

         declare

            Svg : constant Suppress_Array := Scope_Suppress;

         begin

            Scope_Suppress := (others => True);

            Analyze_And_Resolve (N);

            Scope_Suppress := Svg;

         end;

      else

         declare

            Svg : constant Boolean := Scope_Suppress (Suppress);

         begin

            Scope_Suppress (Suppress) := True;

            Analyze_And_Resolve (N);

            Scope_Suppress (Suppress) := Svg;

         end;

      end if;

      if Current_Scope /= Scop

        and then Scope_Is_Transient

      then

         Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=

           Scope_Suppress;

      end if;

   end Analyze_And_Resolve;

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

   -- Bad_Unordered_Enumeration_Reference --

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

   function Bad_Unordered_Enumeration_Reference

     (N : Node_Id;

      T : Entity_Id) return Boolean

   is

   begin

      return Is_Enumeration_Type (T)

        and then Comes_From_Source (N)

        and then Warn_On_Unordered_Enumeration_Type

        and then not Has_Pragma_Ordered (T)

        and then not In_Same_Extended_Unit (N, T);

   end Bad_Unordered_Enumeration_Reference;

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

   -- Check_Discriminant_Use --

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

   procedure Check_Discriminant_Use (N : Node_Id) is

      PN   : constant Node_Id   := Parent (N);

      Disc : constant Entity_Id := Entity (N);

      P    : Node_Id;

      D    : Node_Id;

   begin

      --  Any use in a spec-expression is legal

      if In_Spec_Expression then

         null;

      elsif Nkind (PN) = N_Range then

         --  Discriminant cannot be used to constrain a scalar type

         P := Parent (PN);

         if Nkind (P) = N_Range_Constraint

           and then Nkind (Parent (P)) = N_Subtype_Indication

           and then Nkind (Parent (Parent (P))) = N_Component_Definition

         then

            Error_Msg_N ("discriminant cannot constrain scalar type", N);

         elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then

            --  The following check catches the unusual case where a

            --  discriminant appears within an index constraint that is part of

            --  a larger expression within a constraint on a component, e.g. "C

            --  : Int range 1 .. F (new A(1 .. D))". For now we only check case

            --  of record components, and note that a similar check should also

            --  apply in the case of discriminant constraints below. ???

            --  Note that the check for N_Subtype_Declaration below is to

            --  detect the valid use of discriminants in the constraints of a

            --  subtype declaration when this subtype declaration appears

            --  inside the scope of a record type (which is syntactically

            --  illegal, but which may be created as part of derived type

            --  processing for records). See Sem_Ch3.Build_Derived_Record_Type

            --  for more info.

            if Ekind (Current_Scope) = E_Record_Type

              and then Scope (Disc) = Current_Scope

              and then not

                (Nkind (Parent (P)) = N_Subtype_Indication

                  and then

                    Nkind_In (Parent (Parent (P)), N_Component_Definition,

                                                   N_Subtype_Declaration)

                  and then Paren_Count (N) = 0)

            then

               Error_Msg_N

                 ("discriminant must appear alone in component constraint", N);

               return;

            end if;

            --   Detect a common error:

            --   type R (D : Positive := 100) is record

            --     Name : String (1 .. D);

            --   end record;

            --  The default value causes an object of type R to be allocated

            --  with room for Positive'Last characters. The RM does not mandate

            --  the allocation of the maximum size, but that is what GNAT does

            --  so we should warn the programmer that there is a problem.

            Check_Large : declare

               SI : Node_Id;

               T  : Entity_Id;

               TB : Node_Id;

               CB : Entity_Id;

               function Large_Storage_Type (T : Entity_Id) return Boolean;

               --  Return True if type T has a large enough range that any

               --  array whose index type covered the whole range of the type

               --  would likely raise Storage_Error.

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

               -- Large_Storage_Type --

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

               function Large_Storage_Type (T : Entity_Id) return Boolean is

               begin

                  --  The type is considered large if its bounds are known at

                  --  compile time and if it requires at least as many bits as

                  --  a Positive to store the possible values.

                  return Compile_Time_Known_Value (Type_Low_Bound (T))

                    and then Compile_Time_Known_Value (Type_High_Bound (T))

                    and then

                      Minimum_Size (T, Biased => True) >=

                        RM_Size (Standard_Positive);

               end Large_Storage_Type;

            --  Start of processing for Check_Large

            begin

               --  Check that the Disc has a large range

               if not Large_Storage_Type (Etype (Disc)) then

                  goto No_Danger;

               end if;

               --  If the enclosing type is limited, we allocate only the

               --  default value, not the maximum, and there is no need for

               --  a warning.

               if Is_Limited_Type (Scope (Disc)) then

                  goto No_Danger;

               end if;

               --  Check that it is the high bound

               if N /= High_Bound (PN)

                 or else No (Discriminant_Default_Value (Disc))

               then

                  goto No_Danger;

               end if;

               --  Check the array allows a large range at this bound. First

               --  find the array

               SI := Parent (P);

               if Nkind (SI) /= N_Subtype_Indication then

                  goto No_Danger;

               end if;

               T := Entity (Subtype_Mark (SI));

               if not Is_Array_Type (T) then

                  goto No_Danger;

               end if;

               --  Next, find the dimension

               TB := First_Index (T);

               CB := First (Constraints (P));

               while True

                 and then Present (TB)

                 and then Present (CB)

                 and then CB /= PN

               loop

                  Next_Index (TB);

                  Next (CB);

               end loop;

               if CB /= PN then

                  goto No_Danger;

               end if;

               --  Now, check the dimension has a large range

               if not Large_Storage_Type (Etype (TB)) then

                  goto No_Danger;

               end if;

               --  Warn about the danger

               Error_Msg_N

                 ("?creation of & object may raise Storage_Error!",

                  Scope (Disc));

               <<No_Danger>>

                  null;

            end Check_Large;

         end if;

      --  Legal case is in index or discriminant constraint

      elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,

                          N_Discriminant_Association)

      then

         if Paren_Count (N) > 0 then

            Error_Msg_N

              ("discriminant in constraint must appear alone",  N);

         elsif Nkind (N) = N_Expanded_Name

           and then Comes_From_Source (N)

         then

            Error_Msg_N

              ("discriminant must appear alone as a direct name", N);

         end if;

         return;

      --  Otherwise, context is an expression. It should not be within (i.e. a

      --  subexpression of) a constraint for a component.

      else

         D := PN;

         P := Parent (PN);

         while not Nkind_In (P, N_Component_Declaration,

                                N_Subtype_Indication,

                                N_Entry_Declaration)

         loop

            D := P;

            P := Parent (P);

            exit when No (P);

         end loop;

         --  If the discriminant is used in an expression that is a bound of a

         --  scalar type, an Itype is created and the bounds are attached to

         --  its range, not to the original subtype indication. Such use is of

         --  course a double fault.

         if (Nkind (P) = N_Subtype_Indication

              and then Nkind_In (Parent (P), N_Component_Definition,

                                             N_Derived_Type_Definition)

              and then D = Constraint (P))

           --  The constraint itself may be given by a subtype indication,

           --  rather than by a more common discrete range.

           or else (Nkind (P) = N_Subtype_Indication

                      and then

                    Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)

           or else Nkind (P) = N_Entry_Declaration

           or else Nkind (D) = N_Defining_Identifier

         then

            Error_Msg_N

              ("discriminant in constraint must appear alone",  N);

         end if;

      end if;

   end Check_Discriminant_Use;

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

   -- Check_For_Visible_Operator --

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

   procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is

   begin

      if Is_Invisible_Operator (N, T) then

         Error_Msg_NE -- CODEFIX

           ("operator for} is not directly visible!", N, First_Subtype (T));

         Error_Msg_N -- CODEFIX

           ("use clause would make operation legal!", N);

      end if;

   end Check_For_Visible_Operator;

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

   --  Check_Fully_Declared_Prefix --

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

   procedure Check_Fully_Declared_Prefix

     (Typ  : Entity_Id;

      Pref : Node_Id)

   is

   begin

      --  Check that the designated type of the prefix of a dereference is

      --  not an incomplete type. This cannot be done unconditionally, because

      --  dereferences of private types are legal in default expressions. This

      --  case is taken care of in Check_Fully_Declared, called below. There

      --  are also 2005 cases where it is legal for the prefix to be unfrozen.

      --  This consideration also applies to similar checks for allocators,

      --  qualified expressions, and type conversions.

      --  An additional exception concerns other per-object expressions that

      --  are not directly related to component declarations, in particular

      --  representation pragmas for tasks. These will be per-object

      --  expressions if they depend on discriminants or some global entity.

      --  If the task has access discriminants, the designated type may be

      --  incomplete at the point the expression is resolved. This resolution

      --  takes place within the body of the initialization procedure, where

      --  the discriminant is replaced by its discriminal.

      if Is_Entity_Name (Pref)

        and then Ekind (Entity (Pref)) = E_In_Parameter

      then

         null;

      --  Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages

      --  are handled by Analyze_Access_Attribute, Analyze_Assignment,

      --  Analyze_Object_Renaming, and Freeze_Entity.

      elsif Ada_Version >= Ada_2005

        and then Is_Entity_Name (Pref)

        and then Is_Access_Type (Etype (Pref))

        and then Ekind (Directly_Designated_Type (Etype (Pref))) =

                                                       E_Incomplete_Type

        and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))

      then

         null;

      else

         Check_Fully_Declared (Typ, Parent (Pref));

      end if;

   end Check_Fully_Declared_Prefix;

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

   -- Check_Infinite_Recursion --

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

   function Check_Infinite_Recursion (N : Node_Id) return Boolean is

      P : Node_Id;

      C : Node_Id;

      function Same_Argument_List return Boolean;

      --  Check whether list of actuals is identical to list of formals of

      --  called function (which is also the enclosing scope).

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

      -- Same_Argument_List --

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

      function Same_Argument_List return Boolean is

         A    : Node_Id;

         F    : Entity_Id;

         Subp : Entity_Id;

      begin

         if not Is_Entity_Name (Name (N)) then

            return False;

         else

            Subp := Entity (Name (N));

         end if;

         F := First_Formal (Subp);

         A := First_Actual (N);

         while Present (F) and then Present (A) loop

            if not Is_Entity_Name (A)

              or else Entity (A) /= F

            then

               return False;

            end if;

            Next_Actual (A);

            Next_Formal (F);

         end loop;

         return True;

      end Same_Argument_List;

   --  Start of processing for Check_Infinite_Recursion

   begin

      --  Special case, if this is a procedure call and is a call to the

      --  current procedure with the same argument list, then this is for

      --  sure an infinite recursion and we insert a call to raise SE.

      if Is_List_Member (N)

        and then List_Length (List_Containing (N)) = 1

        and then Same_Argument_List

      then

         declare

            P : constant Node_Id := Parent (N);

         begin

            if Nkind (P) = N_Handled_Sequence_Of_Statements

              and then Nkind (Parent (P)) = N_Subprogram_Body