Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S E M _ C H 6                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, 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_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 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

   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.

   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 Enter_Overloaded_Entity (S : Entity_Id);

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

   --  entity with that name.

   procedure Install_Entity (E : Entity_Id);

   --  Make single entity visible. Used for generic formals as well

   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 can happen 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).

   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_Return_Statement --

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

   procedure Analyze_Return_Statement (N : Node_Id) is

      pragma Assert (Nkind_In (N, N_Simple_Return_Statement,

                                  N_Extended_Return_Statement));

      Returns_Object : constant Boolean :=

                         Nkind (N) = N_Extended_Return_Statement

                           or else

                            (Nkind (N) = N_Simple_Return_Statement

                              and then Present (Expression (N)));

      --  True if we're returning something; that is, "return <expression>;"

      --  or "return Result : T [:= ...]". False for "return;". Used for error

      --  checking: If Returns_Object is True, N should apply to a function

      --  body; otherwise N should apply to a procedure body, entry body,

      --  accept statement, or extended return statement.

      function Find_What_It_Applies_To return Entity_Id;

      --  Find the entity representing the innermost enclosing body, accept

      --  statement, or extended return statement. If the result is a callable

      --  construct or extended return statement, then this will be the value

      --  of the Return_Applies_To attribute. Otherwise, the program is

      --  illegal. See RM-6.5(4/2).

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

      -- Find_What_It_Applies_To --

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

      function Find_What_It_Applies_To return Entity_Id is

         Result : Entity_Id := Empty;

      begin

         --  Loop outward through the Scope_Stack, skipping blocks and loops

         for J in reverse 0 .. Scope_Stack.Last loop

            Result := Scope_Stack.Table (J).Entity;

            exit when Ekind (Result) /= E_Block and then

                      Ekind (Result) /= E_Loop;

         end loop;

         pragma Assert (Present (Result));

         return Result;

      end Find_What_It_Applies_To;

      --  Local declarations

      Scope_Id   : constant Entity_Id   := Find_What_It_Applies_To;

      Kind       : constant Entity_Kind := Ekind (Scope_Id);

      Loc        : constant Source_Ptr  := Sloc (N);

      Stm_Entity : constant Entity_Id   :=

                     New_Internal_Entity

                       (E_Return_Statement, Current_Scope, Loc, 'R');

   --  Start of processing for Analyze_Return_Statement

   begin

      Set_Return_Statement_Entity (N, Stm_Entity);

      Set_Etype (Stm_Entity, Standard_Void_Type);

      Set_Return_Applies_To (Stm_Entity, Scope_Id);

      --  Place Return entity on scope stack, to simplify enforcement of 6.5

      --  (4/2): an inner return statement will apply to this extended return.

      if Nkind (N) = N_Extended_Return_Statement then

         Push_Scope (Stm_Entity);

      end if;

      --  Check that pragma No_Return is obeyed. Don't complain about the

      --  implicitly-generated return that is placed at the end.

      if No_Return (Scope_Id) and then Comes_From_Source (N) then

         Error_Msg_N ("RETURN statement not allowed (No_Return)", N);

      end if;

      --  Warn on any unassigned OUT parameters if in procedure

      if Ekind (Scope_Id) = E_Procedure then

         Warn_On_Unassigned_Out_Parameter (N, Scope_Id);

      end if;

      --  Check that functions return objects, and other things do not

      if Kind = E_Function or else Kind = E_Generic_Function then

         if not Returns_Object then

            Error_Msg_N ("missing expression in return from function", N);

         end if;

      elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then

         if Returns_Object then

            Error_Msg_N ("procedure cannot return value (use function)", N);

         end if;

      elsif Kind = E_Entry or else Kind = E_Entry_Family then

         if Returns_Object then

            if Is_Protected_Type (Scope (Scope_Id)) then

               Error_Msg_N ("entry body cannot return value", N);

            else

               Error_Msg_N ("accept statement cannot return value", N);

            end if;

         end if;

      elsif Kind = E_Return_Statement then

         --  We are nested within another return statement, which must be an

         --  extended_return_statement.

         if Returns_Object then

            Error_Msg_N

              ("extended_return_statement cannot return value; " &

               "use `""RETURN;""`", N);

         end if;

      else

         Error_Msg_N ("illegal context for return statement", N);

      end if;

      if Kind = E_Function or else Kind = E_Generic_Function then

         Analyze_Function_Return (N);

      end if;

      if Nkind (N) = N_Extended_Return_Statement then

         End_Scope;

      end if;

      Kill_Current_Values (Last_Assignment_Only => True);

      Check_Unreachable_Code (N);

   end Analyze_Return_Statement;

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

   -- 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

      Generate_Definition (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 Is_Overriding_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);

   end Analyze_Abstract_Subprogram_Declaration;

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

   -- 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);

      L      : constant List_Id := Parameter_Associations (N);

      Actual : Node_Id;

   begin

      Analyze (P);

      --  A call of the form A.B (X) may be an Ada05 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 (L) then

         Actual := First (L);

         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. ???

         if Is_Limited_Type (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_05

              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_Inherently_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.

            elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then

               if Is_Inherently_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;

            Error_Msg_N

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

            Explain_Limited_Type (R_Type, Expr);

         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;

         --  this 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 cascade 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;

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

            if Is_Constrained (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);

         Analyze_And_Resolve (Expr, R_Type);

         Check_Limited_Return (Expr);

      else

         --  Analyze parts specific to extended_return_statement:

         declare

            Obj_Decl : constant Node_Id :=

                         Last (Return_Object_Declarations (N));

            HSS : constant Node_Id := Handled_Statement_Sequence (N);

         begin

            Expr := Expression (Obj_Decl);

            --  Note: The check for OK_For_Limited_Init will happen in

            --  Analyze_Object_Declaration; we treat it as a normal

            --  object declaration.

            Set_Is_Return_Object (Defining_Identifier (Obj_Decl));

            Analyze (Obj_Decl);

            Check_Return_Subtype_Indication (Obj_Decl);

            if Present (HSS) then

               Analyze (HSS);

               if Present (Exception_Handlers (HSS)) then

                  --  ???Has_Nested_Block_With_Handler needs to be set.

                  --  Probably by creating an actual N_Block_Statement.

                  --  Probably in Expand.

                  null;

               end if;

            end if;

            --  Mark the return object as referenced, since the return is an

            --  implicit reference of the object.

            Set_Referenced (Defining_Identifier (Obj_Decl));

            Check_References (Stm_Entity);

         end;

      end if;

      --  Case of Expr present

      if Present (Expr)

         --  Defend against previous errors

        and then Nkind (Expr) /= N_Empty

        and then Present (Etype (Expr))

      then

         --  Apply constraint check. Note that this is done before the implicit

         --  conversion of the expression done for anonymous access types to

         --  ensure correct generation of the null-excluding check associated

         --  with null-excluding expressions found in return statements.

         Apply_Constraint_Check (Expr, R_Type);

         --  Ada 2005 (AI-318-02): When the result type is an anonymous access

         --  type, apply an implicit conversion of the expression to that type

         --  to force appropriate static and run-time accessibility checks.

         if Ada_Version >= Ada_05

           and then Ekind (R_Type) = E_Anonymous_Access_Type

         then

            Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));

            Analyze_And_Resolve (Expr, R_Type);

         end if;

         --  If the result type is class-wide, then check that the return

         --  expression's type is not declared at a deeper level than the

         --  function (RM05-6.5(5.6/2)).

         if Ada_Version >= Ada_05

           and then Is_Class_Wide_Type (R_Type)

         then

            if Type_Access_Level (Etype (Expr)) >

                 Subprogram_Access_Level (Scope_Id)

            then

               Error_Msg_N

                 ("level of return expression type is deeper than " &

                  "class-wide function!", Expr);

            end if;

         end if;

         --  Check incorrect use of dynamically tagged expression

         if Is_Tagged_Type (R_Type) then

            Check_Dynamically_Tagged_Expression

              (Expr => Expr,

               Typ  => R_Type,

               Related_Nod => N);

         end if;

         --  ??? A real run-time accessibility check is needed in cases

         --  involving dereferences of access parameters. For now we just

         --  check the static cases.

         if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)

           and then Is_Inherently_Limited_Type (Etype (Scope_Id))

           and then Object_Access_Level (Expr) >

                      Subprogram_Access_Level (Scope_Id)

         then

            Rewrite (N,

              Make_Raise_Program_Error (Loc,

                Reason => PE_Accessibility_Check_Failed));

            Analyze (N);

            Error_Msg_N

              ("cannot return a local value by reference?", N);

            Error_Msg_NE

              ("\& will be raised at run time?",

               N, Standard_Program_Error);

         end if;

         if Known_Null (Expr)

           and then Nkind (Parent (Scope_Id)) = N_Function_Specification

           and then Null_Exclusion_Present (Parent (Scope_Id))

         then

            Apply_Compile_Time_Constraint_Error

              (N      => Expr,

               Msg    => "(Ada 2005) null not allowed for "