@@ -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, 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
@@ -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)
@@ -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.
- if Known_Non_Null (Expr) then
- Set_Is_Known_Non_Null (Def_Id, True);
+ elsif Is_Access_Type (Typ) and then 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,25 +8540,207 @@ 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);
+ Initialize_Return_Object
+ (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After);
- elsif Is_Delayed_Aggregate (Expr_Q)
- and then not No_Initialization (N)
- then
- Convert_Aggr_In_Object_Decl (N);
+ -- Replace the return object declaration with a renaming of a
+ -- dereference of the access value designating the return object.
- elsif Present (Init_Stmt) then
- Insert_Action_After (Init_After, Init_Stmt);
- Set_Expression (N, Empty);
+ Expr_Q :=
+ Make_Explicit_Dereference (Loc,
+ 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 (Obj_Acc_Formal, 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;
@@ -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,84 +3290,77 @@ 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);
- 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;
+ Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
+ Name => Deref));
- -- 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.
+ -- We do not analyze this renaming declaration because this would
+ -- change the subtype of Ent back to a constrained string.
- Set_OK_To_Rename (Ent);
+ Set_Etype (Ent, Atyp);
+ Set_Renamed_Object (Ent, Deref);
+ Set_Analyzed (Decl);
+ end;
+ end if;
-- Catch the static out of range case now
@@ -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.
-
- if Nkind (Par) = N_Object_Declaration and then not Use_Sec_Stack then
+ -- 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
+ 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 --
-------------------------------------------
@@ -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);
@@ -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;
--------------------------------
@@ -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)
@@ -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,
@@ -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),
@@ -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 =>
@@ -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.
@@ -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);
@@ -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);
@@ -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);
@@ -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);
@@ -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
@@ -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 =>