+ -----------------------------
+ -- 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 (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 R_Type_Is_Anon_Access then
+ if R_Stm_Type_Is_Anon_Access 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
+ Error_Msg_N ("must use anonymous access type", Subtype_Ind);
+ end if;
+
+ -- Subtype_indication case; check that the types are the same, and
+ -- statically match if appropriate. A null exclusion may be present
+ -- on the return type, on the function specification, on the object
+ -- declaration or on the subtype itself.
+
+ elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then
+ 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;
+
+ -- If the function's result type doesn't match the return object
+ -- entity's type, then we check for the case where the result type
+ -- is class-wide, and allow the declaration if the type of the object
+ -- definition matches the class-wide type. This prevents rejection
+ -- in the case where the object declaration is initialized by a call
+ -- to a build-in-place function with a specific result type and the
+ -- object entity had its type changed to that specific type. (Note
+ -- that the ARG believes that return objects should be allowed to
+ -- have a type covered by a class-wide result type in any case, so
+ -- once that relaxation is made (see AI05-32), the above check for
+ -- type compatibility should be changed to test Covers rather than
+ -- equality, and then the following special test will no longer be
+ -- needed. ???)
+
+ elsif Is_Class_Wide_Type (R_Type)
+ and then
+ R_Type = Etype (Object_Definition (Original_Node (Obj_Decl)))
+ 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.
+
+ Analyze (Obj_Decl);
+
+ Set_Is_Return_Object (Defining_Identifier (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;
+
+ 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 asssociated
+ -- 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;
+
+ 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;
+
+ -- ??? 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 "
+ & "null-excluding return?",
+ Reason => CE_Null_Not_Allowed);
+ end if;
+ end if;
+ end Analyze_Function_Return;
+