public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-1480] [Ada] Fix dangling bounds for array result of BIP functions
@ 2022-07-05 8:29 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-07-05 8:29 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:4844a259b41b4f31940b478216d6dc9faa2bcbca
commit r13-1480-g4844a259b41b4f31940b478216d6dc9faa2bcbca
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Fri Jun 3 10:27:33 2022 +0200
[Ada] Fix dangling bounds for array result of BIP functions
The implementation of the build-in-place return protocol for functions
whose result type is an unconstrained array type generates dangling
references to local bounds built on the stack for the result as soon as
these bounds are not static. The reason is that the implementation
treats the return object, either explicitly present in the source or
synthesized by the compiler, as a regular constrained object until very
late in the game, although it needs to be ultimately rewritten as the
renaming of the dereference of an allocator with unconstrained designated
type in order for the bounds to be part of the allocation.
Recently a partial fix was implemented for the case where the result is an
aggregate, by preventing the return object from being expanded after it has
been analyzed. However, it does not work for the general case of extended
return statements, because the statements therein are still analyzed with
the constrained version of the return object so, after it is changed into
the unconstrained renaming, this yields (sub)type mismatches.
Therefore this change goes the other way around: it rolls back the partial
fix and instead performs the transformation of the return object into the
unconstrained renaming during the expansion of its declaration, in other
words before statements referencing it, if any, are analyzed, thus ensuring
that they see the final version of the object.
gcc/ada/
* exp_aggr.adb (Expand_Array_Aggregate): Remove obsolete code.
Delay the expansion of aggregates initializing return objects of
build-in-place functions.
* exp_ch3.ads (Ensure_Activation_Chain_And_Master): Delete.
* exp_ch3.adb (Ensure_Activation_Chain_And_Master): Fold back to...
(Expand_N_Object_Declaration): ...here.
Perform the expansion of return objects of build-in-place functions
here instead of...
* exp_ch6.ads (Is_Build_In_Place_Return_Object): Declare.
* exp_ch6.adb (Expand_N_Extended_Return_Statement): ...here.
(Is_Build_In_Place_Result_Type): Alphabetize.
(Is_Build_In_Place_Return_Object): New predicate.
* exp_ch7.adb (Enclosing_Function): Delete.
(Process_Object_Declaration): Tidy up handling of return objects.
* sem_ch3.adb (Analyze_Object_Declaration): Do not decorate and
freeze the actual type if it is the same as the nominal type.
* sem_ch6.adb: Remove use and with clauses for Exp_Ch3.
(Analyze_Function_Return): Analyze again all return objects.
(Create_Extra_Formals): Do not force the definition of an Itype
if the subprogram is a compilation unit.
Diff:
---
gcc/ada/exp_aggr.adb | 19 +-
gcc/ada/exp_ch3.adb | 836 +++++++++++++++++++++++++++++++++++++++++++++----
gcc/ada/exp_ch3.ads | 7 -
gcc/ada/exp_ch6.adb | 857 +++------------------------------------------------
gcc/ada/exp_ch6.ads | 28 +-
gcc/ada/exp_ch7.adb | 28 +-
gcc/ada/sem_ch3.adb | 35 ++-
gcc/ada/sem_ch6.adb | 33 +-
8 files changed, 867 insertions(+), 976 deletions(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 4828406647c..027a6477713 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6603,21 +6603,6 @@ package body Exp_Aggr is
then
return;
- -- Do not expand an aggregate for an array type which contains tasks if
- -- the aggregate is associated with an unexpanded return statement of a
- -- build-in-place function. The aggregate is expanded when the related
- -- return statement (rewritten into an extended return) is processed.
- -- This delay ensures that any temporaries and initialization code
- -- generated for the aggregate appear in the proper return block and
- -- use the correct _chain and _master.
-
- elsif Has_Task (Base_Type (Etype (N)))
- and then Nkind (Parent (N)) = N_Simple_Return_Statement
- and then Is_Build_In_Place_Function
- (Return_Applies_To (Return_Statement_Entity (Parent (N))))
- then
- return;
-
elsif Present (Component_Associations (N))
and then Nkind (First (Component_Associations (N))) =
N_Iterated_Component_Association
@@ -6837,7 +6822,9 @@ package body Exp_Aggr is
or else Parent_Kind = N_Extension_Aggregate
or else Parent_Kind = N_Component_Association
or else (Parent_Kind = N_Object_Declaration
- and then Needs_Finalization (Typ))
+ and then (Needs_Finalization (Typ)
+ or else Is_Build_In_Place_Return_Object
+ (Defining_Identifier (Parent_Node))))
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 143e330018e..7e4c4232e65 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4895,47 +4895,6 @@ package body Exp_Ch3 is
end loop;
end Copy_Discr_Checking_Funcs;
- ----------------------------------------
- -- Ensure_Activation_Chain_And_Master --
- ----------------------------------------
-
- procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id) is
- Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
- Expr : constant Node_Id := Expression (Obj_Decl);
- Expr_Q : Node_Id;
- Typ : constant Entity_Id := Etype (Def_Id);
-
- begin
- pragma Assert (Nkind (Obj_Decl) = N_Object_Declaration);
-
- if Might_Have_Tasks (Typ) then
- Build_Activation_Chain_Entity (Obj_Decl);
-
- if Has_Task (Typ) then
- Build_Master_Entity (Def_Id);
-
- -- Handle objects initialized with BIP function calls
-
- elsif Present (Expr) then
- if Nkind (Expr) = N_Qualified_Expression then
- Expr_Q := Expression (Expr);
- else
- Expr_Q := Expr;
- end if;
-
- if Is_Build_In_Place_Function_Call (Expr_Q)
- or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
- or else
- (Nkind (Expr_Q) = N_Reference
- and then
- Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
- then
- Build_Master_Entity (Def_Id);
- end if;
- end if;
- end if;
- end Ensure_Activation_Chain_And_Master;
-
------------------------------
-- Expand_Freeze_Array_Type --
------------------------------
@@ -6180,6 +6139,47 @@ package body Exp_Ch3 is
-- value, it may be possible to build an equivalent aggregate instead,
-- and prevent an actual call to the initialization procedure.
+ function Build_Heap_Or_Pool_Allocator
+ (Temp_Id : Entity_Id;
+ Temp_Typ : Entity_Id;
+ Func_Id : Entity_Id;
+ Ret_Typ : Entity_Id;
+ Alloc_Expr : Node_Id) return Node_Id;
+ -- Create the statements necessary to allocate a return object on the
+ -- heap or user-defined storage pool. The object may need finalization
+ -- actions depending on the return type.
+ --
+ -- * Controlled case
+ --
+ -- if BIPfinalizationmaster = null then
+ -- Temp_Id := <Alloc_Expr>;
+ -- else
+ -- declare
+ -- type Ptr_Typ is access Ret_Typ;
+ -- for Ptr_Typ'Storage_Pool use
+ -- Base_Pool (BIPfinalizationmaster.all).all;
+ -- Local : Ptr_Typ;
+ --
+ -- begin
+ -- procedure Allocate (...) is
+ -- begin
+ -- System.Storage_Pools.Subpools.Allocate_Any (...);
+ -- end Allocate;
+ --
+ -- Local := <Alloc_Expr>;
+ -- Temp_Id := Temp_Typ (Local);
+ -- end;
+ -- end if;
+ --
+ -- * Non-controlled case
+ --
+ -- Temp_Id := <Alloc_Expr>;
+ --
+ -- Temp_Id is the temporary which is used to reference the internally
+ -- created object in all allocation forms. Temp_Typ is the type of the
+ -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
+ -- type of Func_Id. Alloc_Expr is the actual allocator.
+
procedure Count_Default_Sized_Task_Stacks
(Typ : Entity_Id;
Pri_Stacks : out Int;
@@ -6322,6 +6322,157 @@ package body Exp_Ch3 is
end if;
end Build_Equivalent_Aggregate;
+ ----------------------------------
+ -- Build_Heap_Or_Pool_Allocator --
+ ----------------------------------
+
+ function Build_Heap_Or_Pool_Allocator
+ (Temp_Id : Entity_Id;
+ Temp_Typ : Entity_Id;
+ Func_Id : Entity_Id;
+ Ret_Typ : Entity_Id;
+ Alloc_Expr : Node_Id) return Node_Id
+ is
+ begin
+ pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
+ -- Processing for objects that require finalization actions
+
+ if Needs_Finalization (Ret_Typ) then
+ declare
+ Decls : constant List_Id := New_List;
+ Fin_Mas_Id : constant Entity_Id :=
+ Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
+ Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr);
+ Stmts : constant List_Id := New_List;
+ Local_Id : Entity_Id;
+ Pool_Id : Entity_Id;
+ Ptr_Typ : Entity_Id;
+
+ begin
+ -- Generate:
+ -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
+
+ Pool_Id := Make_Temporary (Loc, 'P');
+
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
+ Parameter_Associations => New_List (
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
+
+ -- Create an access type which uses the storage pool of the
+ -- caller's master. This additional type is necessary because
+ -- the finalization master cannot be associated with the type
+ -- of the temporary. Otherwise the secondary stack allocation
+ -- will fail.
+
+ -- Generate:
+ -- type Ptr_Typ is access Ret_Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'P');
+
+ Append_To (Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ret_Typ, Loc))));
+
+ -- Perform minor decoration in order to set the master and the
+ -- storage pool attributes.
+
+ Mutate_Ekind (Ptr_Typ, E_Access_Type);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
+ Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
+
+ -- Create the temporary, generate:
+ -- Local_Id : Ptr_Typ;
+
+ Local_Id := Make_Temporary (Loc, 'T');
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Local_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Ptr_Typ, Loc)));
+
+ -- Allocate the object, generate:
+ -- Local_Id := <Alloc_Expr>;
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Local_Id, Loc),
+ Expression => Alloc_Expr));
+
+ -- Generate:
+ -- Temp_Id := Temp_Typ (Local_Id);
+
+ Append_To (Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp_Id, Loc),
+ Expression =>
+ Unchecked_Convert_To (Temp_Typ,
+ New_Occurrence_Of (Local_Id, Loc))));
+
+ -- Wrap the allocation in a block. This is further conditioned
+ -- by checking the caller finalization master at runtime. A
+ -- null value indicates a non-existent master, most likely due
+ -- to a Finalize_Storage_Only allocation.
+
+ -- Generate:
+ -- if BIPfinalizationmaster = null then
+ -- Temp_Id := <Orig_Expr>;
+ -- else
+ -- declare
+ -- <Decls>
+ -- begin
+ -- <Stmts>
+ -- end;
+ -- end if;
+
+ return
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
+ Right_Opnd => Make_Null (Loc)),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp_Id, Loc),
+ Expression => Orig_Expr)),
+
+ Else_Statements => New_List (
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts))));
+ end;
+
+ -- For all other cases, generate:
+ -- Temp_Id := <Alloc_Expr>;
+
+ else
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp_Id, Loc),
+ Expression => Alloc_Expr);
+ end if;
+ end Build_Heap_Or_Pool_Allocator;
+
-------------------------------------
-- Count_Default_Sized_Task_Stacks --
-------------------------------------
@@ -6869,7 +7020,27 @@ package body Exp_Ch3 is
-- also that a Master variable is established (and that the appropriate
-- enclosing construct is established as a task master).
- Ensure_Activation_Chain_And_Master (N);
+ if Has_Task (Typ) or else Might_Have_Tasks (Typ) then
+ Build_Activation_Chain_Entity (N);
+
+ if Has_Task (Typ) then
+ Build_Master_Entity (Def_Id);
+
+ -- Handle objects initialized with BIP function calls
+
+ elsif Present (Expr) then
+ Expr_Q := Unqualify (Expr);
+
+ if Is_Build_In_Place_Function_Call (Expr_Q)
+ or else Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ or else (Nkind (Expr_Q) = N_Reference
+ and then
+ Is_Build_In_Place_Function_Call (Prefix (Expr_Q)))
+ then
+ Build_Master_Entity (Def_Id);
+ end if;
+ end if;
+ end if;
-- If No_Implicit_Heap_Allocations or No_Implicit_Task_Allocations
-- restrictions are active then default-sized secondary stacks are
@@ -6905,6 +7076,7 @@ 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
@@ -6964,7 +7136,9 @@ package body Exp_Ch3 is
end if;
end if;
- Default_Initialize_Object (Init_After);
+ if not Is_Build_In_Place_Return_Object (Def_Id) then
+ Default_Initialize_Object (Init_After);
+ end if;
-- Generate attribute for Persistent_BSS if needed
@@ -7022,7 +7196,9 @@ package body Exp_Ch3 is
Expander_Mode_Restore;
end if;
- Convert_Aggr_In_Object_Decl (N);
+ if not Is_Build_In_Place_Return_Object (Def_Id) then
+ Convert_Aggr_In_Object_Decl (N);
+ end if;
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the declared object
@@ -7091,13 +7267,12 @@ package body Exp_Ch3 is
then
pragma Assert (Is_Class_Wide_Type (Typ));
- -- If the object is a return object of an inherently limited type,
- -- which implies build-in-place treatment, bypass the special
+ -- If the object is a built-in-place return object, 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_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
+ if Is_Build_In_Place_Return_Object (Def_Id) then
null;
elsif Tagged_Type_Expansion then
@@ -7323,9 +7498,12 @@ package body Exp_Ch3 is
Set_SPARK_Pragma_Inherited (Def_Id, Save_SPI);
end;
end;
- end if;
- return;
+ return;
+
+ else
+ return;
+ end if;
-- Common case of explicit object initialization
@@ -7598,11 +7776,11 @@ package body Exp_Ch3 is
Name => New_Occurrence_Of (Def_Id, Loc),
Expression => Relocate_Node (Expr));
begin
- Set_Expression (N, Empty);
- Set_No_Initialization (N);
Set_Assignment_OK (Name (Stat));
Set_No_Ctrl_Actions (Stat);
- Insert_After_And_Analyze (Init_After, Stat);
+ Insert_Action_After (Init_After, Stat);
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
end;
end if;
end if;
@@ -7699,6 +7877,554 @@ package body Exp_Ch3 is
end;
end if;
+ -- If this is the return object of a build-in-place function, locate the
+ -- implicit BIPaccess parameter designating the caller-supplied return
+ -- object and convert the declaration to a renaming of a dereference of
+ -- this parameter. If the declaration includes an expression, add an
+ -- assignment statement to ensure the return object gets initialized.
+
+ -- Result : T [:= <expression>];
+
+ -- is converted to
+
+ -- Result : T renames BIPaccess.all;
+ -- [Result := <expression>;]
+
+ -- in the constrained case, or to
+
+ -- type Txx is access all ...;
+ -- Rxx : Txx := null;
+
+ -- if BIPalloc = 1 then
+ -- Rxx := BIPaccess;
+ -- elsif BIPalloc = 2 then
+ -- Rxx := new <expression-type>[storage_pool =
+ -- system__secondary_stack__ss_pool][procedure_to_call =
+ -- system__secondary_stack__ss_allocate];
+ -- elsif BIPalloc = 3 then
+ -- Rxx := new <expression-type>
+ -- elsif BIPalloc = 4 then
+ -- Pxx : system__storage_pools__root_storage_pool renames
+ -- BIPstoragepool.all;
+ -- Rxx := new <expression-type>[storage_pool =
+ -- Pxx][procedure_to_call =
+ -- system__storage_pools__allocate_any];
+ -- else
+ -- [program_error "build in place mismatch"]
+ -- end if;
+
+ -- Result : T renames Rxx.all;
+ -- Result := <expression>;
+
+ -- in the unconstrained case.
+
+ if Is_Build_In_Place_Return_Object (Def_Id) then
+ declare
+ Func_Id : constant Entity_Id :=
+ Return_Applies_To (Scope (Def_Id));
+ Ret_Obj_Typ : constant Entity_Id := Etype (Def_Id);
+
+ Init_Stmt : Node_Id;
+ Obj_Acc_Formal : Entity_Id;
+
+ begin
+ -- Retrieve the implicit access parameter passed by the caller
+
+ Obj_Acc_Formal :=
+ Build_In_Place_Formal (Func_Id, BIP_Object_Access);
+
+ -- If the return object's declaration includes an expression
+ -- and the declaration isn't marked as No_Initialization, then
+ -- we need to generate an assignment to the object and insert
+ -- it after the declaration before rewriting it as a renaming
+ -- (otherwise we'll lose the initialization). The case where
+ -- the result type is an interface (or class-wide interface)
+ -- is also excluded because the context of the function call
+ -- must be unconstrained, so the initialization will always
+ -- be done as part of an allocator evaluation (storage pool
+ -- or secondary stack), never to a constrained target object
+ -- passed in by the caller. Besides the assignment being
+ -- unneeded in this case, it avoids problems with trying to
+ -- generate a dispatching assignment when the return expression
+ -- is a nonlimited descendant of a limited interface (the
+ -- interface has no assignment operation).
+
+ if Present (Expr_Q)
+ and then not Is_Delayed_Aggregate (Expr_Q)
+ and then not No_Initialization (N)
+ and then not Is_Interface (Etype (Def_Id))
+ then
+ if Is_Class_Wide_Type (Etype (Def_Id))
+ and then not Is_Class_Wide_Type (Etype (Expr_Q))
+ then
+ Init_Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Def_Id), Loc),
+ Expression => New_Copy_Tree (Expr_Q)));
+
+ else
+ Init_Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Def_Id, Loc),
+ Expression => New_Copy_Tree (Expr_Q));
+ end if;
+
+ Set_Assignment_OK (Name (Init_Stmt));
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ else
+ Init_Stmt := Empty;
+ end if;
+
+ -- When the function's subtype is unconstrained, a run-time
+ -- test may be needed to decide the form of allocation to use
+ -- for the return object. The function has an implicit formal
+ -- parameter indicating this. If the BIP_Alloc_Form formal has
+ -- the value one, then the caller has passed access to an
+ -- existing object for use as the return object. If the value
+ -- is two, then the return object must be allocated on the
+ -- secondary stack. Otherwise, the object must be allocated in
+ -- a storage pool. We generate an if statement to test the
+ -- implicit allocation formal and initialize a local access
+ -- value appropriately, creating allocators in the secondary
+ -- stack and global heap cases. The special formal also exists
+ -- and must be tested when the function has a tagged result,
+ -- even when the result subtype is constrained, because in
+ -- general such functions can be called in dispatching contexts
+ -- and must be handled similarly to functions with a class-wide
+ -- result.
+
+ if Needs_BIP_Alloc_Form (Func_Id) then
+ declare
+ Desig_Typ : constant Entity_Id :=
+ (if Ekind (Ret_Obj_Typ) = E_Array_Subtype
+ then Etype (Func_Id) else Ret_Obj_Typ);
+ -- Ensure that the we use a fat pointer when allocating
+ -- an unconstrained array on the heap. In this case the
+ -- result object type is a constrained array type even
+ -- though the function 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');
+
+ Alloc_Obj_Id : Entity_Id;
+ Alloc_Obj_Decl : Node_Id;
+ Alloc_Stmt : Node_Id;
+ Guard_Except : Node_Id;
+ Heap_Allocator : Node_Id;
+ Pool_Decl : Node_Id;
+ Pool_Allocator : Node_Id;
+ Ptr_Type_Decl : Node_Id;
+ Ref_Type : Entity_Id;
+ SS_Allocator : Node_Id;
+
+ begin
+ -- Create an access type designating the function's
+ -- result subtype.
+
+ Ref_Type := Make_Temporary (Loc, 'A');
+
+ Ptr_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ref_Type,
+ 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);
+
+ -- Create an access object that will be initialized to an
+ -- access value denoting the return object, either coming
+ -- from an implicit access value passed in by the caller
+ -- or from the result of an allocator.
+
+ Alloc_Obj_Id := Make_Temporary (Loc, 'R');
+ Set_Etype (Alloc_Obj_Id, Ref_Type);
+
+ Alloc_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Alloc_Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Ref_Type, Loc));
+
+ Insert_Action (N, Alloc_Obj_Decl);
+
+ -- Create allocators for both the secondary stack and
+ -- global heap. If there's an initialization expression,
+ -- then create these as initialized allocators.
+
+ 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.
+
+ Heap_Allocator :=
+ 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 (Ret_Obj_Typ) then
+ Heap_Allocator :=
+ Make_Allocator (Loc,
+ Expression =>
+ New_Occurrence_Of (Etype (Expr_Q), Loc));
+
+ else
+ Heap_Allocator :=
+ Make_Allocator (Loc,
+ Expression =>
+ New_Occurrence_Of (Ret_Obj_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 (Heap_Allocator);
+ 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. Note that this flag
+ -- will be inherited by the copies made below.
+
+ Set_Alloc_For_BIP_Return (Heap_Allocator);
+
+ -- 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 := New_Copy_Tree (Heap_Allocator);
+
+ pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
+
+ -- Do not generate the renaming of the build-in-place
+ -- pool parameter on ZFP because the parameter is not
+ -- created in the first place.
+
+ if RTE_Available (RE_Root_Storage_Pool_Ptr) then
+ Pool_Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pool_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Root_Storage_Pool), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of
+ (Build_In_Place_Formal
+ (Func_Id, BIP_Storage_Pool), Loc)));
+ Set_Storage_Pool (Pool_Allocator, Pool_Id);
+ Set_Procedure_To_Call
+ (Pool_Allocator, RTE (RE_Allocate_Any));
+ else
+ Pool_Decl := Make_Null_Statement (Loc);
+ end if;
+
+ -- If the No_Allocators restriction is active, then only
+ -- an allocator for secondary stack allocation is needed.
+ -- It's OK for such allocators to have Comes_From_Source
+ -- set to False, because gigi knows not to flag them as
+ -- being a violation of No_Implicit_Heap_Allocations.
+
+ if Restriction_Active (No_Allocators) then
+ SS_Allocator := Heap_Allocator;
+ Heap_Allocator := Make_Null (Loc);
+ Pool_Allocator := Make_Null (Loc);
+
+ -- Otherwise the heap and pool allocators may be needed,
+ -- so we make another allocator for secondary stack
+ -- allocation.
+
+ else
+ SS_Allocator := New_Copy_Tree (Heap_Allocator);
+
+ pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
+
+ -- The heap and pool allocators are marked as
+ -- Comes_From_Source since they correspond to an
+ -- explicit user-written allocator (that is, it will
+ -- only be executed on behalf of callers that call the
+ -- function as initialization for such an allocator).
+ -- Prevents errors when No_Implicit_Heap_Allocations
+ -- is in force.
+
+ Set_Comes_From_Source (Heap_Allocator, True);
+ Set_Comes_From_Source (Pool_Allocator, True);
+ end if;
+
+ -- The allocator is returned on the secondary stack
+
+ Check_Restriction (No_Secondary_Stack, N);
+ Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
+ Set_Procedure_To_Call
+ (SS_Allocator, RTE (RE_SS_Allocate));
+
+ -- The allocator is returned on the secondary stack,
+ -- so indicate that the function return, as well as
+ -- all blocks that encloses the allocator, must not
+ -- release it. The flags must be set now because
+ -- the decision to use the secondary stack is done
+ -- very late in the course of expanding the return
+ -- statement, past the point where these flags are
+ -- normally set.
+
+ Set_Uses_Sec_Stack (Func_Id);
+ Set_Uses_Sec_Stack (Scope (Def_Id));
+ Set_Sec_Stack_Needed_For_Return (Scope (Def_Id));
+
+ -- Guard against poor expansion on the caller side by
+ -- using a raise statement to catch out-of-range values
+ -- of formal parameter BIP_Alloc_Form.
+
+ if Exceptions_OK then
+ Guard_Except :=
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Build_In_Place_Mismatch);
+ else
+ Guard_Except := Make_Null_Statement (Loc);
+ end if;
+
+ -- Create an if statement to test the BIP_Alloc_Form
+ -- formal and initialize the access object to either the
+ -- BIP_Object_Access formal (BIP_Alloc_Form =
+ -- Caller_Allocation), the result of allocating the
+ -- object in the secondary stack (BIP_Alloc_Form =
+ -- Secondary_Stack), or else an allocator to create the
+ -- return object in the heap or user-defined pool
+ -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
+
+ -- ??? An unchecked type conversion must be made in the
+ -- case of assigning the access object formal to the
+ -- local access object, because a normal conversion would
+ -- be illegal in some cases (such as converting access-
+ -- to-unconstrained to access-to-constrained), but the
+ -- the unchecked conversion will presumably fail to work
+ -- right in just such cases. It's not clear at all how to
+ -- handle this. ???
+
+ Alloc_Stmt :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (Caller_Allocation)))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Alloc_Obj_Id, Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Ref_Type,
+ New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
+
+ Elsif_Parts => New_List (
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (Secondary_Stack)))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Alloc_Obj_Id, Loc),
+ Expression => SS_Allocator))),
+
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (Global_Heap)))),
+
+ Then_Statements => New_List (
+ Build_Heap_Or_Pool_Allocator
+ (Temp_Id => Alloc_Obj_Id,
+ Temp_Typ => Ref_Type,
+ Func_Id => Func_Id,
+ Ret_Typ => Desig_Typ,
+ Alloc_Expr => Heap_Allocator))),
+
+ -- ???If all is well, we can put the following
+ -- 'elsif' in the 'else', but this is a useful
+ -- self-check in case caller and callee don't agree
+ -- on whether BIPAlloc and so on should be passed.
+
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (User_Storage_Pool)))),
+
+ Then_Statements => New_List (
+ Pool_Decl,
+ Build_Heap_Or_Pool_Allocator
+ (Temp_Id => Alloc_Obj_Id,
+ Temp_Typ => Ref_Type,
+ Func_Id => Func_Id,
+ Ret_Typ => Desig_Typ,
+ Alloc_Expr => Pool_Allocator)))),
+
+ -- Raise Program_Error if it's none of the above;
+ -- this is a compiler bug.
+
+ Else_Statements => New_List (Guard_Except));
+
+ -- If a separate initialization assignment was created
+ -- earlier, append that following the assignment of the
+ -- implicit access formal to the access object, to ensure
+ -- that the return object is initialized in that case. In
+ -- this situation, the target of the assignment must be
+ -- rewritten to denote a dereference of the access to the
+ -- return object passed in by the caller.
+
+ if Present (Init_Stmt) then
+ Set_Name (Init_Stmt,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
+ Set_Assignment_OK (Name (Init_Stmt));
+
+ Append_To (Then_Statements (Alloc_Stmt), Init_Stmt);
+ Init_Stmt := Empty;
+ end if;
+
+ Insert_Action (N, Alloc_Stmt, Suppress => All_Checks);
+
+ -- From now on, the type of the return object is the
+ -- designated type.
+
+ Set_Etype (Def_Id, Desig_Typ);
+
+ -- Remember the local access object for use in the
+ -- dereference of the renaming created below.
+
+ Obj_Acc_Formal := Alloc_Obj_Id;
+ end;
+
+ -- When the function's subtype is unconstrained and a run-time
+ -- test is not needed, we nevertheless need to build the return
+ -- using the function's result subtype.
+
+ elsif not Is_Constrained (Underlying_Type (Etype (Func_Id))) then
+ declare
+ Alloc_Obj_Id : Entity_Id;
+ Alloc_Obj_Decl : Node_Id;
+ Ptr_Type_Decl : Node_Id;
+ Ref_Type : Entity_Id;
+
+ begin
+ -- Create an access type designating the function's
+ -- result subtype.
+
+ Ref_Type := Make_Temporary (Loc, 'A');
+
+ Ptr_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ref_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Ret_Obj_Typ, Loc)));
+
+ Insert_Action (N, Ptr_Type_Decl);
+
+ -- Create an access object initialized to the conversion
+ -- of the implicit access value passed in by the caller.
+
+ Alloc_Obj_Id := Make_Temporary (Loc, 'R');
+
+ -- See the ??? comment a few lines above about the use of
+ -- an unchecked conversion here.
+
+ Alloc_Obj_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Alloc_Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Ref_Type, Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Ref_Type,
+ New_Occurrence_Of (Obj_Acc_Formal, Loc)));
+
+ Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks);
+
+ -- Remember the local access object for use in the
+ -- dereference of the renaming created below.
+
+ Obj_Acc_Formal := Alloc_Obj_Id;
+ end;
+ end if;
+
+ -- 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;
+
+ -- 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));
+ Set_Etype (Expr_Q, Etype (Def_Id));
+
+ Rewrite_As_Renaming := True;
+ end;
+ end if;
+
-- Final transformation - turn the object declaration into a renaming
-- if appropriate. If this is the completion of a deferred constant
-- declaration, then this transformation generates what would be
@@ -7707,8 +8433,8 @@ package body Exp_Ch3 is
if Rewrite_As_Renaming then
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Defining_Identifier (N),
- Subtype_Mark => Obj_Def,
+ Defining_Identifier => Def_Id,
+ Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc),
Name => Expr_Q));
-- We do not analyze this renaming declaration, because all its
@@ -7716,7 +8442,7 @@ package body Exp_Ch3 is
-- ahead and analyze it, we would in effect be trying to generate
-- another declaration of X, which won't do.
- Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
+ Set_Renamed_Object (Def_Id, Expr_Q);
Set_Analyzed (N);
-- We do need to deal with debug issues for this renaming
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index ca8a5507674..f7d43c4aa7e 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -113,13 +113,6 @@ package Exp_Ch3 is
-- Build the body of the equality function Body_Id for the untagged variant
-- record Typ with the given parameters specification list.
- procedure Ensure_Activation_Chain_And_Master (Obj_Decl : Node_Id);
- -- If tasks are being declared (or might be declared) by the given object
- -- declaration then ensure to have an activation chain defined for the
- -- tasks (has no effect if we already have one), and also that a Master
- -- variable is established (and that the appropriate enclosing construct
- -- is established as a task master).
-
function Freeze_Type (N : Node_Id) return Boolean;
-- This function executes the freezing actions associated with the given
-- freeze type node N and returns True if the node is to be deleted. We
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 14e0498e2ac..d6d9d008a55 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5079,48 +5079,15 @@ package body Exp_Ch6 is
-- (in which case default initial values might need to be set)).
procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- function Build_Heap_Or_Pool_Allocator
- (Temp_Id : Entity_Id;
- Temp_Typ : Entity_Id;
- Func_Id : Entity_Id;
- Ret_Typ : Entity_Id;
- Alloc_Expr : Node_Id) return Node_Id;
- -- Create the statements necessary to allocate a return object on the
- -- heap or user-defined storage pool. The object may need finalization
- -- actions depending on the return type.
- --
- -- * Controlled case
- --
- -- if BIPfinalizationmaster = null then
- -- Temp_Id := <Alloc_Expr>;
- -- else
- -- declare
- -- type Ptr_Typ is access Ret_Typ;
- -- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPfinalizationmaster.all).all;
- -- Local : Ptr_Typ;
- --
- -- begin
- -- procedure Allocate (...) is
- -- begin
- -- System.Storage_Pools.Subpools.Allocate_Any (...);
- -- end Allocate;
- --
- -- Local := <Alloc_Expr>;
- -- Temp_Id := Temp_Typ (Local);
- -- end;
- -- end if;
- --
- -- * Non-controlled case
- --
- -- Temp_Id := <Alloc_Expr>;
- --
- -- Temp_Id is the temporary which is used to reference the internally
- -- created object in all allocation forms. Temp_Typ is the type of the
- -- temporary. Func_Id is the enclosing function. Ret_Typ is the return
- -- type of Func_Id. Alloc_Expr is the actual allocator.
+ Loc : constant Source_Ptr := Sloc (N);
+ Func_Id : constant Entity_Id :=
+ Return_Applies_To (Return_Statement_Entity (N));
+ Is_BIP_Func : constant Boolean :=
+ Is_Build_In_Place_Function (Func_Id);
+ Ret_Obj_Id : constant Entity_Id :=
+ First_Entity (Return_Statement_Entity (N));
+ Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
+ Ret_Typ : constant Entity_Id := Etype (Func_Id);
function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id;
-- Construct a call to System.Tasking.Stages.Move_Activation_Chain
@@ -5132,173 +5099,6 @@ package body Exp_Ch6 is
-- Func_Id is the entity of the function where the extended return
-- statement appears.
- ----------------------------------
- -- Build_Heap_Or_Pool_Allocator --
- ----------------------------------
-
- function Build_Heap_Or_Pool_Allocator
- (Temp_Id : Entity_Id;
- Temp_Typ : Entity_Id;
- Func_Id : Entity_Id;
- Ret_Typ : Entity_Id;
- Alloc_Expr : Node_Id) return Node_Id
- is
- begin
- pragma Assert (Is_Build_In_Place_Function (Func_Id));
-
- -- Processing for objects that require finalization actions
-
- if Needs_Finalization (Ret_Typ) then
- declare
- Decls : constant List_Id := New_List;
- Fin_Mas_Id : constant Entity_Id :=
- Build_In_Place_Formal
- (Func_Id, BIP_Finalization_Master);
- Orig_Expr : constant Node_Id :=
- New_Copy_Tree
- (Source => Alloc_Expr,
- Scopes_In_EWA_OK => True);
- Stmts : constant List_Id := New_List;
- Desig_Typ : Entity_Id;
- Local_Id : Entity_Id;
- Pool_Id : Entity_Id;
- Ptr_Typ : Entity_Id;
-
- begin
- -- Generate:
- -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
-
- Pool_Id := Make_Temporary (Loc, 'P');
-
- Append_To (Decls,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Pool_Id,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
- Parameter_Associations => New_List (
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
-
- -- Create an access type which uses the storage pool of the
- -- caller's master. This additional type is necessary because
- -- the finalization master cannot be associated with the type
- -- of the temporary. Otherwise the secondary stack allocation
- -- will fail.
-
- Desig_Typ := Ret_Typ;
-
- -- Ensure that the build-in-place machinery uses a fat pointer
- -- when allocating an unconstrained array on the heap. In this
- -- case the result object type is a constrained array type even
- -- though the function type is unconstrained.
-
- if Ekind (Desig_Typ) = E_Array_Subtype then
- Desig_Typ := Base_Type (Desig_Typ);
- end if;
-
- -- Generate:
- -- type Ptr_Typ is access Desig_Typ;
-
- Ptr_Typ := Make_Temporary (Loc, 'P');
-
- Append_To (Decls,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Desig_Typ, Loc))));
-
- -- Perform minor decoration in order to set the master and the
- -- storage pool attributes.
-
- Mutate_Ekind (Ptr_Typ, E_Access_Type);
- Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
- Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-
- -- Create the temporary, generate:
- -- Local_Id : Ptr_Typ;
-
- Local_Id := Make_Temporary (Loc, 'T');
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Local_Id,
- Object_Definition =>
- New_Occurrence_Of (Ptr_Typ, Loc)));
-
- -- Allocate the object, generate:
- -- Local_Id := <Alloc_Expr>;
-
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Local_Id, Loc),
- Expression => Alloc_Expr));
-
- -- Generate:
- -- Temp_Id := Temp_Typ (Local_Id);
-
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression =>
- Unchecked_Convert_To (Temp_Typ,
- New_Occurrence_Of (Local_Id, Loc))));
-
- -- Wrap the allocation in a block. This is further conditioned
- -- by checking the caller finalization master at runtime. A
- -- null value indicates a non-existent master, most likely due
- -- to a Finalize_Storage_Only allocation.
-
- -- Generate:
- -- if BIPfinalizationmaster = null then
- -- Temp_Id := <Orig_Expr>;
- -- else
- -- declare
- -- <Decls>
- -- begin
- -- <Stmts>
- -- end;
- -- end if;
-
- return
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
- Right_Opnd => Make_Null (Loc)),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression => Orig_Expr)),
-
- Else_Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts))));
- end;
-
- -- For all other cases, generate:
- -- Temp_Id := <Alloc_Expr>;
-
- else
- return
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp_Id, Loc),
- Expression => Alloc_Expr);
- end if;
- end Build_Heap_Or_Pool_Allocator;
-
---------------------------
-- Move_Activation_Chain --
---------------------------
@@ -5331,15 +5131,6 @@ package body Exp_Ch6 is
-- Local variables
- Func_Id : constant Entity_Id :=
- Return_Applies_To (Return_Statement_Entity (N));
- Is_BIP_Func : constant Boolean :=
- Is_Build_In_Place_Function (Func_Id);
- Ret_Obj_Id : constant Entity_Id :=
- First_Entity (Return_Statement_Entity (N));
- Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id);
- Ret_Typ : constant Entity_Id := Etype (Func_Id);
-
Exp : Node_Id;
HSS : Node_Id;
Result : Node_Id;
@@ -5508,13 +5299,6 @@ package body Exp_Ch6 is
end;
end if;
- -- Build a simple_return_statement that returns the return object
-
- Return_Stmt :=
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
- Append_To (Stmts, Return_Stmt);
-
HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
end if;
@@ -5535,571 +5319,12 @@ package body Exp_Ch6 is
Set_Identifier
(Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
- -- If the object decl was already rewritten as a renaming, then we
- -- don't want to do the object allocation and transformation of
- -- the return object declaration to a renaming. This case occurs
- -- when the return object is initialized by a call to another
- -- build-in-place function, and that function is responsible for
- -- the allocation of the return object.
-
- if Is_BIP_Func
- and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration
- then
- pragma Assert
- (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
- and then
-
- -- It is a regular BIP object declaration
-
- (Is_Build_In_Place_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl)))
-
- -- It is a BIP object declaration that displaces the pointer
- -- to the object to reference a converted interface type.
-
- or else
- Present (Unqual_BIP_Iface_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl))))));
-
- elsif Is_BIP_Func then
-
- -- Locate the implicit access parameter associated with the
- -- caller-supplied return object and convert the return
- -- statement's return object declaration to a renaming of a
- -- dereference of the access parameter. If the return object's
- -- declaration includes an expression that has not already been
- -- expanded as separate assignments, then add an assignment
- -- statement to ensure the return object gets initialized.
-
- -- declare
- -- Result : T [:= <expression>];
- -- begin
- -- ...
-
- -- is converted to
-
- -- declare
- -- Result : T renames FuncRA.all;
- -- [Result := <expression;]
- -- begin
- -- ...
-
- declare
- Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl);
- Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id);
-
- Init_Assignment : Node_Id := Empty;
- Obj_Acc_Formal : Entity_Id;
- Obj_Acc_Deref : Node_Id;
- Obj_Alloc_Formal : Entity_Id;
-
- begin
- -- Retrieve the implicit access parameter passed by the caller
-
- Obj_Acc_Formal :=
- Build_In_Place_Formal (Func_Id, BIP_Object_Access);
-
- -- If the return object's declaration includes an expression
- -- and the declaration isn't marked as No_Initialization, then
- -- we need to generate an assignment to the object and insert
- -- it after the declaration before rewriting it as a renaming
- -- (otherwise we'll lose the initialization). The case where
- -- the result type is an interface (or class-wide interface)
- -- is also excluded because the context of the function call
- -- must be unconstrained, so the initialization will always
- -- be done as part of an allocator evaluation (storage pool
- -- or secondary stack), never to a constrained target object
- -- passed in by the caller. Besides the assignment being
- -- unneeded in this case, it avoids problems with trying to
- -- generate a dispatching assignment when the return expression
- -- is a nonlimited descendant of a limited interface (the
- -- interface has no assignment operation).
-
- if Present (Ret_Obj_Expr)
- and then not No_Initialization (Ret_Obj_Decl)
- and then not Is_Interface (Ret_Obj_Typ)
- then
- Init_Assignment :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
- Expression =>
- New_Copy_Tree
- (Source => Ret_Obj_Expr,
- Scopes_In_EWA_OK => True));
-
- Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
- Set_Assignment_OK (Name (Init_Assignment));
- Set_No_Ctrl_Actions (Init_Assignment);
-
- Set_Parent (Name (Init_Assignment), Init_Assignment);
- Set_Parent (Expression (Init_Assignment), Init_Assignment);
-
- Set_Expression (Ret_Obj_Decl, Empty);
-
- if Is_Class_Wide_Type (Etype (Ret_Obj_Id))
- and then not Is_Class_Wide_Type
- (Etype (Expression (Init_Assignment)))
- then
- Rewrite (Expression (Init_Assignment),
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Ret_Obj_Id), Loc),
- Expression =>
- Relocate_Node (Expression (Init_Assignment))));
- end if;
-
- -- In the case of functions where the calling context can
- -- determine the form of allocation needed, initialization
- -- is done with each part of the if statement that handles
- -- the different forms of allocation (this is true for
- -- unconstrained, tagged, and controlled result subtypes).
-
- if not Needs_BIP_Alloc_Form (Func_Id) then
- Insert_After (Ret_Obj_Decl, Init_Assignment);
- end if;
- end if;
-
- -- When the function's subtype is unconstrained, a run-time
- -- test may be needed to decide the form of allocation to use
- -- for the return object. The function has an implicit formal
- -- parameter indicating this. If the BIP_Alloc_Form formal has
- -- the value one, then the caller has passed access to an
- -- existing object for use as the return object. If the value
- -- is two, then the return object must be allocated on the
- -- secondary stack. Otherwise, the object must be allocated in
- -- a storage pool. We generate an if statement to test the
- -- implicit allocation formal and initialize a local access
- -- value appropriately, creating allocators in the secondary
- -- stack and global heap cases. The special formal also exists
- -- and must be tested when the function has a tagged result,
- -- even when the result subtype is constrained, because in
- -- general such functions can be called in dispatching contexts
- -- and must be handled similarly to functions with a class-wide
- -- result.
-
- if Needs_BIP_Alloc_Form (Func_Id) then
- Obj_Alloc_Formal :=
- Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
-
- declare
- Pool_Id : constant Entity_Id :=
- Make_Temporary (Loc, 'P');
- Alloc_Obj_Id : Entity_Id;
- Alloc_Obj_Decl : Node_Id;
- Alloc_If_Stmt : Node_Id;
- Guard_Except : Node_Id;
- Heap_Allocator : Node_Id;
- Pool_Decl : Node_Id;
- Pool_Allocator : Node_Id;
- Ptr_Type_Decl : Node_Id;
- Ref_Type : Entity_Id;
- SS_Allocator : Node_Id;
-
- begin
- -- Create an access type designating the function's
- -- result subtype.
-
- Ref_Type := Make_Temporary (Loc, 'A');
-
- Ptr_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Ret_Obj_Typ, Loc)));
-
- Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
-
- -- Create an access object that will be initialized to an
- -- access value denoting the return object, either coming
- -- from an implicit access value passed in by the caller
- -- or from the result of an allocator.
-
- Alloc_Obj_Id := Make_Temporary (Loc, 'R');
- Set_Etype (Alloc_Obj_Id, Ref_Type);
-
- Alloc_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Alloc_Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Ref_Type, Loc));
-
- Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
-
- -- Create allocators for both the secondary stack and
- -- global heap. If there's an initialization expression,
- -- then create these as initialized allocators.
-
- if Present (Ret_Obj_Expr)
- and then not No_Initialization (Ret_Obj_Decl)
- 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.
-
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (Etype (Ret_Obj_Expr), Loc),
- Expression =>
- New_Copy_Tree
- (Source => Ret_Obj_Expr,
- Scopes_In_EWA_OK => True)));
-
- 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 (Ret_Obj_Typ) then
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of
- (Etype (Ret_Obj_Expr), Loc));
- else
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of (Ret_Obj_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 (Heap_Allocator);
- 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. Note that this flag
- -- will be inherited by the copies made below.
-
- Set_Alloc_For_BIP_Return (Heap_Allocator);
-
- -- 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 :=
- New_Copy_Tree
- (Source => Heap_Allocator,
- Scopes_In_EWA_OK => True);
-
- pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
-
- -- Do not generate the renaming of the build-in-place
- -- pool parameter on ZFP because the parameter is not
- -- created in the first place.
-
- if RTE_Available (RE_Root_Storage_Pool_Ptr) then
- Pool_Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Pool_Id,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
- Make_Explicit_Dereference (Loc,
- New_Occurrence_Of
- (Build_In_Place_Formal
- (Func_Id, BIP_Storage_Pool), Loc)));
- Set_Storage_Pool (Pool_Allocator, Pool_Id);
- Set_Procedure_To_Call
- (Pool_Allocator, RTE (RE_Allocate_Any));
- else
- Pool_Decl := Make_Null_Statement (Loc);
- end if;
-
- -- If the No_Allocators restriction is active, then only
- -- an allocator for secondary stack allocation is needed.
- -- It's OK for such allocators to have Comes_From_Source
- -- set to False, because gigi knows not to flag them as
- -- being a violation of No_Implicit_Heap_Allocations.
-
- if Restriction_Active (No_Allocators) then
- SS_Allocator := Heap_Allocator;
- Heap_Allocator := Make_Null (Loc);
- Pool_Allocator := Make_Null (Loc);
-
- -- Otherwise the heap and pool allocators may be needed,
- -- so we make another allocator for secondary stack
- -- allocation.
-
- else
- SS_Allocator :=
- New_Copy_Tree
- (Source => Heap_Allocator,
- Scopes_In_EWA_OK => True);
-
- pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
-
- -- The heap and pool allocators are marked as
- -- Comes_From_Source since they correspond to an
- -- explicit user-written allocator (that is, it will
- -- only be executed on behalf of callers that call the
- -- function as initialization for such an allocator).
- -- Prevents errors when No_Implicit_Heap_Allocations
- -- is in force.
-
- Set_Comes_From_Source (Heap_Allocator, True);
- Set_Comes_From_Source (Pool_Allocator, True);
- end if;
-
- -- The allocator is returned on the secondary stack
-
- Check_Restriction (No_Secondary_Stack, N);
- Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool));
- Set_Procedure_To_Call
- (SS_Allocator, RTE (RE_SS_Allocate));
-
- -- The allocator is returned on the secondary stack,
- -- so indicate that the function return, as well as
- -- all blocks that encloses the allocator, must not
- -- release it. The flags must be set now because
- -- the decision to use the secondary stack is done
- -- very late in the course of expanding the return
- -- statement, past the point where these flags are
- -- normally set.
-
- Set_Uses_Sec_Stack (Func_Id);
- Set_Uses_Sec_Stack (Return_Statement_Entity (N));
- Set_Sec_Stack_Needed_For_Return
- (Return_Statement_Entity (N));
- Set_Enclosing_Sec_Stack_Return (N);
-
- -- Guard against poor expansion on the caller side by
- -- using a raise statement to catch out-of-range values
- -- of formal parameter BIP_Alloc_Form.
-
- if Exceptions_OK then
- Guard_Except :=
- Make_Raise_Program_Error (Loc,
- Reason => PE_Build_In_Place_Mismatch);
- else
- Guard_Except := Make_Null_Statement (Loc);
- end if;
-
- -- Create an if statement to test the BIP_Alloc_Form
- -- formal and initialize the access object to either the
- -- BIP_Object_Access formal (BIP_Alloc_Form =
- -- Caller_Allocation), the result of allocating the
- -- object in the secondary stack (BIP_Alloc_Form =
- -- Secondary_Stack), or else an allocator to create the
- -- return object in the heap or user-defined pool
- -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool).
-
- -- ??? An unchecked type conversion must be made in the
- -- case of assigning the access object formal to the
- -- local access object, because a normal conversion would
- -- be illegal in some cases (such as converting access-
- -- to-unconstrained to access-to-constrained), but the
- -- the unchecked conversion will presumably fail to work
- -- right in just such cases. It's not clear at all how to
- -- handle this. ???
-
- Alloc_If_Stmt :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Caller_Allocation)))),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Alloc_Obj_Id, Loc),
- Expression =>
- Unchecked_Convert_To
- (Ref_Type,
- New_Occurrence_Of (Obj_Acc_Formal, Loc)))),
-
- Elsif_Parts => New_List (
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Secondary_Stack)))),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Alloc_Obj_Id, Loc),
- Expression => SS_Allocator))),
-
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Global_Heap)))),
-
- Then_Statements => New_List (
- Build_Heap_Or_Pool_Allocator
- (Temp_Id => Alloc_Obj_Id,
- Temp_Typ => Ref_Type,
- Func_Id => Func_Id,
- Ret_Typ => Ret_Obj_Typ,
- Alloc_Expr => Heap_Allocator))),
-
- -- ???If all is well, we can put the following
- -- 'elsif' in the 'else', but this is a useful
- -- self-check in case caller and callee don't agree
- -- on whether BIPAlloc and so on should be passed.
-
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (User_Storage_Pool)))),
-
- Then_Statements => New_List (
- Pool_Decl,
- Build_Heap_Or_Pool_Allocator
- (Temp_Id => Alloc_Obj_Id,
- Temp_Typ => Ref_Type,
- Func_Id => Func_Id,
- Ret_Typ => Ret_Obj_Typ,
- Alloc_Expr => Pool_Allocator)))),
-
- -- Raise Program_Error if it's none of the above;
- -- this is a compiler bug.
-
- Else_Statements => New_List (Guard_Except));
-
- -- If a separate initialization assignment was created
- -- earlier, append that following the assignment of the
- -- implicit access formal to the access object, to ensure
- -- that the return object is initialized in that case. In
- -- this situation, the target of the assignment must be
- -- rewritten to denote a dereference of the access to the
- -- return object passed in by the caller.
-
- if Present (Init_Assignment) then
- Rewrite (Name (Init_Assignment),
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
- pragma Assert
- (Assignment_OK
- (Original_Node (Name (Init_Assignment))));
- Set_Assignment_OK (Name (Init_Assignment));
-
- Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
-
- Append_To
- (Then_Statements (Alloc_If_Stmt), Init_Assignment);
- end if;
-
- Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
-
- -- Remember the local access object for use in the
- -- dereference of the renaming created below.
-
- Obj_Acc_Formal := Alloc_Obj_Id;
- end;
-
- -- When the function's subtype is unconstrained and a run-time
- -- test is not needed, we nevertheless need to build the return
- -- using the function's result subtype.
-
- elsif not Is_Constrained (Underlying_Type (Etype (Func_Id)))
- then
- declare
- Alloc_Obj_Id : Entity_Id;
- Alloc_Obj_Decl : Node_Id;
- Ptr_Type_Decl : Node_Id;
- Ref_Type : Entity_Id;
-
- begin
- -- Create an access type designating the function's
- -- result subtype.
-
- Ref_Type := Make_Temporary (Loc, 'A');
-
- Ptr_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Ret_Obj_Typ, Loc)));
-
- Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl);
-
- -- Create an access object initialized to the conversion
- -- of the implicit access value passed in by the caller.
-
- Alloc_Obj_Id := Make_Temporary (Loc, 'R');
- Set_Etype (Alloc_Obj_Id, Ref_Type);
-
- -- See the ??? comment a few lines above about the use of
- -- an unchecked conversion here.
-
- Alloc_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Alloc_Obj_Id,
- Object_Definition =>
- New_Occurrence_Of (Ref_Type, Loc),
- Expression =>
- Unchecked_Convert_To
- (Ref_Type,
- New_Occurrence_Of (Obj_Acc_Formal, Loc)));
-
- Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
-
- -- Remember the local access object for use in the
- -- dereference of the renaming created below.
-
- Obj_Acc_Formal := Alloc_Obj_Id;
- end;
- end if;
-
- -- Replace the return object declaration with a renaming of a
- -- dereference of the access value designating the return
- -- object.
-
- Obj_Acc_Deref :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc));
-
- Rewrite (Ret_Obj_Decl,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Ret_Obj_Id,
- Access_Definition => Empty,
- Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc),
- Name => Obj_Acc_Deref));
+ -- Build a simple_return_statement that returns the return object
- Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref);
- end;
- end if;
+ Return_Stmt :=
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
+ Append_To (Stmts, Return_Stmt);
-- Case where we do not need to build a block. But we're about to drop
-- Return_Object_Declarations on the floor, so assert that it contains
@@ -6124,9 +5349,7 @@ package body Exp_Ch6 is
-- before an object is returned. A predicate that applies to the return
-- subtype is checked immediately before an object is returned.
- -- Suppress access checks to avoid generating extra checks for b-i-p.
-
- Analyze (N, Suppress => Access_Check);
+ Analyze (N);
end Expand_N_Extended_Return_Statement;
----------------------------
@@ -8518,26 +7741,6 @@ package body Exp_Ch6 is
end if;
end Install_Class_Preconditions_Check;
- -----------------------------------
- -- Is_Build_In_Place_Result_Type --
- -----------------------------------
-
- function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
- begin
- if not Expander_Active then
- return False;
- end if;
-
- -- In Ada 2005 all functions with an inherently limited return type
- -- must be handled using a build-in-place profile, including the case
- -- of a function with a limited interface result, where the function
- -- may return objects of nonlimited descendants.
-
- return Is_Limited_View (Typ)
- and then Ada_Version >= Ada_2005
- and then not Debug_Flag_Dot_L;
- end Is_Build_In_Place_Result_Type;
-
------------------------------
-- Is_Build_In_Place_Entity --
------------------------------
@@ -8655,6 +7858,36 @@ package body Exp_Ch6 is
end;
end Is_Build_In_Place_Function_Call;
+ -----------------------------------
+ -- Is_Build_In_Place_Result_Type --
+ -----------------------------------
+
+ function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
+ begin
+ if not Expander_Active then
+ return False;
+ end if;
+
+ -- In Ada 2005 all functions with an inherently limited return type
+ -- must be handled using a build-in-place profile, including the case
+ -- of a function with a limited interface result, where the function
+ -- may return objects of nonlimited descendants.
+
+ return Is_Limited_View (Typ)
+ and then Ada_Version >= Ada_2005
+ and then not Debug_Flag_Dot_L;
+ end Is_Build_In_Place_Result_Type;
+
+ -------------------------------------
+ -- Is_Build_In_Place_Return_Object --
+ -------------------------------------
+
+ function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean is
+ begin
+ return Is_Return_Object (E)
+ and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E)));
+ end Is_Build_In_Place_Return_Object;
+
-----------------------
-- Is_Null_Procedure --
-----------------------
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index f886eda51a3..19d0bc3ff69 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -127,22 +127,6 @@ package Exp_Ch6 is
function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
- function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
- -- Ada 2005 (AI-318-02): Returns True if functions returning the type use
- -- build-in-place protocols. For inherently limited types, this must be
- -- True in >= Ada 2005, and must be False in Ada 95. For other types, it
- -- can be True or False, and the decision should be based on efficiency,
- -- and should be the same for all language versions, so that mixed-dialect
- -- programs will work.
- --
- -- For inherently limited types in Ada 2005, True means that calls will
- -- actually be build-in-place in all cases. For other types, build-in-place
- -- will be used when possible, but we need to make a copy in some
- -- cases. For example, for "X := F(...);" if F can see X, or if F can
- -- propagate exceptions, we need to store its result in a temp in general,
- -- and copy the temp into X. Also, for "return Global_Var;" Global_Var
- -- needs to be copied into the function result object.
-
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
-- function, or access-to-function type for which
@@ -155,6 +139,15 @@ package Exp_Ch6 is
-- that requires handling as a build-in-place call (possibly qualified or
-- converted).
+ function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if functions returning the type use
+ -- build-in-place protocols. For inherently limited types, this must be
+ -- 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
+ -- that uses build-in-place protocols.
+
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.
@@ -272,4 +265,7 @@ package Exp_Ch6 is
-- to reference the secondary dispatch table of an interface; otherwise
-- return Empty.
+private
+ pragma Inline (Is_Build_In_Place_Return_Object);
+
end Exp_Ch6;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 2be891e1bb7..07664822791 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -441,10 +441,6 @@ package body Exp_Ch7 is
-- of the formal of Proc, or force a conversion to the class-wide type in
-- the case where the operation is abstract.
- function Enclosing_Function (E : Entity_Id) return Entity_Id;
- -- Given an arbitrary entity, traverse the scope chain looking for the
- -- first enclosing function. Return Empty if no function was found.
-
function Make_Call
(Loc : Source_Ptr;
Proc_Id : Entity_Id;
@@ -3431,7 +3427,9 @@ package body Exp_Ch7 is
if Is_Return_Object (Obj_Id) then
declare
- Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
+ Func_Id : constant Entity_Id :=
+ Return_Applies_To (Scope (Obj_Id));
+
begin
if Is_Build_In_Place_Function (Func_Id)
and then Needs_BIP_Finalization_Master (Func_Id)
@@ -5084,26 +5082,6 @@ package body Exp_Ch7 is
end if;
end Convert_View;
- ------------------------
- -- Enclosing_Function --
- ------------------------
-
- function Enclosing_Function (E : Entity_Id) return Entity_Id is
- Func_Id : Entity_Id;
-
- begin
- Func_Id := E;
- while Present (Func_Id) and then Func_Id /= Standard_Standard loop
- if Ekind (Func_Id) = E_Function then
- return Func_Id;
- end if;
-
- Func_Id := Scope (Func_Id);
- end loop;
-
- return Empty;
- end Enclosing_Function;
-
-------------------------------
-- Establish_Transient_Scope --
-------------------------------
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 93aa2ca2b0f..29969b3aa22 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -4043,7 +4043,6 @@ package body Sem_Ch3 is
Prev_Entity : Entity_Id := Empty;
Related_Id : Entity_Id;
- Full_View_Present : Boolean := False;
-- Start of processing for Analyze_Object_Declaration
@@ -4732,28 +4731,32 @@ package body Sem_Ch3 is
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
- -- Propagate attributes to full view when needed
+ if Act_T /= T then
+ declare
+ Full_View_Present : constant Boolean :=
+ Is_Private_Type (Act_T)
+ and then Present (Full_View (Act_T));
+ -- Propagate attributes to full view when needed
- Set_Is_Constr_Subt_For_U_Nominal (Act_T);
+ begin
+ Set_Is_Constr_Subt_For_U_Nominal (Act_T);
- if Is_Private_Type (Act_T) and then Present (Full_View (Act_T))
- then
- Full_View_Present := True;
- end if;
+ if Full_View_Present then
+ Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T));
+ end if;
- if Full_View_Present then
- Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T));
- end if;
+ if Aliased_Present (N) then
+ Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
- if Aliased_Present (N) then
- Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+ if Full_View_Present then
+ Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T));
+ end if;
+ end if;
- if Full_View_Present then
- Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T));
- end if;
+ Freeze_Before (N, Act_T);
+ end;
end if;
- Freeze_Before (N, Act_T);
Freeze_Before (N, T);
end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 05db793a155..e5c13ed36b2 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -34,7 +34,6 @@ with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
-with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
@@ -1520,33 +1519,7 @@ package body Sem_Ch6 is
-- object declaration.
Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
-
- -- Returning a build-in-place unconstrained array type we defer
- -- the full analysis of the returned object to avoid generating
- -- the corresponding constrained subtype; otherwise the bounds
- -- would be created in the stack and a dangling reference would
- -- be returned pointing to the bounds. We perform its preanalysis
- -- to report errors on the initializing aggregate now (if any);
- -- we also ensure its activation chain and Master variable are
- -- defined (if tasks are being declared) since they are generated
- -- as part of the analysis and expansion of the object declaration
- -- at this stage.
-
- if Is_Array_Type (R_Type)
- and then not Is_Constrained (R_Type)
- and then Is_Build_In_Place_Function (Scope_Id)
- and then Needs_BIP_Alloc_Form (Scope_Id)
- and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
- then
- Preanalyze (Obj_Decl);
-
- if Expander_Active then
- Ensure_Activation_Chain_And_Master (Obj_Decl);
- end if;
-
- else
- Analyze (Obj_Decl);
- end if;
+ Analyze (Obj_Decl);
Check_Return_Subtype_Indication (Obj_Decl);
@@ -9274,7 +9247,9 @@ package body Sem_Ch6 is
-- Force the definition of the Itype in case of internal function
-- calls within the same or nested scope.
- if Is_Subprogram_Or_Generic_Subprogram (E) then
+ if Is_Subprogram_Or_Generic_Subprogram (E)
+ and then not Is_Compilation_Unit (E)
+ then
Subp_Decl := Parent (E);
-- The insertion point for an Itype reference should be after
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-07-05 8:29 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-07-05 8:29 [gcc r13-1480] [Ada] Fix dangling bounds for array result of BIP functions Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).