Subversion Repositories scarts

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              S E M _ C H 6                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, 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 2,  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 COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- 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_Ch7;  use Exp_Ch7;

with Exp_Tss;  use Exp_Tss;

with Fname;    use Fname;

with Freeze;   use Freeze;

with Itypes;   use Itypes;

with Lib.Xref; use Lib.Xref;

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

with Sem;      use Sem;

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

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

   -- Local Subprograms --

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

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

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

   type Conformance_Type is

     (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);

   --  Conformance type used for following call, meaning matches the

   --  RM definitions of the corresponding terms.

   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_Overriding_Indicator

     (Subp          : Entity_Id;

      Does_Override : Boolean);

   --  Verify the consistency of an overriding_indicator given for subprogram

   --  declaration, body, renaming, or instantiation. The flag Does_Override

   --  is set if the scope into which we are introducing the subprogram

   --  contains a type-conformant subprogram that becomes hidden by the new

   --  subprogram.

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

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

   --  for returns present in a procedure body which has No_Return set. L is

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

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

   --  or do not have a return (Mode = 'P'). 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.

   function Conforming_Types

     (T1       : Entity_Id;

      T2       : Entity_Id;

      Ctype    : Conformance_Type;

      Get_Inst : Boolean := False) return Boolean;

   --  Check that two formal parameter types conform, checking both for

   --  equality of base types, and where required statically matching

   --  subtypes, depending on the setting of Ctype.

   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

   procedure Install_Formals (Id : Entity_Id);

   --  On entry to a subprogram body, make the formals visible. Note that

   --  simply placing the subprogram on the scope stack is not sufficient:

   --  the formals must become the current entities for their names.

   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 Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);

   --  If there is a separate spec for a subprogram or generic subprogram, the

   --  formals of the body are treated as references to the corresponding

   --  formals of the spec. This reference does not count as an actual use of

   --  the formal, in order to diagnose formals that are unused in the body.

   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

      Generate_Definition (Designator);

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

      end if;

      Generate_Reference_To_Formals (Designator);

   end Analyze_Abstract_Subprogram_Declaration;

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

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

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

   procedure Analyze_Generic_Subprogram_Body

     (N      : Node_Id;

      Gen_Id : Entity_Id)

   is

      Gen_Decl : constant Node_Id     := Unit_Declaration_Node (Gen_Id);

      Kind     : constant Entity_Kind := Ekind (Gen_Id);

      Body_Id  : Entity_Id;

      New_N    : Node_Id;

      Spec     : Node_Id;

   begin

      --  Copy body and disable expansion while analyzing the generic For a

      --  stub, do not copy the stub (which would load the proper body), this

      --  will be done when the proper body is analyzed.

      if Nkind (N) /= N_Subprogram_Body_Stub then

         New_N := Copy_Generic_Node (N, Empty, Instantiating => False);

         Rewrite (N, New_N);

         Start_Generic;

      end if;

      Spec := Specification (N);

      --  Within the body of the generic, the subprogram is callable, and

      --  behaves like the corresponding non-generic unit.

      Body_Id := Defining_Entity (Spec);

      if Kind = E_Generic_Procedure

        and then Nkind (Spec) /= N_Procedure_Specification

      then

         Error_Msg_N ("invalid body for generic procedure ", Body_Id);

         return;

      elsif Kind = E_Generic_Function

        and then Nkind (Spec) /= N_Function_Specification

      then

         Error_Msg_N ("invalid body for generic function ", Body_Id);

         return;

      end if;

      Set_Corresponding_Body (Gen_Decl, Body_Id);

      if Has_Completion (Gen_Id)

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

      then

         Error_Msg_N ("duplicate generic body", N);

         return;

      else

         Set_Has_Completion (Gen_Id);

      end if;

      if Nkind (N) = N_Subprogram_Body_Stub then

         Set_Ekind (Defining_Entity (Specification (N)), Kind);

      else

         Set_Corresponding_Spec (N, Gen_Id);

      end if;

      if Nkind (Parent (N)) = N_Compilation_Unit then

         Set_Cunit_Entity (Current_Sem_Unit, Defining_Entity (N));

      end if;

      --  Make generic parameters immediately visible in the body. They are

      --  needed to process the formals declarations. Then make the formals

      --  visible in a separate step.

      New_Scope (Gen_Id);

      declare

         E         : Entity_Id;

         First_Ent : Entity_Id;

      begin

         First_Ent := First_Entity (Gen_Id);

         E := First_Ent;

         while Present (E) and then not Is_Formal (E) loop

            Install_Entity (E);

            Next_Entity (E);

         end loop;

         Set_Use (Generic_Formal_Declarations (Gen_Decl));

         --  Now generic formals are visible, and the specification can be

         --  analyzed, for subsequent conformance check.

         Body_Id := Analyze_Subprogram_Specification (Spec);

         --  Make formal parameters visible

         if Present (E) then

            --  E is the first formal parameter, we loop through the formals

            --  installing them so that they will be visible.

            Set_First_Entity (Gen_Id, E);

            while Present (E) loop

               Install_Entity (E);

               Next_Formal (E);

            end loop;

         end if;

         --  Visible generic entity is callable within its own body

         Set_Ekind (Gen_Id, Ekind (Body_Id));

         Set_Ekind (Body_Id, E_Subprogram_Body);

         Set_Convention (Body_Id, Convention (Gen_Id));

         Set_Scope (Body_Id, Scope (Gen_Id));

         Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);

         if Nkind (N) = N_Subprogram_Body_Stub then

            --  No body to analyze, so restore state of generic unit

            Set_Ekind (Gen_Id, Kind);

            Set_Ekind (Body_Id, Kind);

            if Present (First_Ent) then

               Set_First_Entity (Gen_Id, First_Ent);

            end if;

            End_Scope;

            return;

         end if;

         --  If this is a compilation unit, it must be made visible explicitly,

         --  because the compilation of the declaration, unlike other library

         --  unit declarations, does not. If it is not a unit, the following

         --  is redundant but harmless.

         Set_Is_Immediately_Visible (Gen_Id);

         Reference_Body_Formals (Gen_Id, Body_Id);

         Set_Actual_Subtypes (N, Current_Scope);

         Analyze_Declarations (Declarations (N));

         Check_Completion;

         Analyze (Handled_Statement_Sequence (N));

         Save_Global_References (Original_Node (N));

         --  Prior to exiting the scope, include generic formals again (if any

         --  are present) in the set of local entities.

         if Present (First_Ent) then

            Set_First_Entity (Gen_Id, First_Ent);

         end if;

         Check_References (Gen_Id);

      end;

      Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);

      End_Scope;

      Check_Subprogram_Order (N);

      --  Outside of its body, unit is generic again

      Set_Ekind (Gen_Id, Kind);

      Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);

      Style.Check_Identifier (Body_Id, Gen_Id);

      End_Generic;

   end Analyze_Generic_Subprogram_Body;

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

   -- Analyze_Operator_Symbol --

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

   --  An operator symbol such as "+" or "and" may appear in context where the

   --  literal denotes an entity name, such as "+"(x, y) or in context when it

   --  is just a string, as in (conjunction = "or"). In these cases the parser

   --  generates this node, and the semantics does the disambiguation. Other

   --  such case are actuals in an instantiation, the generic unit in an

   --  instantiation, and pragma arguments.

   procedure Analyze_Operator_Symbol (N : Node_Id) is

      Par : constant Node_Id := Parent (N);

   begin

      if        (Nkind (Par) = N_Function_Call and then N = Name (Par))

        or else  Nkind (Par) = N_Function_Instantiation

        or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))

        or else (Nkind (Par) = N_Pragma_Argument_Association

                   and then not Is_Pragma_String_Literal (Par))

        or else  Nkind (Par) = N_Subprogram_Renaming_Declaration

        or else  (Nkind (Par) = N_Attribute_Reference

                   and then Attribute_Name (Par) /= Name_Value)

      then

         Find_Direct_Name (N);

      else

         Change_Operator_Symbol_To_String_Literal (N);

         Analyze (N);

      end if;

   end Analyze_Operator_Symbol;

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

   -- Analyze_Parameter_Association --

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

   procedure Analyze_Parameter_Association (N : Node_Id) is

   begin

      Analyze (Explicit_Actual_Parameter (N));

   end Analyze_Parameter_Association;

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

   -- Analyze_Procedure_Call --

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

   procedure Analyze_Procedure_Call (N : Node_Id) is

      Loc     : constant Source_Ptr := Sloc (N);

      P       : constant Node_Id    := Name (N);

      Actuals : constant List_Id    := Parameter_Associations (N);

      Actual  : Node_Id;

      New_N   : Node_Id;

      procedure Analyze_Call_And_Resolve;

      --  Do Analyze and Resolve calls for procedure call

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

      -- Analyze_Call_And_Resolve --

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

      procedure Analyze_Call_And_Resolve is

      begin

         if Nkind (N) = N_Procedure_Call_Statement then

            Analyze_Call (N);

            Resolve (N, Standard_Void_Type);

         else

            Analyze (N);

         end if;

      end Analyze_Call_And_Resolve;

   --  Start of processing for Analyze_Procedure_Call

   begin

      --  The syntactic construct: PREFIX ACTUAL_PARAMETER_PART can denote

      --  a procedure call or an entry call. The prefix may denote an access

      --  to subprogram type, in which case an implicit dereference applies.

      --  If the prefix is an indexed component (without implicit defererence)

      --  then the construct denotes a call to a member of an entire family.

      --  If the prefix is a simple name, it may still denote a call to a

      --  parameterless member of an entry family. Resolution of these various

      --  interpretations is delicate.

      Analyze (P);

      --  If this is a call of the form Obj.Op, the call may have been

      --  analyzed and possibly rewritten into a block, in which case

      --  we are done.

      if Analyzed (N) then

         return;

      end if;

      --  If error analyzing prefix, then set Any_Type as result 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;

      --  Special processing for Elab_Spec and Elab_Body calls

      if Nkind (P) = N_Attribute_Reference

        and then (Attribute_Name (P) = Name_Elab_Spec

                   or else Attribute_Name (P) = Name_Elab_Body)

      then

         if Present (Actuals) then

            Error_Msg_N

              ("no parameters allowed for this call", First (Actuals));

            return;

         end if;

         Set_Etype (N, Standard_Void_Type);

         Set_Analyzed (N);

      elsif Is_Entity_Name (P)

        and then Is_Record_Type (Etype (Entity (P)))

        and then Remote_AST_I_Dereference (P)

      then

         return;

      elsif Is_Entity_Name (P)

        and then Ekind (Entity (P)) /= E_Entry_Family

      then

         if Is_Access_Type (Etype (P))

           and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type

           and then No (Actuals)

           and then Comes_From_Source (N)

         then

            Error_Msg_N ("missing explicit dereference in call", N);

         end if;

         Analyze_Call_And_Resolve;

      --  If the prefix is the simple name of an entry family, this is

      --  a parameterless call from within the task body itself.

      elsif Is_Entity_Name (P)

        and then Nkind (P) = N_Identifier

        and then Ekind (Entity (P)) = E_Entry_Family

        and then Present (Actuals)

        and then No (Next (First (Actuals)))

      then

         --  Can be call to parameterless entry family. What appears to be the

         --  sole argument is in fact the entry index. Rewrite prefix of node

         --  accordingly. Source representation is unchanged by this

         --  transformation.

         New_N :=

           Make_Indexed_Component (Loc,

             Prefix =>

               Make_Selected_Component (Loc,

                 Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),

                 Selector_Name => New_Occurrence_Of (Entity (P), Loc)),

             Expressions => Actuals);

         Set_Name (N, New_N);

         Set_Etype (New_N, Standard_Void_Type);

         Set_Parameter_Associations (N, No_List);

         Analyze_Call_And_Resolve;

      elsif Nkind (P) = N_Explicit_Dereference then

         if Ekind (Etype (P)) = E_Subprogram_Type then

            Analyze_Call_And_Resolve;

         else

            Error_Msg_N ("expect access to procedure in call", P);

         end if;

      --  The name can be a selected component or an indexed component that

      --  yields an access to subprogram. Such a prefix is legal if the call

      --  has parameter associations.

      elsif Is_Access_Type (Etype (P))

        and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type

      then

         if Present (Actuals) then

            Analyze_Call_And_Resolve;

         else

            Error_Msg_N ("missing explicit dereference in call ", N);

         end if;

      --  If not an access to subprogram, then the prefix must resolve to the

      --  name of an entry, entry family, or protected operation.

      --  For the case of a simple entry call, P is a selected component where

      --  the prefix is the task and the selector name is the entry. A call to

      --  a protected procedure will have the same syntax. If the protected

      --  object contains overloaded operations, the entity may appear as a

      --  function, the context will select the operation whose type is Void.

      elsif Nkind (P) = N_Selected_Component

        and then (Ekind (Entity (Selector_Name (P))) = E_Entry

                    or else

                  Ekind (Entity (Selector_Name (P))) = E_Procedure

                    or else

                  Ekind (Entity (Selector_Name (P))) = E_Function)

      then

         Analyze_Call_And_Resolve;

      elsif Nkind (P) = N_Selected_Component

        and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family

        and then Present (Actuals)

        and then No (Next (First (Actuals)))

      then

         --  Can be call to parameterless entry family. What appears to be the

         --  sole argument is in fact the entry index. Rewrite prefix of node

         --  accordingly. Source representation is unchanged by this

         --  transformation.

         New_N :=

           Make_Indexed_Component (Loc,

             Prefix => New_Copy (P),

             Expressions => Actuals);

         Set_Name (N, New_N);

         Set_Etype (New_N, Standard_Void_Type);

         Set_Parameter_Associations (N, No_List);

         Analyze_Call_And_Resolve;

      --  For the case of a reference to an element of an entry family, P is

      --  an indexed component whose prefix is a selected component (task and

      --  entry family), and whose index is the entry family index.

      elsif Nkind (P) = N_Indexed_Component

        and then Nkind (Prefix (P)) = N_Selected_Component

        and then Ekind (Entity (Selector_Name (Prefix (P)))) = E_Entry_Family

      then

         Analyze_Call_And_Resolve;

      --  If the prefix is the name of an entry family, it is a call from

      --  within the task body itself.

      elsif Nkind (P) = N_Indexed_Component

        and then Nkind (Prefix (P)) = N_Identifier

        and then Ekind (Entity (Prefix (P))) = E_Entry_Family

      then

         New_N :=

           Make_Selected_Component (Loc,

             Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),

             Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));

         Rewrite (Prefix (P), New_N);

         Analyze (P);

         Analyze_Call_And_Resolve;

      --  Anything else is an error

      else

         Error_Msg_N ("invalid procedure or entry call", N);

      end if;

   end Analyze_Procedure_Call;

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

   -- Analyze_Return_Statement --

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

   procedure Analyze_Return_Statement (N : Node_Id) is

      Loc      : constant Source_Ptr := Sloc (N);

      Expr     : Node_Id;

      Scope_Id : Entity_Id;

      Kind     : Entity_Kind;

      R_Type   : Entity_Id;

   begin

      --  Find subprogram or accept statement enclosing the return statement

      Scope_Id := Empty;

      for J in reverse 0 .. Scope_Stack.Last loop

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

         exit when Ekind (Scope_Id) /= E_Block and then

                   Ekind (Scope_Id) /= E_Loop;

      end loop;

      pragma Assert (Present (Scope_Id));

      Kind := Ekind (Scope_Id);

      Expr := Expression (N);

      if Kind /= E_Function

        and then Kind /= E_Generic_Function

        and then Kind /= E_Procedure

        and then Kind /= E_Generic_Procedure

        and then Kind /= E_Entry

        and then Kind /= E_Entry_Family

      then

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

      elsif Present (Expr) then

         if Kind = E_Function or else Kind = E_Generic_Function then

            Set_Return_Present (Scope_Id);

            R_Type := Etype (Scope_Id);

            Set_Return_Type (N, R_Type);

            Analyze_And_Resolve (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 (Is_Class_Wide_Type (Etype (Expr))

                 or else Is_Dynamically_Tagged (Expr))

              and then not Is_Class_Wide_Type (R_Type)

            then

               Error_Msg_N

                 ("dynamically tagged expression not allowed!", Expr);

            end if;

            Apply_Constraint_Check (Expr, R_Type);

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

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