Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S E M _ C H 6                               --

--                                                                          --

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

with Elists;   use Elists;

with Errout;   use Errout;

with Expander; use Expander;

with Exp_Ch6;  use Exp_Ch6;

with Exp_Ch7;  use Exp_Ch7;

with Exp_Ch9;  use Exp_Ch9;

with Exp_Disp; use Exp_Disp;

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.Xref; use Lib.Xref;

with Layout;   use Layout;

with Namet;    use Namet;

with Lib;      use Lib;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

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_Cat;  use Sem_Cat;

with Sem_Ch3;  use Sem_Ch3;

with Sem_Ch4;  use Sem_Ch4;

with Sem_Ch5;  use Sem_Ch5;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Ch10; use Sem_Ch10;

with Sem_Ch12; use Sem_Ch12;

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_Eval; use Sem_Eval;

with Sem_Mech; use Sem_Mech;

with Sem_Prag; use Sem_Prag;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sem_Type; use Sem_Type;

with Sem_Warn; use Sem_Warn;

with Sinput;   use Sinput;

with Stand;    use Stand;

with Sinfo;    use Sinfo;

with Sinfo.CN; use Sinfo.CN;

with Snames;   use Snames;

with Stringt;  use Stringt;

with Style;

with Stylesw;  use Stylesw;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

with Urealp;   use Urealp;

with Validsw;  use Validsw;

package body Sem_Ch6 is

   May_Hide_Profile : Boolean := False;

   --  This flag is used to indicate that two formals in two subprograms being

   --  checked for conformance differ only in that one is an access parameter

   --  while the other is of a general access type with the same designated

   --  type. In this case, if the rest of the signatures match, a call to

   --  either subprogram may be ambiguous, which is worth a warning. The flag

   --  is set in Compatible_Types, and the warning emitted in

   --  New_Overloaded_Entity.

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

   -- Local Subprograms --

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

   procedure Analyze_Return_Statement (N : Node_Id);

   --  Common processing for simple and extended return statements

   procedure Analyze_Function_Return (N : Node_Id);

   --  Subsidiary to Analyze_Return_Statement. Called when the return statement

   --  applies to a [generic] function.

   procedure Analyze_Return_Type (N : Node_Id);

   --  Subsidiary to Process_Formals: analyze subtype mark in function

   --  specification in a context where the formals are visible and hide

   --  outer homographs.

   procedure Analyze_Subprogram_Body_Helper (N : Node_Id);

   --  Does all the real work of Analyze_Subprogram_Body. This is split out so

   --  that we can use RETURN but not skip the debug output at the end.

   procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);

   --  Analyze a generic subprogram body. N is the body to be analyzed, and

   --  Gen_Id is the defining entity Id for the corresponding spec.

   procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id);

   --  If a subprogram has pragma Inline and inlining is active, use generic

   --  machinery to build an unexpanded body for the subprogram. This body is

   --  subsequently used for inline expansions at call sites. If subprogram can

   --  be inlined (depending on size and nature of local declarations) this

   --  function returns true. Otherwise subprogram body is treated normally.

   --  If proper warnings are enabled and the subprogram contains a construct

   --  that cannot be inlined, the offending construct is flagged accordingly.

   function Can_Override_Operator (Subp : Entity_Id) return Boolean;

   --  Returns true if Subp can override a predefined operator.

   procedure Check_Conformance

     (New_Id                   : Entity_Id;

      Old_Id                   : Entity_Id;

      Ctype                    : Conformance_Type;

      Errmsg                   : Boolean;

      Conforms                 : out Boolean;

      Err_Loc                  : Node_Id := Empty;

      Get_Inst                 : Boolean := False;

      Skip_Controlling_Formals : Boolean := False);

   --  Given two entities, this procedure checks that the profiles associated

   --  with these entities meet the conformance criterion given by the third

   --  parameter. If they conform, Conforms is set True and control returns

   --  to the caller. If they do not conform, Conforms is set to False, and

   --  in addition, if Errmsg is True on the call, proper messages are output

   --  to complain about the conformance failure. If Err_Loc is non_Empty

   --  the error messages are placed on Err_Loc, if Err_Loc is empty, then

   --  error messages are placed on the appropriate part of the construct

   --  denoted by New_Id. If Get_Inst is true, then this is a mode conformance

   --  against a formal access-to-subprogram type so Get_Instance_Of must

   --  be called.

   procedure Check_Subprogram_Order (N : Node_Id);

   --  N is the N_Subprogram_Body node for a subprogram. This routine applies

   --  the alpha ordering rule for N if this ordering requirement applicable.

   procedure Check_Returns

     (HSS  : Node_Id;

      Mode : Character;

      Err  : out Boolean;

      Proc : Entity_Id := Empty);

   --  Called to check for missing return statements in a function body, or for

   --  returns present in a procedure body which has No_Return set. HSS is the

   --  handled statement sequence for the subprogram body. This procedure

   --  checks all flow paths to make sure they either have return (Mode = 'F',

   --  used for functions) or do not have a return (Mode = 'P', used for

   --  No_Return procedures). The flag Err is set if there are any control

   --  paths not explicitly terminated by a return in the function case, and is

   --  True otherwise. Proc is the entity for the procedure case and is used

   --  in posting the warning message.

   procedure Check_Untagged_Equality (Eq_Op : Entity_Id);

   --  In Ada 2012, a primitive equality operator on an untagged record type

   --  must appear before the type is frozen, and have the same visibility as

   --  that of the type. This procedure checks that this rule is met, and

   --  otherwise emits an error on the subprogram declaration and a warning

   --  on the earlier freeze point if it is easy to locate.

   procedure Enter_Overloaded_Entity (S : Entity_Id);

   --  This procedure makes S, a new overloaded entity, into the first visible

   --  entity with that name.

   function Is_Non_Overriding_Operation

     (Prev_E : Entity_Id;

      New_E  : Entity_Id) return Boolean;

   --  Enforce the rule given in 12.3(18): a private operation in an instance

   --  overrides an inherited operation only if the corresponding operation

   --  was overriding in the generic. This needs to be checked for primitive

   --  operations of types derived (in the generic unit) from formal private

   --  or formal derived types.

   procedure Make_Inequality_Operator (S : Entity_Id);

   --  Create the declaration for an inequality operator that is implicitly

   --  created by a user-defined equality operator that yields a boolean.

   procedure May_Need_Actuals (Fun : Entity_Id);

   --  Flag functions that can be called without parameters, i.e. those that

   --  have no parameters, or those for which defaults exist for all parameters

   procedure Process_PPCs

     (N       : Node_Id;

      Spec_Id : Entity_Id;

      Body_Id : Entity_Id);

   --  Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post

   --  conditions for the body and assembling and inserting the _postconditions

   --  procedure. N is the node for the subprogram body and Body_Id/Spec_Id are

   --  the entities for the body and separate spec (if there is no separate

   --  spec, Spec_Id is Empty). Note that invariants and predicates may also

   --  provide postconditions, and are also handled in this procedure.

   procedure Set_Formal_Validity (Formal_Id : Entity_Id);

   --  Formal_Id is an formal parameter entity. This procedure deals with

   --  setting the proper validity status for this entity, which depends on

   --  the kind of parameter and the validity checking mode.

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

   -- Analyze_Abstract_Subprogram_Declaration --

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

   procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is

      Designator : constant Entity_Id :=

                     Analyze_Subprogram_Specification (Specification (N));

      Scop       : constant Entity_Id := Current_Scope;

   begin

      Check_SPARK_Restriction ("abstract subprogram is not allowed", N);

      Generate_Definition (Designator);

      Set_Contract (Designator, Make_Contract (Sloc (Designator)));

      Set_Is_Abstract_Subprogram (Designator);

      New_Overloaded_Entity (Designator);

      Check_Delayed_Subprogram (Designator);

      Set_Categorization_From_Scope (Designator, Scop);

      if Ekind (Scope (Designator)) = E_Protected_Type then

         Error_Msg_N

           ("abstract subprogram not allowed in protected type", N);

      --  Issue a warning if the abstract subprogram is neither a dispatching

      --  operation nor an operation that overrides an inherited subprogram or

      --  predefined operator, since this most likely indicates a mistake.

      elsif Warn_On_Redundant_Constructs

        and then not Is_Dispatching_Operation (Designator)

        and then not Present (Overridden_Operation (Designator))

        and then (not Is_Operator_Symbol_Name (Chars (Designator))

                   or else Scop /= Scope (Etype (First_Formal (Designator))))

      then

         Error_Msg_N

           ("?abstract subprogram is not dispatching or overriding", N);

      end if;

      Generate_Reference_To_Formals (Designator);

      Check_Eliminated (Designator);

      if Has_Aspects (N) then

         Analyze_Aspect_Specifications (N, Designator);

      end if;

   end Analyze_Abstract_Subprogram_Declaration;

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

   -- Analyze_Expression_Function --

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

   procedure Analyze_Expression_Function (N : Node_Id) is

      Loc      : constant Source_Ptr := Sloc (N);

      LocX     : constant Source_Ptr := Sloc (Expression (N));

      Expr     : constant Node_Id    := Expression (N);

      Spec     : constant Node_Id    := Specification (N);

      Def_Id :  Entity_Id;

      Prev :  Entity_Id;

      --  If the expression is a completion, Prev is the entity whose

      --  declaration is completed. Def_Id is needed to analyze the spec.

      New_Body : Node_Id;

      New_Decl : Node_Id;

      New_Spec : Node_Id;

      Ret      : Node_Id;

   begin

      --  This is one of the occasions on which we transform the tree during

      --  semantic analysis. If this is a completion, transform the expression

      --  function into an equivalent subprogram body, and analyze it.

      --  Expression functions are inlined unconditionally. The back-end will

      --  determine whether this is possible.

      Inline_Processing_Required := True;

      --  Create a specification for the generated body. Types and defauts in

      --  the profile are copies of the spec, but new entities must be created

      --  for the unit name and the formals.

      New_Spec := New_Copy_Tree (Spec);

      Set_Defining_Unit_Name (New_Spec,

        Make_Defining_Identifier (Sloc (Defining_Unit_Name (Spec)),

          Chars (Defining_Unit_Name (Spec))));

      if Present (Parameter_Specifications (New_Spec)) then

         declare

            Formal_Spec : Node_Id;

         begin

            Formal_Spec := First (Parameter_Specifications (New_Spec));

            while Present (Formal_Spec) loop

               Set_Defining_Identifier

                 (Formal_Spec,

                  Make_Defining_Identifier (Sloc (Formal_Spec),

                    Chars => Chars (Defining_Identifier (Formal_Spec))));

               Next (Formal_Spec);

            end loop;

         end;

      end if;

      Prev     := Current_Entity_In_Scope (Defining_Entity (Spec));

      --  If there are previous overloadable entities with the same name,

      --  check whether any of them is completed by the expression function.

      if Present (Prev) and then Is_Overloadable (Prev) then

         Def_Id   := Analyze_Subprogram_Specification (Spec);

         Prev     := Find_Corresponding_Spec (N);

      end if;

      Ret := Make_Simple_Return_Statement (LocX, Expression (N));

      New_Body :=

        Make_Subprogram_Body (Loc,

          Specification              => New_Spec,

          Declarations               => Empty_List,

          Handled_Statement_Sequence =>

            Make_Handled_Sequence_Of_Statements (LocX,

              Statements => New_List (Ret)));

      if Present (Prev) and then Ekind (Prev) = E_Generic_Function then

         --  If the expression completes a generic subprogram, we must create a

         --  separate node for the body, because at instantiation the original

         --  node of the generic copy must be a generic subprogram body, and

         --  cannot be a expression function. Otherwise we just rewrite the

         --  expression with the non-generic body.

         Insert_After (N, New_Body);

         Rewrite (N, Make_Null_Statement (Loc));

         Set_Has_Completion (Prev, False);

         Analyze (N);

         Analyze (New_Body);

         Set_Is_Inlined (Prev);

      elsif Present (Prev)

        and then Comes_From_Source (Prev)

      then

         Set_Has_Completion (Prev, False);

         --  For navigation purposes, indicate that the function is a body

         Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);

         Rewrite (N, New_Body);

         Analyze (N);

         --  Prev is the previous entity with the same name, but it is can

         --  be an unrelated spec that is not completed by the expression

         --  function. In that case the relevant entity is the one in the body.

         --  Not clear that the backend can inline it in this case ???

         if Has_Completion (Prev) then

            Set_Is_Inlined (Prev);

            --  The formals of the expression function are body formals,

            --  and do not appear in the ali file, which will only contain

            --  references to the formals of the original subprogram spec.

            declare

               F1 : Entity_Id;

               F2 : Entity_Id;

            begin

               F1 := First_Formal (Def_Id);

               F2 := First_Formal (Prev);

               while Present (F1) loop

                  Set_Spec_Entity (F1, F2);

                  Next_Formal (F1);

                  Next_Formal (F2);

               end loop;

            end;

         else

            Set_Is_Inlined (Defining_Entity (New_Body));

         end if;

      --  If this is not a completion, create both a declaration and a body, so

      --  that the expression can be inlined whenever possible.

      else

         New_Decl :=

           Make_Subprogram_Declaration (Loc, Specification => Spec);

         Rewrite (N, New_Decl);

         Analyze (N);

         Set_Is_Inlined (Defining_Entity (New_Decl));

         --  To prevent premature freeze action, insert the new body at the end

         --  of the current declarations, or at the end of the package spec.

         --  However, resolve usage names now, to prevent spurious visibility

         --  on later entities.

         declare

            Decls : List_Id            := List_Containing (N);

            Par   : constant Node_Id   := Parent (Decls);

            Id    : constant Entity_Id := Defining_Entity (New_Decl);

         begin

            if Nkind (Par) = N_Package_Specification

               and then Decls = Visible_Declarations (Par)

               and then Present (Private_Declarations (Par))

               and then not Is_Empty_List (Private_Declarations (Par))

            then

               Decls := Private_Declarations (Par);

            end if;

            Insert_After (Last (Decls), New_Body);

            Push_Scope (Id);

            Install_Formals (Id);

            Preanalyze_Spec_Expression (Expression  (Ret), Etype (Id));

            End_Scope;

         end;

      end if;

      --  If the return expression is a static constant, we suppress warning

      --  messages on unused formals, which in most cases will be noise.

      Set_Is_Trivial_Subprogram (Defining_Entity (New_Body),

        Is_OK_Static_Expression (Expr));

   end Analyze_Expression_Function;

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

   -- Analyze_Extended_Return_Statement  --

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

   procedure Analyze_Extended_Return_Statement (N : Node_Id) is

   begin

      Analyze_Return_Statement (N);

   end Analyze_Extended_Return_Statement;

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

   -- Analyze_Function_Call  --

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

   procedure Analyze_Function_Call (N : Node_Id) is

      P       : constant Node_Id := Name (N);

      Actuals : constant List_Id := Parameter_Associations (N);

      Actual  : Node_Id;

   begin

      Analyze (P);

      --  A call of the form A.B (X) may be an Ada 2005 call, which is

      --  rewritten as B (A, X). If the rewriting is successful, the call

      --  has been analyzed and we just return.

      if Nkind (P) = N_Selected_Component

        and then Name (N) /= P

        and then Is_Rewrite_Substitution (N)

        and then Present (Etype (N))

      then

         return;

      end if;

      --  If error analyzing name, then set Any_Type as result type and return

      if Etype (P) = Any_Type then

         Set_Etype (N, Any_Type);

         return;

      end if;

      --  Otherwise analyze the parameters

      if Present (Actuals) then

         Actual := First (Actuals);

         while Present (Actual) loop

            Analyze (Actual);

            Check_Parameterless_Call (Actual);

            Next (Actual);

         end loop;

      end if;

      Analyze_Call (N);

   end Analyze_Function_Call;

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

   -- Analyze_Function_Return --

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

   procedure Analyze_Function_Return (N : Node_Id) is

      Loc        : constant Source_Ptr  := Sloc (N);

      Stm_Entity : constant Entity_Id   := Return_Statement_Entity (N);

      Scope_Id   : constant Entity_Id   := Return_Applies_To (Stm_Entity);

      R_Type : constant Entity_Id := Etype (Scope_Id);

      --  Function result subtype

      procedure Check_Limited_Return (Expr : Node_Id);

      --  Check the appropriate (Ada 95 or Ada 2005) rules for returning

      --  limited types. Used only for simple return statements.

      --  Expr is the expression returned.

      procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);

      --  Check that the return_subtype_indication properly matches the result

      --  subtype of the function, as required by RM-6.5(5.1/2-5.3/2).

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

      -- Check_Limited_Return --

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

      procedure Check_Limited_Return (Expr : Node_Id) is

      begin

         --  Ada 2005 (AI-318-02): Return-by-reference types have been

         --  removed and replaced by anonymous access results. This is an

         --  incompatibility with Ada 95. Not clear whether this should be

         --  enforced yet or perhaps controllable with special switch. ???

         --  A limited interface that is not immutably limited is OK.

         if Is_Limited_Interface (R_Type)

           and then

             not (Is_Task_Interface (R_Type)

                   or else Is_Protected_Interface (R_Type)

                   or else Is_Synchronized_Interface (R_Type))

         then

            null;

         elsif Is_Limited_Type (R_Type)

           and then not Is_Interface (R_Type)

           and then Comes_From_Source (N)

           and then not In_Instance_Body

           and then not OK_For_Limited_Init_In_05 (R_Type, Expr)

         then

            --  Error in Ada 2005

            if Ada_Version >= Ada_2005

              and then not Debug_Flag_Dot_L

              and then not GNAT_Mode

            then

               Error_Msg_N

                 ("(Ada 2005) cannot copy object of a limited type " &

                  "(RM-2005 6.5(5.5/2))", Expr);

               if Is_Immutably_Limited_Type (R_Type) then

                  Error_Msg_N

                    ("\return by reference not permitted in Ada 2005", Expr);

               end if;

            --  Warn in Ada 95 mode, to give folks a heads up about this

            --  incompatibility.

            --  In GNAT mode, this is just a warning, to allow it to be

            --  evilly turned off. Otherwise it is a real error.

            --  In a generic context, simplify the warning because it makes

            --  no sense to discuss pass-by-reference or copy.

            elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then

               if Inside_A_Generic then

                  Error_Msg_N

                    ("return of limited object not permitted in Ada 2005 "

                     & "(RM-2005 6.5(5.5/2))?", Expr);

               elsif Is_Immutably_Limited_Type (R_Type) then

                  Error_Msg_N

                    ("return by reference not permitted in Ada 2005 "

                     & "(RM-2005 6.5(5.5/2))?", Expr);

               else

                  Error_Msg_N

                    ("cannot copy object of a limited type in Ada 2005 "

                     & "(RM-2005 6.5(5.5/2))?", Expr);

               end if;

            --  Ada 95 mode, compatibility warnings disabled

            else

               return; --  skip continuation messages below

            end if;

            if not Inside_A_Generic then

               Error_Msg_N

                 ("\consider switching to return of access type", Expr);

               Explain_Limited_Type (R_Type, Expr);

            end if;

         end if;

      end Check_Limited_Return;

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

      -- Check_Return_Subtype_Indication --

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

      procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is

         Return_Obj : constant Node_Id   := Defining_Identifier (Obj_Decl);

         R_Stm_Type : constant Entity_Id := Etype (Return_Obj);

         --  Subtype given in the extended return statement (must match R_Type)

         Subtype_Ind : constant Node_Id :=

                         Object_Definition (Original_Node (Obj_Decl));

         R_Type_Is_Anon_Access :

           constant Boolean :=

             Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type

               or else

             Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type

               or else

             Ekind (R_Type) = E_Anonymous_Access_Type;

         --  True if return type of the function is an anonymous access type

         --  Can't we make Is_Anonymous_Access_Type in einfo ???

         R_Stm_Type_Is_Anon_Access :

           constant Boolean :=

             Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type

               or else

             Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type

               or else

             Ekind (R_Stm_Type) = E_Anonymous_Access_Type;

         --  True if type of the return object is an anonymous access type

      begin

         --  First, avoid cascaded errors

         if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then

            return;

         end if;

         --  "return access T" case; check that the return statement also has

         --  "access T", and that the subtypes statically match:

         --   if this is an access to subprogram the signatures must match.

         if R_Type_Is_Anon_Access then

            if R_Stm_Type_Is_Anon_Access then

               if

                 Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type

               then

                  if Base_Type (Designated_Type (R_Stm_Type)) /=

                     Base_Type (Designated_Type (R_Type))

                    or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)

                  then

                     Error_Msg_N

                      ("subtype must statically match function result subtype",

                       Subtype_Mark (Subtype_Ind));

                  end if;

               else

                  --  For two anonymous access to subprogram types, the

                  --  types themselves must be type conformant.

                  if not Conforming_Types

                    (R_Stm_Type, R_Type, Fully_Conformant)

                  then

                     Error_Msg_N

                      ("subtype must statically match function result subtype",

                         Subtype_Ind);

                  end if;

               end if;

            else

               Error_Msg_N ("must use anonymous access type", Subtype_Ind);

            end if;

         --  If the return object is of an anonymous access type, then report

         --  an error if the function's result type is not also anonymous.

         elsif R_Stm_Type_Is_Anon_Access

           and then not R_Type_Is_Anon_Access

         then

            Error_Msg_N ("anonymous access not allowed for function with " &

                         "named access result", Subtype_Ind);

         --  Subtype indication case: check that the return object's type is

         --  covered by the result type, and that the subtypes statically match

         --  when the result subtype is constrained. Also handle record types

         --  with unknown discriminants for which we have built the underlying

         --  record view. Coverage is needed to allow specific-type return

         --  objects when the result type is class-wide (see AI05-32).

         elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type))

           or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type))

                     and then

                       Covers

                         (Base_Type (R_Type),

                          Underlying_Record_View (Base_Type (R_Stm_Type))))

         then

            --  A null exclusion may be present on the return type, on the

            --  function specification, on the object declaration or on the

            --  subtype itself.

            if Is_Access_Type (R_Type)

              and then

               (Can_Never_Be_Null (R_Type)

                 or else Null_Exclusion_Present (Parent (Scope_Id))) /=

                                              Can_Never_Be_Null (R_Stm_Type)

            then

               Error_Msg_N

                 ("subtype must statically match function result subtype",

                  Subtype_Ind);

            end if;

            --  AI05-103: for elementary types, subtypes must statically match

            if Is_Constrained (R_Type)

              or else Is_Access_Type (R_Type)

            then

               if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then

                  Error_Msg_N

                    ("subtype must statically match function result subtype",

                     Subtype_Ind);

               end if;

            end if;

         elsif Etype (Base_Type (R_Type)) = R_Stm_Type

           and then Is_Null_Extension (Base_Type (R_Type))

         then

            null;

         else

            Error_Msg_N

              ("wrong type for return_subtype_indication", Subtype_Ind);

         end if;

      end Check_Return_Subtype_Indication;

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

      -- Local Variables --

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

      Expr : Node_Id;

   --  Start of processing for Analyze_Function_Return

   begin

      Set_Return_Present (Scope_Id);

      if Nkind (N) = N_Simple_Return_Statement then

         Expr := Expression (N);

         --  Guard against a malformed expression. The parser may have tried to

         --  recover but the node is not analyzable.

         if Nkind (Expr) = N_Error then

            Set_Etype (Expr, Any_Type);

            Expander_Mode_Save_And_Set (False);

            return;

         else

            --  The resolution of a controlled [extension] aggregate associated

            --  with a return statement creates a temporary which needs to be

            --  finalized on function exit. Wrap the return statement inside a

            --  block so that the finalization machinery can detect this case.

            --  This early expansion is done only when the return statement is

            --  not part of a handled sequence of statements.

            if Nkind_In (Expr, N_Aggregate,

                               N_Extension_Aggregate)

              and then Needs_Finalization (R_Type)

              and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements

            then

               Rewrite (N,

                 Make_Block_Statement (Loc,

                   Handled_Statement_Sequence =>

                     Make_Handled_Sequence_Of_Statements (Loc,

                       Statements => New_List (Relocate_Node (N)))));