procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

ada: Elide the copy in extended returns for nonlimited by-reference types

Browse source 
This implements elision of the copy operation for extended return statements
in the case of nonlimited by-reference types (the copy operation is already
elided for limited types by the front-end and nonlimited non-by-reference
types by the code generator), which comprise controlled and tagged types.

The implementation partly reuses the machinery implemented for limited types
(the build-in-place machinery) to allocate the return object directly on the
primary or the secondary stack, depending on whether the result type of the
function is constrained or not.

This requires further special-casing for the allocators generated by this
machinery as well as an adjustment to the implementation of a specific case
of string concatenation.

gcc/ada/

	* einfo.ads (Actual_Subtype): Document additional usage.
	* exp_aggr.adb (Expand_Array_Aggregate): Replace test on
	Is_Build_In_Place_Return_Object with Is_Special_Return_Object.
	* exp_ch3.adb (Expand_N_Object_Declaration): Factor out parts of the
	processing done for build-in-place return objects and reuse them to
	implement a similar processing for specific return objects.
	* exp_ch4.adb (Expand_Allocator_Expression): Do not generate a tag
	assignment or an adjustment if the allocator was made for a special
	return object.
	(Expand_Concatenate): If the result is allocated on the secondary
	stack, use an unconstrained allocation.
	* exp_ch6.ads (Apply_CW_Accessibility_Check): New declaration.
	(Is_By_Reference_Return_Object): Likewise.
	(Is_Secondary_Stack_Return_Object): Likewise.
	(Is_Special_Return_Object): Likewise.
	* exp_ch6.adb (Expand_Ctrl_Function_Call): Do not bail out for the
	expression in the declaration of a special return object.
	(Expand_N_Extended_Return_Statement): Add missing guard and move
	the class-wide accessibility check to Expand_N_Object_Declaration.
	(Expand_Simple_Function_Return): Delete obsolete commentary.
	Skip the special processing for types that require finalization or
	are returned on the secondary stack if the return originally comes
	from an extended return statement.  Add missing Constant_Present.
	(Is_By_Reference_Return_Object): New predicate.
	(Is_Secondary_Stack_Return_Object): Likewise.
	(Is_Special_Return_Object): Likewise.
	* exp_util.adb (Is_Related_To_Func_Return): Also return true if the
	parent of the expression is the renaming declaration generated for
	the expansion of a return object.
	* gen_il-fields.ads (Opt_Field_Enum): Replace Alloc_For_BIP_Return
	with For_Special_Return_Object.
	* gen_il-gen-gen_nodes.adb (N_Allocator): Likewise.
	* gen_il-internals.adb (Image): Remove Alloc_For_BIP_Return.
	* sem_ch3.adb (Check_Return_Subtype_Indication): New procedure
	moved from sem_ch6.adb.
	(Analyze_Object_Declaration): Call it on a return object.
	* sem_ch4.adb: Add with and use clauses for Rtsfind.
	(Analyze_Allocator): Test For_Special_Return_Object to skip checks
	for allocators made for special return objects.
	Do not report restriction violations for the return stack pool.
	* sem_ch5.adb (Analyze_Assignment.Set_Assignment_Type): Return the
	Actual_Subtype for return objects that live on the secondary stack.
	* sem_ch6.adb (Check_Return_Subtype_Indication): Move procedure to
	sem_ch3.adb.
	(Analyze_Function_Return): Do not call above procedure.
	* sem_res.adb (Resolve_Allocator): Replace Alloc_For_BIP_Return
	with For_Special_Return_Object.
	* sinfo.ads: Likewise.
	* treepr.adb (Image): Remove Alloc_For_BIP_Return.
	* gcc-interface/trans.cc (gnat_to_gnu): Do not convert to the result
	type in the unconstrained array type case if the parent is a simple
	return statement.
This commit is contained in:
Eric Botcazou 2022-12-02 10:55:49 +01:00 • committed by Marc Poulhiès
parent a444c05623
commit ea588d41f3
18 changed files with 707 additions and 412 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/ada/einfo.ads
View file

@ -358,9 +358,11 @@ package Einfo is
--
-- For objects, the Actual_Subtype is set only if this is a discriminated
-- type. For arrays, the bounds of the expression are obtained and the
-- Etype of the object is directly the constrained subtype. This is
-- rather irregular, and the semantic checks that depend on the nominal
-- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv).
-- Etype of the object is directly the constrained subtype, except in the
-- case of a return object that lives on the secondary stack where Etype
-- is the nominal unconstrained subtype. This is rather irregular and the
-- semantic checks that depend on the nominal subtype being unconstrained
-- use flag Is_Constr_Subt_For_U_Nominal(qv).
-- Address_Clause (synthesized)
-- Applies to entries, objects and subprograms. Set if an address clause

2
gcc/ada/exp_aggr.adb
View file

@ -6841,7 +6841,7 @@ package body Exp_Aggr is
or else Parent_Kind = N_Component_Association
or else (Parent_Kind = N_Object_Declaration
and then (Needs_Finalization (Typ)
or else Is_Build_In_Place_Return_Object
or else Is_Special_Return_Object
(Defining_Identifier (Parent_Node))))
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)

472
gcc/ada/exp_ch3.adb
View file

@ -6289,6 +6289,18 @@ package body Exp_Ch3 is
-- Generate all default initialization actions for object Def_Id. Any
-- new code is inserted after node After.
procedure Initialize_Return_Object
(Tag_Assign : Node_Id;
Adj_Call : Node_Id;
Expr : Node_Id;
Init_Stmt : Node_Id;
After : Node_Id);
-- Generate all initialization actions for return object Def_Id. Any
-- new code is inserted after node After.
function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id;
-- Make an allocator for a return object initialized with Expr
function OK_To_Rename_Ref (N : Node_Id) return Boolean;
-- Return True if N denotes an entity with OK_To_Rename set
@ -7047,6 +7059,108 @@ package body Exp_Ch3 is
end if;
end Default_Initialize_Object;
------------------------------
-- Initialize_Return_Object --
------------------------------
procedure Initialize_Return_Object
(Tag_Assign : Node_Id;
Adj_Call : Node_Id;
Expr : Node_Id;
Init_Stmt : Node_Id;
After : Node_Id)
is
begin
if Present (Tag_Assign) then
Insert_Action_After (After, Tag_Assign);
end if;
if Present (Adj_Call) then
Insert_Action_After (After, Adj_Call);
end if;
if No (Expr) then
Default_Initialize_Object (After);
elsif Is_Delayed_Aggregate (Expr)
and then not No_Initialization (N)
then
Convert_Aggr_In_Object_Decl (N);
elsif Present (Init_Stmt) then
Insert_Action_After (After, Init_Stmt);
Set_Expression (N, Empty);
end if;
end Initialize_Return_Object;
-------------------------------
-- Make_Allocator_For_Return --
-------------------------------
function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is
Func_Id : constant Entity_Id := Return_Applies_To (Scope (Def_Id));
Alloc : Node_Id;
begin
-- If the return object's declaration includes an expression and the
-- declaration isn't marked as No_Initialization, then we generate an
-- allocator with a qualified expression. Although this is necessary
-- only in the case where the result type is an interface (or class-
-- wide interface), we do it in all cases for the sake of consistency
-- instead of subsequently generating a separate assignment.
if Present (Expr)
and then not Is_Delayed_Aggregate (Expr)
and then not No_Initialization (N)
then
-- Ada 2005 (AI95-344): If the result type is class-wide, insert
-- a check that the level of the return expression's underlying
-- type is not deeper than the level of the master enclosing the
-- function.
-- AI12-043: The check is made immediately after the return object
-- is created.
if Is_Class_Wide_Type (Etype (Func_Id)) then
Apply_CW_Accessibility_Check (Expr, Func_Id);
end if;
-- We always use the type of the expression for the qualified
-- expression, rather than the return object's type. We cannot
-- always use the return object's type because the expression
-- might be of a specific type and the result object mignt not.
Alloc :=
Make_Allocator (Loc,
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (Expr), Loc),
Expression => New_Copy_Tree (Expr)));
else
Alloc :=
Make_Allocator (Loc,
Expression => New_Occurrence_Of (Typ, Loc));
-- If the return object requires default initialization, then it
-- will happen later following the elaboration of the renaming.
-- If we don't turn it off here, then the object will be default
-- initialized twice.
Set_No_Initialization (Alloc);
end if;
-- Set the flag indicating that the allocator is made for a special
-- return object. This is used to bypass various legality checks as
-- well as to make sure that the result is not adjusted twice.
Set_For_Special_Return_Object (Alloc);
return Alloc;
end Make_Allocator_For_Return;
----------------------
-- OK_To_Rename_Ref --
----------------------
@ -7060,10 +7174,9 @@ package body Exp_Ch3 is
-- Local variables
Adj_Call : Node_Id;
Expr_Q : Node_Id;
Id_Ref : Node_Id;
Tag_Assign : Node_Id;
Adj_Call : Node_Id := Empty;
Expr_Q : Node_Id := Empty;
Tag_Assign : Node_Id := Empty;
Init_After : Node_Id := N;
-- Node after which the initialization actions are to be inserted. This
@ -7172,8 +7285,6 @@ package body Exp_Ch3 is
-- Default initialization required, and no expression present
if No (Expr) then
Expr_Q := Expr;
-- If we have a type with a variant part, the initialization proc
-- will contain implicit tests of the discriminant values, which
-- counts as a violation of the restriction No_Implicit_Conditionals.
@ -7232,7 +7343,7 @@ package body Exp_Ch3 is
end if;
end if;
if not Is_Build_In_Place_Return_Object (Def_Id) then
if not Is_Special_Return_Object (Def_Id) then
Default_Initialize_Object (Init_After);
end if;
@ -7292,7 +7403,7 @@ package body Exp_Ch3 is
Expander_Mode_Restore;
end if;
if not Is_Build_In_Place_Return_Object (Def_Id) then
if not Is_Special_Return_Object (Def_Id) then
Convert_Aggr_In_Object_Decl (N);
end if;
@ -7363,12 +7474,12 @@ package body Exp_Ch3 is
then
pragma Assert (Is_Class_Wide_Type (Typ));
-- If the object is a built-in-place return object, bypass special
-- If the object is a special return object, then bypass special
-- treatment of class-wide interface initialization below. In this
-- case, the expansion of the return statement will take care of
-- creating the object (via allocator) and initializing it.
if Is_Build_In_Place_Return_Object (Def_Id) then
if Is_Special_Return_Object (Def_Id) then
null;
elsif Tagged_Type_Expansion then
@ -7668,8 +7779,7 @@ package body Exp_Ch3 is
if Present (Tag_Assign) then
if Present (Following_Address_Clause (N)) then
Ensure_Freeze_Node (Def_Id);
else
elsif not Is_Special_Return_Object (Def_Id) then
Insert_Action_After (Init_After, Tag_Assign);
end if;
@ -7679,23 +7789,26 @@ package body Exp_Ch3 is
-- record type.
elsif Is_CPP_Constructor_Call (Expr) then
declare
Id_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
-- The call to the initialization procedure does NOT freeze the
-- object being initialized.
begin
-- The call to the initialization procedure does NOT freeze
-- the object being initialized.
Id_Ref := New_Occurrence_Of (Def_Id, Loc);
Set_Must_Not_Freeze (Id_Ref);
Set_Assignment_OK (Id_Ref);
Set_Must_Not_Freeze (Id_Ref);
Set_Assignment_OK (Id_Ref);
Insert_Actions_After (Init_After,
Build_Initialization_Call (Loc, Id_Ref, Typ,
Constructor_Ref => Expr));
Insert_Actions_After (Init_After,
Build_Initialization_Call (Loc, Id_Ref, Typ,
Constructor_Ref => Expr));
-- We remove here the original call to the constructor
-- to avoid its management in the backend
-- We remove here the original call to the constructor
-- to avoid its management in the backend
Set_Expression (N, Empty);
return;
Set_Expression (N, Empty);
return;
end;
-- Handle initialization of limited tagged types
@ -7735,18 +7848,15 @@ package body Exp_Ch3 is
then
Set_Is_Known_Valid (Def_Id);
elsif Is_Access_Type (Typ) then
-- For access types, set the Is_Known_Non_Null flag if the
-- initializing value is known to be non-null. We can also
-- set Can_Never_Be_Null if this is a constant.
-- For access types set the Is_Known_Non_Null flag if the
-- initializing value is known to be non-null. We can also set
-- Can_Never_Be_Null if this is a constant.
elsif Is_Access_Type (Typ) and then Known_Non_Null (Expr) then
Set_Is_Known_Non_Null (Def_Id, True);
if Known_Non_Null (Expr) then
Set_Is_Known_Non_Null (Def_Id, True);
if Constant_Present (N) then
Set_Can_Never_Be_Null (Def_Id);
end if;
if Constant_Present (N) then
Set_Can_Never_Be_Null (Def_Id);
end if;
end if;
@ -7762,6 +7872,7 @@ package body Exp_Ch3 is
and then not Is_Generic_Type (Typ)
then
Ensure_Valid (Expr);
if Safe_To_Capture_Value (N, Def_Id) then
Set_Is_Known_Valid (Def_Id);
end if;
@ -7839,10 +7950,9 @@ package body Exp_Ch3 is
Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Typ);
-- Guard against a missing [Deep_]Adjust when the base type
-- was not properly frozen.
if Present (Adj_Call) then
if Present (Adj_Call)
and then not Is_Special_Return_Object (Def_Id)
then
Insert_Action_After (Init_After, Adj_Call);
end if;
end if;
@ -8092,78 +8202,12 @@ package body Exp_Ch3 is
-- an unconstrained array on the heap. In this case the
-- result object's type is a constrained array type even
-- though the function's type is unconstrained.
Obj_Alloc_Formal : constant Entity_Id :=
Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
Pool_Id : constant Entity_Id :=
Make_Temporary (Loc, 'P');
function Make_Allocator_For_BIP_Return return Node_Id;
-- Make an allocator for the BIP return being processed
-----------------------------------
-- Make_Allocator_For_BIP_Return --
-----------------------------------
function Make_Allocator_For_BIP_Return return Node_Id is
Alloc : Node_Id;
begin
if Present (Expr_Q)
and then not Is_Delayed_Aggregate (Expr_Q)
and then not No_Initialization (N)
then
-- Always use the type of the expression for the
-- qualified expression, rather than the result type.
-- In general we cannot always use the result type
-- for the allocator, because the expression might be
-- of a specific type, such as in the case of an
-- aggregate or even a nonlimited object when the
-- result type is a limited class-wide interface type.
Alloc :=
Make_Allocator (Loc,
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (Expr_Q), Loc),
Expression => New_Copy_Tree (Expr_Q)));
else
-- If the function returns a class-wide type we cannot
-- use the return type for the allocator. Instead we
-- use the type of the expression, which must be an
-- aggregate of a definite type.
if Is_Class_Wide_Type (Typ) then
Alloc :=
Make_Allocator (Loc,
Expression =>
New_Occurrence_Of (Etype (Expr_Q), Loc));
else
Alloc :=
Make_Allocator (Loc,
Expression =>
New_Occurrence_Of (Typ, Loc));
end if;
-- If the object requires default initialization then
-- that will happen later following the elaboration of
-- the object renaming. If we don't turn it off here
-- then the object will be default initialized twice.
Set_No_Initialization (Alloc);
end if;
-- Set the flag indicating that the allocator came from
-- a build-in-place return statement, so we can avoid
-- adjusting the allocated object.
Set_Alloc_For_BIP_Return (Alloc);
return Alloc;
end Make_Allocator_For_BIP_Return;
Acc_Typ : Entity_Id;
Alloc_Obj_Decl : Node_Id;
Alloc_Obj_Id : Entity_Id;
@ -8209,13 +8253,13 @@ package body Exp_Ch3 is
-- First create the Heap_Allocator
Heap_Allocator := Make_Allocator_For_BIP_Return;
Heap_Allocator := Make_Allocator_For_Return (Expr_Q);
-- The Pool_Allocator is just like the Heap_Allocator,
-- except we set Storage_Pool and Procedure_To_Call so
-- it will use the user-defined storage pool.
Pool_Allocator := Make_Allocator_For_BIP_Return;
Pool_Allocator := Make_Allocator_For_Return (Expr_Q);
-- Do not generate the renaming of the build-in-place
-- pool parameter on ZFP because the parameter is not
@ -8256,7 +8300,7 @@ package body Exp_Ch3 is
-- allocation.
else
SS_Allocator := Make_Allocator_For_BIP_Return;
SS_Allocator := Make_Allocator_For_Return (Expr_Q);
-- The heap and pool allocators are marked as
-- Comes_From_Source since they correspond to an
@ -8427,7 +8471,10 @@ package body Exp_Ch3 is
-- From now on, the type of the return object is the
-- designated type.
Set_Etype (Def_Id, Desig_Typ);
if Desig_Typ /= Typ then
Set_Etype (Def_Id, Desig_Typ);
Set_Actual_Subtype (Def_Id, Typ);
end if;
-- Remember the local access object for use in the
-- dereference of the renaming created below.
@ -8474,6 +8521,7 @@ package body Exp_Ch3 is
Alloc_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Alloc_Obj_Id,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Acc_Typ, Loc),
Expression =>
@ -8492,18 +8540,8 @@ package body Exp_Ch3 is
-- Initialize the object now that it has got its final subtype,
-- but before rewriting it as a renaming.
if No (Expr_Q) then
Default_Initialize_Object (Init_After);
elsif Is_Delayed_Aggregate (Expr_Q)
and then not No_Initialization (N)
then
Convert_Aggr_In_Object_Decl (N);
elsif Present (Init_Stmt) then
Insert_Action_After (Init_After, Init_Stmt);
Set_Expression (N, Empty);
end if;
Initialize_Return_Object
(Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After);
-- Replace the return object declaration with a renaming of a
-- dereference of the access value designating the return object.
@ -8513,6 +8551,198 @@ package body Exp_Ch3 is
Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
Set_Etype (Expr_Q, Etype (Def_Id));
Rewrite_As_Renaming := True;
end;
-- If we can rename the initialization expression, we need to make sure
-- that we use the proper type in the case of a return object that lives
-- on the secondary stack. See other cases below for a similar handling.
elsif Rewrite_As_Renaming then
if Is_Secondary_Stack_Return_Object (Def_Id) then
declare
Func_Id : constant Entity_Id :=
Return_Applies_To (Scope (Def_Id));
Desig_Typ : constant Entity_Id :=
(if Ekind (Typ) = E_Array_Subtype
then Etype (Func_Id) else Typ);
begin
-- From now on, the type of the return object is the
-- designated type.
if Desig_Typ /= Typ then
Set_Etype (Def_Id, Desig_Typ);
Set_Actual_Subtype (Def_Id, Typ);
end if;
end;
end if;
-- If this is the return object of a function returning on the secondary
-- stack, convert the declaration to a renaming of the dereference of ah
-- allocator for the secondary stack.
-- Result : T [:= <expression>];
-- is converted to
-- type Txx is access all ...;
-- Rxx : constant Txx :=
-- new <expression-type>['(<expression>)][storage_pool =
-- system__secondary_stack__ss_pool][procedure_to_call =
-- system__secondary_stack__ss_allocate];
-- Result : T renames Rxx.all;
elsif Is_Secondary_Stack_Return_Object (Def_Id) then
declare
Func_Id : constant Entity_Id :=
Return_Applies_To (Scope (Def_Id));
Desig_Typ : constant Entity_Id :=
(if Ekind (Typ) = E_Array_Subtype
then Etype (Func_Id) else Typ);
-- Ensure that the we use a fat pointer when allocating
-- an unconstrained array on the heap. In this case the
-- result object's type is a constrained array type even
-- though the function's type is unconstrained.
Acc_Typ : Entity_Id;
Alloc_Obj_Decl : Node_Id;
Alloc_Obj_Id : Entity_Id;
Ptr_Type_Decl : Node_Id;
begin
-- Create an access type designating the function's
-- result subtype.
Acc_Typ := Make_Temporary (Loc, 'A');
Ptr_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Desig_Typ, Loc)));
Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks);
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
Alloc_Obj_Id := Make_Temporary (Loc, 'R');
Alloc_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Alloc_Obj_Id,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Acc_Typ, Loc),
Expression => Make_Allocator_For_Return (Expr_Q));
Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
Set_Uses_Sec_Stack (Func_Id);
Set_Uses_Sec_Stack (Scope (Def_Id));
Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));
-- From now on, the type of the return object is the
-- designated type.
if Desig_Typ /= Typ then
Set_Etype (Def_Id, Desig_Typ);
Set_Actual_Subtype (Def_Id, Typ);
end if;
-- Initialize the object now that it has got its final subtype,
-- but before rewriting it as a renaming.
Initialize_Return_Object
(Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After);
-- Replace the return object declaration with a renaming of a
-- dereference of the access value designating the return object.
Expr_Q :=
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc));
Set_Etype (Expr_Q, Etype (Def_Id));
Rewrite_As_Renaming := True;
end;
-- If this is the return object of a function returning a by-reference
-- type, convert the declaration to a renaming of the dereference of ah
-- allocator for the return stack.
-- Result : T [:= <expression>];
-- is converted to
-- type Txx is access all ...;
-- Rxx : constant Txx :=
-- new <expression-type>['(<expression>)][storage_pool =
-- system__secondary_stack__rs_pool][procedure_to_call =
-- system__secondary_stack__rs_allocate];
-- Result : T renames Rxx.all;
elsif Back_End_Return_Slot
and then Is_By_Reference_Return_Object (Def_Id)
then
declare
Acc_Typ : Entity_Id;
Alloc_Obj_Decl : Node_Id;
Alloc_Obj_Id : Entity_Id;
Ptr_Type_Decl : Node_Id;
begin
-- Create an access type designating the function's
-- result subtype.
Acc_Typ := Make_Temporary (Loc, 'A');
Ptr_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Typ, Loc)));
Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks);
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool));
Alloc_Obj_Id := Make_Temporary (Loc, 'R');
Alloc_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Alloc_Obj_Id,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Acc_Typ, Loc),
Expression => Make_Allocator_For_Return (Expr_Q));
Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
-- Initialize the object now that it has got its final subtype,
-- but before rewriting it as a renaming.
Initialize_Return_Object
(Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After);
-- Replace the return object declaration with a renaming of a
-- dereference of the access value designating the return object.
Expr_Q :=
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc));
Set_Etype (Expr_Q, Etype (Def_Id));
Rewrite_As_Renaming := True;
end;
end if;

126
gcc/ada/exp_ch4.adb
View file

@ -898,6 +898,11 @@ package body Exp_Ch4 is
(Directly_Designated_Type (Etype (N))));
null;
-- Likewise if the allocator is made for a special return object
elsif For_Special_Return_Object (N) then
null;
elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
TagT := T;
TagR :=
@ -946,19 +951,18 @@ package body Exp_Ch4 is
-- Adjust procedure, and the object is built in place. In Ada 95, the
-- object can be limited but not inherently limited if this allocator
-- came from a return statement (we're allocating the result on the
-- secondary stack). In that case, the object will be moved, so we do
-- want to Adjust. However, if it's a nonlimited build-in-place
-- function call, Adjust is not wanted.
--
-- Needs_Finalization (DesigT) can differ from Needs_Finalization (T)
-- secondary stack); in that case, the object will be moved, so we do
-- want to Adjust. But the call is always skipped if the allocator is
-- made for a special return object because it's generated elsewhere.
-- Needs_Finalization (DesigT) may differ from Needs_Finalization (T)
-- if one of the two types is class-wide, and the other is not.
if Needs_Finalization (DesigT)
and then Needs_Finalization (T)
and then not Aggr_In_Place
and then not Is_Limited_View (T)
and then not Alloc_For_BIP_Return (N)
and then not Is_Build_In_Place_Function_Call (Expression (N))
and then not For_Special_Return_Object (N)
then
-- An unchecked conversion is needed in the classwide case because
-- the designated type can be an ancestor of the subtype mark of
@ -2724,6 +2728,7 @@ package body Exp_Ch4 is
Len : Unat;
J : Nat;
Clen : Node_Id;
Decl : Node_Id;
Set : Boolean;
-- Start of processing for Expand_Concatenate
@ -3250,10 +3255,32 @@ package body Exp_Ch4 is
Set_Is_Internal (Ent);
Set_Debug_Info_Needed (Ent);
-- If the bound is statically known to be out of range, we do not want
-- to abort, we want a warning and a constraint error at run time. Note
-- that we have arranged that the result will not be treated as a static
-- constant, so we won't get an illegality during the insertion. We also
-- enable all checks (in particular range checks) in case the bounds of
-- Subtyp_Ind are out of range.
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => Subtyp_Ind);
Insert_Action (Cnode, Decl);
-- If the result of the concatenation appears as the initializing
-- expression of an object declaration, we can just rename the
-- result, rather than copying it.
Set_OK_To_Rename (Ent);
-- If we are concatenating strings and the current scope already uses
-- the secondary stack, allocate the resulting string also on the
-- secondary stack to avoid putting too much pressure on the primary
-- stack.
-- the secondary stack, allocate the result also on the secondary stack
-- to avoid putting too much pressure on the primary stack.
-- We use an unconstrained allocation, i.e. we also allocate the bounds,
-- so that the result can be renamed in all contexts.
-- Don't do this if -gnatd.h is set, as this will break the wrapping of
-- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat.
@ -3263,85 +3290,78 @@ package body Exp_Ch4 is
and then not Debug_Flag_Dot_H
then
-- Generate:
-- subtype Axx is ...;
-- type Ayy is access Axx;
-- Rxx : Ayy := new <subtype> [storage_pool = ss_pool];
-- Sxx : <subtype> renames Rxx.all;
-- subtype Axx is String (<low-bound> .. <high-bound>)
-- type Ayy is access String;
-- Rxx : Ayy := new <Axx> [storage_pool = ss_pool];
-- Sxx : String renames Rxx.all;
declare
Alloc : Node_Id;
ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
Alloc : Node_Id;
Deref : Node_Id;
Temp : Entity_Id;
begin
Insert_Action (Cnode,
Insert_Action (Decl,
Make_Subtype_Declaration (Loc,
Defining_Identifier => ConstrT,
Subtype_Indication => Subtyp_Ind),
Suppress => All_Checks);
Freeze_Itype (ConstrT, Cnode);
Insert_Action (Cnode,
Freeze_Itype (ConstrT, Decl);
Insert_Action (Decl,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))),
Subtype_Indication => New_Occurrence_Of (Atyp, Loc))),
Suppress => All_Checks);
Mutate_Ekind (Acc_Typ, E_Access_Type);
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
Alloc :=
Make_Allocator (Loc,
Expression => New_Occurrence_Of (ConstrT, Loc));
-- Allocate on the secondary stack. This is currently done
-- only for type String, which normally doesn't have default
-- initialization, but we need to Set_No_Initialization in case
-- of Initialize_Scalars or Normalize_Scalars; otherwise, the
-- allocator will get transformed and will not use the secondary
-- stack.
-- This is currently done only for type String, which normally
-- doesn't have default initialization, but we need to set the
-- No_Initialization flag in case of either Initialize_Scalars
-- or Normalize_Scalars.
Set_Storage_Pool (Alloc, RTE (RE_SS_Pool));
Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate));
Set_No_Initialization (Alloc);
Temp := Make_Temporary (Loc, 'R', Alloc);
Insert_Action (Cnode,
Insert_Action (Decl,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
Expression => Alloc),
Suppress => All_Checks);
Insert_Action (Cnode,
Deref :=
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc));
Set_Etype (Deref, Atyp);
Rewrite (Decl,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Ent,
Subtype_Mark => New_Occurrence_Of (ConstrT, Loc),
Name =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc))),
Suppress => All_Checks);
Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
Name => Deref));
-- We do not analyze this renaming declaration because this would
-- change the subtype of Ent back to a constrained string.
Set_Etype (Ent, Atyp);
Set_Renamed_Object (Ent, Deref);
Set_Analyzed (Decl);
end;
else
-- If the bound is statically known to be out of range, we do not
-- want to abort, we want a warning and a runtime constraint error.
-- Note that we have arranged that the result will not be treated as
-- a static constant, so we won't get an illegality during this
-- insertion.
-- We also enable checks (in particular range checks) in case the
-- bounds of Subtyp_Ind are out of range.
Insert_Action (Cnode,
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => Subtyp_Ind));
end if;
-- If the result of the concatenation appears as the initializing
-- expression of an object declaration, we can just rename the
-- result, rather than copying it.
Set_OK_To_Rename (Ent);
-- Catch the static out of range case now
if Raises_Constraint_Error (High_Bound)

99
gcc/ada/exp_ch6.adb
View file

@ -192,16 +192,6 @@ package body Exp_Ch6 is
-- the activation Chain. Note: Master_Actual can be Empty, but only if
-- there are no tasks.
procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
-- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
-- that the level of the return expression's underlying type is not deeper
-- than the level of the master enclosing the function. Always generate the
-- check when the type of the return expression is class-wide, when it's a
-- type conversion, or when it's a formal parameter. Otherwise suppress the
-- check in the case where the return expression has a specific type whose
-- level is known not to be statically deeper than the result type of the
-- function.
function Caller_Known_Size
(Func_Call : Node_Id;
Result_Subt : Entity_Id) return Boolean;
@ -5140,10 +5130,15 @@ package body Exp_Ch6 is
end if;
-- Another optimization: if the returned value is used to initialize an
-- object, and the secondary stack is not involved in the call, then no
-- need to copy/readjust/finalize, we can just initialize it in place.
-- object, then no need to copy/readjust/finalize, we can initialize it
-- in place. However, if the call returns on the secondary stack or this
-- is a special return object, then we need the expansion because we'll
-- be renaming the temporary as the (permanent) object.
if Nkind (Par) = N_Object_Declaration and then not Use_Sec_Stack then
if Nkind (Par) = N_Object_Declaration
and then not Use_Sec_Stack
and then not Is_Special_Return_Object (Defining_Entity (Par))
then
return;
end if;
@ -5300,7 +5295,7 @@ package body Exp_Ch6 is
-- Assert that if F says "return R : T := G(...) do..."
-- then F and G are both b-i-p, or neither b-i-p.
if Nkind (Exp) = N_Function_Call then
if Present (Exp) and then Nkind (Exp) = N_Function_Call then
pragma Assert (Ekind (Current_Subprogram) = E_Function);
pragma Assert
(Is_Build_In_Place_Function (Current_Subprogram) =
@ -5308,16 +5303,6 @@ package body Exp_Ch6 is
null;
end if;
-- Ada 2005 (AI95-344): If the result type is class-wide, then insert
-- a check that the level of the return expression's underlying type
-- is not deeper than the level of the master enclosing the function.
-- AI12-043: The check is made immediately after the return object
-- is created.
if Present (Exp) and then Is_Class_Wide_Type (Ret_Typ) then
Apply_CW_Accessibility_Check (Exp, Func_Id);
end if;
else
Exp := Empty;
end if;
@ -6529,19 +6514,6 @@ package body Exp_Ch6 is
-- need to reify the return object, so we can build it "in place", and
-- we need a block statement to hang finalization and tasking stuff.
-- ??? In order to avoid disruption, we avoid translating to extended
-- return except in the cases where we really need to (Ada 2005 for
-- inherently limited). We might prefer to do this translation in all
-- cases (except perhaps for the case of Ada 95 inherently limited),
-- in order to fully exercise the Expand_N_Extended_Return_Statement
-- code. This would also allow us to do the build-in-place optimization
-- for efficiency even in cases where it is semantically not required.
-- As before, we check the type of the return expression rather than the
-- return type of the function, because the latter may be a limited
-- class-wide interface type, which is not a limited type, even though
-- the type of the expression may be.
pragma Assert
(Comes_From_Extended_Return_Statement (N)
or else not Is_Build_In_Place_Function_Call (Exp)
@ -6682,15 +6654,18 @@ package body Exp_Ch6 is
-- type Ann is access R_Type;
-- for Ann'Storage_pool use rs_pool;
-- Rnn : Ann := new Exp_Typ'(Exp);
-- Rnn : constant Ann := new Exp_Typ'(Exp);
-- return Rnn.all;
-- but optimize the case where the result is a function call that
-- also needs finalization. In this case the result can directly be
-- allocated on the return stack of the caller and no further
-- processing is required.
-- processing is required. Likewise if this is a return object.
if Present (Utyp)
if Comes_From_Extended_Return_Statement (N) then
null;
elsif Present (Utyp)
and then Needs_Finalization (Utyp)
and then not (Exp_Is_Function_Call
and then Needs_Finalization (Exp_Typ))
@ -6733,6 +6708,7 @@ package body Exp_Ch6 is
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
Expression => Alloc_Node)));
@ -6753,11 +6729,16 @@ package body Exp_Ch6 is
Set_Enclosing_Sec_Stack_Return (N);
-- Nothing else to do for a return object
if Comes_From_Extended_Return_Statement (N) then
null;
-- Optimize the case where the result is a function call that also
-- returns on the secondary stack. In this case the result is already
-- on the secondary stack and no further processing is required.
if Exp_Is_Function_Call
elsif Exp_Is_Function_Call
and then Needs_Secondary_Stack (Exp_Typ)
then
-- Remove side effects from the expression now so that other parts
@ -6782,7 +6763,7 @@ package body Exp_Ch6 is
-- type Ann is access R_Type;
-- for Ann'Storage_pool use ss_pool;
-- Rnn : Ann := new Exp_Typ'(Exp);
-- Rnn : constant Ann := new Exp_Typ'(Exp);
-- return Rnn.all;
-- And we do the same for class-wide types that are not potentially
@ -6806,7 +6787,6 @@ package body Exp_Ch6 is
begin
Mutate_Ekind (Acc_Typ, E_Access_Type);
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
-- This is an allocator for the secondary stack, and it's fine
@ -6836,6 +6816,7 @@ package body Exp_Ch6 is
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Acc_Typ, Loc),
Expression => Alloc_Node)));
@ -7900,6 +7881,16 @@ package body Exp_Ch6 is
and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E)));
end Is_Build_In_Place_Return_Object;
-----------------------------------
-- Is_By_Reference_Return_Object --
-----------------------------------
function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean is
begin
return Is_Return_Object (E)
and then Is_By_Reference_Type (Etype (Return_Applies_To (Scope (E))));
end Is_By_Reference_Return_Object;
-----------------------
-- Is_Null_Procedure --
-----------------------
@ -7959,6 +7950,28 @@ package body Exp_Ch6 is
end if;
end Is_Null_Procedure;
--------------------------------------
-- Is_Secondary_Stack_Return_Object --
--------------------------------------
function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean is
begin
return Is_Return_Object (E)
and then Needs_Secondary_Stack (Etype (Return_Applies_To (Scope (E))));
end Is_Secondary_Stack_Return_Object;
------------------------------
-- Is_Special_Return_Object --
------------------------------
function Is_Special_Return_Object (E : Entity_Id) return Boolean is
begin
return Is_Build_In_Place_Return_Object (E)
or else Is_Secondary_Stack_Return_Object (E)
or else (Back_End_Return_Slot
and then Is_By_Reference_Return_Object (E));
end Is_Special_Return_Object;
-------------------------------------------
-- Make_Build_In_Place_Call_In_Allocator --
-------------------------------------------

27
gcc/ada/exp_ch6.ads
View file

@ -99,6 +99,16 @@ package Exp_Ch6 is
-- Adds Extra_Actual as a named parameter association for the formal
-- Extra_Formal in Subprogram_Call.
procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id);
-- Ada 2005 (AI95-344): If the result type is class-wide, insert a check
-- that the level of the return expression's underlying type is not deeper
-- than the level of the master enclosing the function. Always generate the
-- check when the type of the return expression is class-wide, when it's a
-- type conversion, or when it's a formal parameter. Otherwise suppress the
-- check in the case where the return expression has a specific type whose
-- level is known not to be statically deeper than the result type of the
-- function.
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
-- for build-in-place formal parameters of the given kind.
@ -158,13 +168,28 @@ package Exp_Ch6 is
-- True in >= Ada 2005 and must be False in Ada 95.
function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Return True is E is a return object of a function
-- Ada 2005 (AI-318-02): Return True if E is a return object of a function
-- that uses build-in-place protocols.
function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean;
-- Return True if E is a return object of a function whose return type is
-- required to be passed by reference, as defined in (RM 6.2(4-9)).
function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
-- Predicate to recognize stubbed procedures and null procedures, which
-- can be inlined unconditionally in all cases.
function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean;
-- Return True if E is a return object of a function whose return type is
-- returned on the secondary stack.
function Is_Special_Return_Object (E : Entity_Id) return Boolean;
-- Return True if E is the return object of a function and is handled in a
-- special way by the expander. In most cases, return objects are handled
-- like any other variables or constants but, in a few special cases, they
-- are further expanded into more elaborate constructs, whose common goal
-- is to elide the copy operation associated with the return.
procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id;
Function_Call : Node_Id);

6
gcc/ada/exp_util.adb
View file

@ -9166,7 +9166,11 @@ package body Exp_Util is
return
Present (Expr)
and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
and then (Nkind (Parent (Expr)) = N_Simple_Return_Statement
or else
(Nkind (Parent (Expr)) = N_Object_Renaming_Declaration
and then
Is_Return_Object (Defining_Entity (Parent (Expr)))));
end Is_Related_To_Func_Return;
--------------------------------

12
gcc/ada/gcc-interface/trans.cc
View file

@ -8473,9 +8473,10 @@ gnat_to_gnu (Node_Id gnat_node)
declaration, return the result unmodified because we want to use the
return slot optimization in this case.
5. If this is a reference to an unconstrained array which is used as the
prefix of an attribute reference that requires an lvalue, return the
result unmodified because we want to return the original bounds.
5. If this is a reference to an unconstrained array which is used either
as the prefix of an attribute reference that requires an lvalue or in
a return statement, then return the result unmodified because we want
to return the original bounds.
6. Finally, if the type of the result is already correct. */
@ -8539,8 +8540,9 @@ gnat_to_gnu (Node_Id gnat_node)
else if (TREE_CODE (TREE_TYPE (gnu_result)) == UNCONSTRAINED_ARRAY_TYPE
&& Present (Parent (gnat_node))
&& Nkind (Parent (gnat_node)) == N_Attribute_Reference
&& lvalue_required_for_attribute_p (Parent (gnat_node)))
&& ((Nkind (Parent (gnat_node)) == N_Attribute_Reference
&& lvalue_required_for_attribute_p (Parent (gnat_node)))
|| Nkind (Parent (gnat_node)) == N_Simple_Return_Statement))
;
else if (TREE_TYPE (gnu_result) != gnu_result_type)

2
gcc/ada/gen_il-fields.ads
View file

@ -69,7 +69,6 @@ package Gen_IL.Fields is
Address_Warning_Posted,
Aggregate_Bounds,
Aliased_Present,
Alloc_For_BIP_Return,
All_Others,
All_Present,
Alternatives,
@ -189,6 +188,7 @@ package Gen_IL.Fields is
Float_Truncate,
Formal_Type_Definition,
Forwards_OK,
For_Special_Return_Object,
From_Aspect_Specification,
From_At_Mod,
From_Conditional_Expression,

2
gcc/ada/gen_il-gen-gen_nodes.adb
View file

@ -494,7 +494,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Expression, Node_Id, Default_Empty),
Sy (Subpool_Handle_Name, Node_Id, Default_Empty),
Sy (Null_Exclusion_Present, Flag, Default_False),
Sm (Alloc_For_BIP_Return, Flag),
Sm (For_Special_Return_Object, Flag),
Sm (Do_Storage_Check, Flag),
Sm (Is_Dynamic_Coextension, Flag),
Sm (Is_Static_Coextension, Flag),

2
gcc/ada/gen_il-internals.adb
View file

@ -257,8 +257,6 @@ package body Gen_IL.Internals is
-- Special cases for the same reason as in the above Image
-- function for Opt_Type_Enum.
when Alloc_For_BIP_Return =>
return "Alloc_For_BIP_Return";
when Assignment_OK =>
return "Assignment_OK";
when Backwards_OK =>

139
gcc/ada/sem_ch3.adb
View file

@ -3781,6 +3781,11 @@ package body Sem_Ch3 is
-- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit
-- a compile-time warning if this is not the case.
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
-- Check that the return subtype indication properly matches the result
-- subtype of the function in an extended return object declaration, as
-- required by RM 6.5(5.1/2-5.3/2).
function Count_Tasks (T : Entity_Id) return Uint;
-- This function is called when a non-generic library level object of a
-- task type is declared. Its function is to count the static number of
@ -3954,6 +3959,134 @@ package body Sem_Ch3 is
Check_Component (Obj_Typ, Obj_Decl);
end Check_For_Null_Excluding_Components;
-------------------------------------
-- Check_Return_Subtype_Indication --
-------------------------------------
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
Obj_Typ : constant Entity_Id := Etype (Obj_Id);
Func_Id : constant Entity_Id := Return_Applies_To (Scope (Obj_Id));
R_Typ : constant Entity_Id := Etype (Func_Id);
Indic : constant Node_Id :=
Object_Definition (Original_Node (Obj_Decl));
procedure Error_No_Match (N : Node_Id);
-- Output error messages for case where types do not statically
-- match. N is the location for the messages.
--------------------
-- Error_No_Match --
--------------------
procedure Error_No_Match (N : Node_Id) is
begin
Error_Msg_N
("subtype must statically match function result subtype", N);
if not Predicates_Match (Obj_Typ, R_Typ) then
Error_Msg_Node_2 := R_Typ;
Error_Msg_NE
("\predicate of& does not match predicate of&",
N, Obj_Typ);
end if;
end Error_No_Match;
-- Start of processing for Check_Return_Subtype_Indication
begin
-- First, avoid cascaded errors
if Error_Posted (Obj_Decl) or else Error_Posted (Indic) 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 Is_Anonymous_Access_Type (R_Typ) then
if Is_Anonymous_Access_Type (Obj_Typ) then
if Ekind (Designated_Type (Obj_Typ)) /= E_Subprogram_Type
then
if Base_Type (Designated_Type (Obj_Typ)) /=
Base_Type (Designated_Type (R_Typ))
or else not Subtypes_Statically_Match (Obj_Typ, R_Typ)
then
Error_No_Match (Subtype_Mark (Indic));
end if;
else
-- For two anonymous access to subprogram types, the types
-- themselves must be type conformant.
if not Conforming_Types
(Obj_Typ, R_Typ, Fully_Conformant)
then
Error_No_Match (Indic);
end if;
end if;
else
Error_Msg_N ("must use anonymous access type", Indic);
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 Is_Anonymous_Access_Type (Obj_Typ) then
pragma Assert (not Is_Anonymous_Access_Type (R_Typ));
Error_Msg_N
("anonymous access not allowed for function with named access "
& "result", Indic);
-- 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_Typ), Base_Type (Obj_Typ))
or else (Is_Underlying_Record_View (Base_Type (Obj_Typ))
and then
Covers
(Base_Type (R_Typ),
Underlying_Record_View (Base_Type (Obj_Typ))))
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_Typ)
and then
(Can_Never_Be_Null (R_Typ)
or else Null_Exclusion_Present (Parent (Func_Id))) /=
Can_Never_Be_Null (Obj_Typ)
then
Error_No_Match (Indic);
end if;
-- AI05-103: for elementary types, subtypes must statically match
if Is_Constrained (R_Typ) or else Is_Access_Type (R_Typ) then
if not Subtypes_Statically_Match (Obj_Typ, R_Typ) then
Error_No_Match (Indic);
end if;
end if;
-- All remaining cases are illegal
-- Note: previous versions of this subprogram allowed the return
-- value to be the ancestor of the return type if the return type
-- was a null extension. This was plainly incorrect.
else
Error_Msg_N
("wrong type for return_subtype_indication", Indic);
end if;
end Check_Return_Subtype_Indication;
-----------------
-- Count_Tasks --
-----------------
@ -5047,6 +5180,12 @@ package body Sem_Ch3 is
end if;
end if;
-- Check specific legality rules for a return object
if Is_Return_Object (Id) then
Check_Return_Subtype_Indication (N);
end if;
-- Some simple constant-propagation: if the expression is a constant
-- string initialized with a literal, share the literal. This avoids
-- a run-time copy.

64
gcc/ada/sem_ch4.adb
View file

@ -44,6 +44,7 @@ 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_Case; use Sem_Case;
@ -733,43 +734,16 @@ package body Sem_Ch4 is
end;
end if;
-- Check for missing initialization. Skip this check if we already
-- had errors on analyzing the allocator, since in that case these
-- are probably cascaded errors.
-- Check for missing initialization. Skip this check if the allocator
-- is made for a special return object or if we already had errors on
-- analyzing the allocator since, in that case, these are very likely
-- cascaded errors.
if not Is_Definite_Subtype (Type_Id)
and then not For_Special_Return_Object (N)
and then Serious_Errors_Detected = Sav_Errs
then
-- The build-in-place machinery may produce an allocator when
-- the designated type is indefinite but the underlying type is
-- not. In this case the unknown discriminants are meaningless
-- and should not trigger error messages. Check the parent node
-- because the allocator is marked as coming from source.
if Present (Underlying_Type (Type_Id))
and then Is_Definite_Subtype (Underlying_Type (Type_Id))
and then not Comes_From_Source (Parent (N))
then
null;
-- An unusual case arises when the parent of a derived type is
-- a limited record extension with unknown discriminants, and
-- its full view has no discriminants.
--
-- A more general fix might be to create the proper underlying
-- type for such a derived type, but it is a record type with
-- no private attributes, so this required extending the
-- meaning of this attribute. ???
elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private
and then Present (Underlying_Type (Etype (Type_Id)))
and then
not Has_Discriminants (Underlying_Type (Etype (Type_Id)))
and then not Comes_From_Source (Parent (N))
then
null;
elsif Is_Class_Wide_Type (Type_Id) then
if Is_Class_Wide_Type (Type_Id) then
Error_Msg_N
("initialization required in class-wide allocation", N);
@ -842,6 +816,27 @@ package body Sem_Ch4 is
Error_Msg_N ("cannot allocate abstract object", E);
end if;
Set_Etype (N, Acc_Type);
-- If this is an allocator for the return stack, then no restriction may
-- be violated since it's just a low-level access to the primary stack.
if Nkind (Parent (N)) = N_Object_Declaration
and then Is_Entity_Name (Object_Definition (Parent (N)))
and then Is_Access_Type (Entity (Object_Definition (Parent (N))))
then
declare
Pool : constant Entity_Id :=
Associated_Storage_Pool
(Root_Type (Entity (Object_Definition (Parent (N)))));
begin
if Present (Pool) and then Is_RTE (Pool, RE_RS_Pool) then
goto Leave;
end if;
end;
end if;
if Has_Task (Designated_Type (Acc_Type)) then
Check_Restriction (No_Tasking, N);
Check_Restriction (Max_Tasks, N);
@ -893,12 +888,11 @@ package body Sem_Ch4 is
end if;
end if;
Set_Etype (N, Acc_Type);
if not Is_Library_Level_Entity (Acc_Type) then
Check_Restriction (No_Local_Allocators, N);
end if;
<<Leave>>
if Serious_Errors_Detected > Sav_Errs then
Set_Error_Posted (N);
Set_Etype (N, Any_Type);

6
gcc/ada/sem_ch5.adb
View file

@ -307,7 +307,8 @@ package body Sem_Ch5 is
-- get the actual subtype (needed for the unconstrained case). If the
-- operand is the actual in an entry declaration, then within the
-- accept statement it is replaced with a local renaming, which may
-- also have an actual subtype.
-- also have an actual subtype. Likewise for a return object that
-- lives on the secondary stack.
if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) in E_Out_Parameter
@ -318,7 +319,8 @@ package body Sem_Ch5 is
and then Nkind (Parent (Entity (Opnd))) =
N_Object_Renaming_Declaration
and then Nkind (Parent (Parent (Entity (Opnd)))) =
N_Accept_Statement))
N_Accept_Statement)
or else Is_Secondary_Stack_Return_Object (Entity (Opnd)))
then
Opnd_Type := Get_Actual_Subtype (Opnd);

135
gcc/ada/sem_ch6.adb
View file

@ -746,10 +746,6 @@ package body Sem_Ch6 is
-- Ada 2022: Check that the return expression in a No_Return function
-- meets the conditions specified by RM 6.5.1(5.1/5).
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_No_Return_Expression --
--------------------------------
@ -778,135 +774,6 @@ package body Sem_Ch6 is
Return_Expr);
end Check_No_Return_Expression;
-------------------------------------
-- 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));
procedure Error_No_Match (N : Node_Id);
-- Output error messages for case where types do not statically
-- match. N is the location for the messages.
--------------------
-- Error_No_Match --
--------------------
procedure Error_No_Match (N : Node_Id) is
begin
Error_Msg_N
("subtype must statically match function result subtype", N);
if not Predicates_Match (R_Stm_Type, R_Type) then
Error_Msg_Node_2 := R_Type;
Error_Msg_NE
("\predicate of& does not match predicate of&",
N, R_Stm_Type);
end if;
end Error_No_Match;
-- Start of processing for Check_Return_Subtype_Indication
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 Is_Anonymous_Access_Type (R_Type) then
if Is_Anonymous_Access_Type (R_Stm_Type) 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_No_Match (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_No_Match (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 Is_Anonymous_Access_Type (R_Stm_Type) then
pragma Assert (not Is_Anonymous_Access_Type (R_Type));
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_No_Match (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_No_Match (Subtype_Ind);
end if;
end if;
-- All remaining cases are illegal
-- Note: previous versions of this subprogram allowed the return
-- value to be the ancestor of the return type if the return type
-- was a null extension. This was plainly incorrect.
else
Error_Msg_N
("wrong type for return_subtype_indication", Subtype_Ind);
end if;
end Check_Return_Subtype_Indication;
---------------------
-- Local Variables --
---------------------
@ -1016,8 +883,6 @@ package body Sem_Ch6 is
Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
Analyze (Obj_Decl);
Check_Return_Subtype_Indication (Obj_Decl);
if Present (HSS) then
Analyze (HSS);

2
gcc/ada/sem_res.adb
View file

@ -5622,7 +5622,7 @@ package body Sem_Res is
-- caller does use an allocator, it will be caught at the call site.
if No_Pool_Assigned (Typ)
and then not Alloc_For_BIP_Return (N)
and then not For_Special_Return_Object (N)
then
Error_Msg_N ("allocation from empty storage pool!", N);

10
gcc/ada/sinfo.ads
View file

@ -842,10 +842,6 @@ package Sinfo is
-- known at compile time, this field points to an N_Range node with those
-- bounds. Otherwise Empty.
-- Alloc_For_BIP_Return
-- Present in N_Allocator nodes. True if the allocator is one of those
-- generated for a build-in-place return statement.
-- All_Others
-- Present in an N_Others_Choice node. This flag is set for an others
-- exception where all exceptions are to be caught, even those that are
@ -1344,6 +1340,10 @@ package Sinfo is
-- cannot figure it out. If both flags Forwards_OK and Backwards_OK are
-- set, it means that the front end can assure no overlap of operands.
-- For_Special_Return_Object
-- Present in N_Allocator nodes. True if the allocator is generated for
-- the initialization of a special return object.
-- From_Aspect_Specification
-- Processing of aspect specifications typically results in insertion in
-- the tree of corresponding pragma or attribute definition clause nodes.
@ -4777,7 +4777,7 @@ package Sinfo is
-- Subpool_Handle_Name (set to Empty if not present)
-- Storage_Pool
-- Procedure_To_Call
-- Alloc_For_BIP_Return
-- For_Special_Return_Object
-- Null_Exclusion_Present
-- No_Initialization
-- Is_Static_Coextension

5
gcc/ada/treepr.adb
View file

@ -269,8 +269,9 @@ package body Treepr is
function Image (F : Node_Or_Entity_Field) return String is
begin
case F is
when F_Alloc_For_BIP_Return =>
return "Alloc_For_BIP_Return";
-- We special case the following; otherwise the compiler will use
-- the usual Mixed_Case convention.
when F_Assignment_OK =>
return "Assignment_OK";
when F_Backwards_OK =>