OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-07-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
	is now used as Is_Ignored_Transient.
	(Is_Finalized_Transient): New routine.
	(Is_Ignored_Transient): New routine.
	(Is_Processed_Transient): Removed.
	(Set_Is_Finalized_Transient): New routine.
	(Set_Is_Ignored_Transient): New routine.
	(Set_Is_Processed_Transient): Removed.
	(Write_Entity_Flags): Output Flag252 and Flag295.
	* einfo.ads: New attributes Is_Finalized_Transient
	and Is_Ignored_Transient along with occurrences in
	entities. Remove attribute Is_Processed_Transient.
	(Is_Finalized_Transient): New routine along with pragma Inline.
	(Is_Ignored_Transient): New routine along with pragma Inline.
	(Is_Processed_Transient): Removed along with pragma Inline.
	(Set_Is_Finalized_Transient): New routine along with pragma Inline.
	(Set_Is_Ignored_Transient): New routine along with pragma Inline.
	(Set_Is_Processed_Transient): Removed along with pragma Inline.
	* exp_aggr.adb Add with and use clauses for Exp_Ch11 and Inline.
	(Build_Record_Aggr_Code): Change the handling
	of controlled record components.
	(Ctrl_Init_Expression): Removed.
	(Gen_Assign): Add new formal parameter In_Loop
	along with comment on usage.  Remove local variables Stmt and
	Stmt_Expr. Change the handling of controlled array components.
	(Gen_Loop): Update the call to Gen_Assign.
	(Gen_While): Update the call to Gen_Assign.
	(Initialize_Array_Component): New routine.
	(Initialize_Ctrl_Array_Component): New routine.
	(Initialize_Ctrl_Record_Component): New routine.
	(Initialize_Record_Component): New routine.
	(Process_Transient_Component): New routine.
	(Process_Transient_Component_Completion): New routine.
	* exp_ch4.adb (Process_Transient_In_Expression): New routine.
	(Process_Transient_Object): Removed. Replace all existing calls
	to this routine with calls to Process_Transient_In_Expression.
	* exp_ch6.adb (Expand_Ctrl_Function_Call): Remove local constant
	Is_Elem_Ref. Update the comment on ignoring transients.
	* exp_ch7.adb (Process_Declarations): Do not process ignored
	or finalized transient objects.
	(Process_Transient_In_Scope): New routine.
	(Process_Transients_In_Scope): New routine.
	(Process_Transient_Objects): Removed. Replace all existing calls
	to this routine with calls to Process_Transients_In_Scope.
	* exp_util.adb (Build_Transient_Object_Statements): New routine.
	(Is_Finalizable_Transient): Do not consider a transient object
	which has been finalized.
	(Requires_Cleanup_Actions): Do not consider ignored or finalized
	transient objects.
	* exp_util.ads (Build_Transient_Object_Statements): New routine.
	* sem_aggr.adb: Major code clean up.
	* sem_res.adb: Update documentation.

2016-07-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Analyze_Subtype_Declaration): For generated
	subtypes, such as actual subtypes of unconstrained formals,
	inherit predicate functions, if any, from the parent type rather
	than creating redundant new ones.

From-SVN: r238044
This commit is contained in:
Arnaud Charlet 2016-07-06 14:37:54 +02:00
parent 75e4e36dfe
commit 937e96763e
12 changed files with 2050 additions and 1309 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
gcc/ada/ChangeLog
View File

@ -1,3 +1,65 @@
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
is now used as Is_Ignored_Transient.
(Is_Finalized_Transient): New routine.
(Is_Ignored_Transient): New routine.
(Is_Processed_Transient): Removed.
(Set_Is_Finalized_Transient): New routine.
(Set_Is_Ignored_Transient): New routine.
(Set_Is_Processed_Transient): Removed.
(Write_Entity_Flags): Output Flag252 and Flag295.
* einfo.ads: New attributes Is_Finalized_Transient
and Is_Ignored_Transient along with occurrences in
entities. Remove attribute Is_Processed_Transient.
(Is_Finalized_Transient): New routine along with pragma Inline.
(Is_Ignored_Transient): New routine along with pragma Inline.
(Is_Processed_Transient): Removed along with pragma Inline.
(Set_Is_Finalized_Transient): New routine along with pragma Inline.
(Set_Is_Ignored_Transient): New routine along with pragma Inline.
(Set_Is_Processed_Transient): Removed along with pragma Inline.
* exp_aggr.adb Add with and use clauses for Exp_Ch11 and Inline.
(Build_Record_Aggr_Code): Change the handling
of controlled record components.
(Ctrl_Init_Expression): Removed.
(Gen_Assign): Add new formal parameter In_Loop
along with comment on usage. Remove local variables Stmt and
Stmt_Expr. Change the handling of controlled array components.
(Gen_Loop): Update the call to Gen_Assign.
(Gen_While): Update the call to Gen_Assign.
(Initialize_Array_Component): New routine.
(Initialize_Ctrl_Array_Component): New routine.
(Initialize_Ctrl_Record_Component): New routine.
(Initialize_Record_Component): New routine.
(Process_Transient_Component): New routine.
(Process_Transient_Component_Completion): New routine.
* exp_ch4.adb (Process_Transient_In_Expression): New routine.
(Process_Transient_Object): Removed. Replace all existing calls
to this routine with calls to Process_Transient_In_Expression.
* exp_ch6.adb (Expand_Ctrl_Function_Call): Remove local constant
Is_Elem_Ref. Update the comment on ignoring transients.
* exp_ch7.adb (Process_Declarations): Do not process ignored
or finalized transient objects.
(Process_Transient_In_Scope): New routine.
(Process_Transients_In_Scope): New routine.
(Process_Transient_Objects): Removed. Replace all existing calls
to this routine with calls to Process_Transients_In_Scope.
* exp_util.adb (Build_Transient_Object_Statements): New routine.
(Is_Finalizable_Transient): Do not consider a transient object
which has been finalized.
(Requires_Cleanup_Actions): Do not consider ignored or finalized
transient objects.
* exp_util.ads (Build_Transient_Object_Statements): New routine.
* sem_aggr.adb: Major code clean up.
* sem_res.adb: Update documentation.
2016-07-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Analyze_Subtype_Declaration): For generated
subtypes, such as actual subtypes of unconstrained formals,
inherit predicate functions, if any, from the parent type rather
than creating redundant new ones.
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting.

43
gcc/ada/einfo.adb
View File

@ -561,7 +561,7 @@ package body Einfo is
-- Has_Predicates Flag250
-- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
-- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
@ -609,8 +609,8 @@ package body Einfo is
-- Is_Partial_Invariant_Procedure Flag292
-- Is_Actual_Subtype Flag293
-- Has_Pragma_Unused Flag294
-- Is_Ignored_Transient Flag295
-- (unused) Flag295
-- (unused) Flag296
-- (unused) Flag297
-- (unused) Flag298
@ -2185,6 +2185,12 @@ package body Einfo is
return Flag99 (Id);
end Is_Exported;
function Is_Finalized_Transient (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
return Flag252 (Id);
end Is_Finalized_Transient;
function Is_First_Subtype (Id : E) return B is
begin
return Flag70 (Id);
@ -2250,6 +2256,12 @@ package body Einfo is
return Flag278 (Id);
end Is_Ignored_Ghost_Entity;
function Is_Ignored_Transient (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
return Flag295 (Id);
end Is_Ignored_Transient;
function Is_Immediately_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -2466,12 +2478,6 @@ package body Einfo is
return Flag245 (Id);
end Is_Private_Primitive;
function Is_Processed_Transient (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
return Flag252 (Id);
end Is_Processed_Transient;
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -5248,6 +5254,12 @@ package body Einfo is
Set_Flag99 (Id, V);
end Set_Is_Exported;
procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
Set_Flag252 (Id, V);
end Set_Is_Finalized_Transient;
procedure Set_Is_First_Subtype (Id : E; V : B := True) is
begin
Set_Flag70 (Id, V);
@ -5329,6 +5341,12 @@ package body Einfo is
Set_Flag278 (Id, V);
end Set_Is_Ignored_Ghost_Entity;
procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
Set_Flag295 (Id, V);
end Set_Is_Ignored_Transient;
procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -5543,12 +5561,6 @@ package body Einfo is
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
procedure Set_Is_Processed_Transient (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
Set_Flag252 (Id, V);
end Set_Is_Processed_Transient;
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@ -9241,6 +9253,7 @@ package body Einfo is
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id));
W ("Is_Finalized_Transient", Flag252 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
W ("Is_Formal_Subprogram", Flag111 (Id));
@ -9253,6 +9266,7 @@ package body Einfo is
W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id));
W ("Is_Hidden_Open_Scope", Flag171 (Id));
W ("Is_Ignored_Ghost_Entity", Flag278 (Id));
W ("Is_Ignored_Transient", Flag295 (Id));
W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
@ -9292,7 +9306,6 @@ package body Einfo is
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
W ("Is_Processed_Transient", Flag252 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));

40
gcc/ada/einfo.ads
View File

@ -535,7 +535,7 @@ package Einfo is
-- a build-in-place function call. Contains the relocated build-in-place
-- call after the expansion has decoupled the call from the object. This
-- attribute is used by the finalization machinery to insert cleanup code
-- for all additional transient variables found in the transient block.
-- for all additional transient objects found in the transient block.
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Defined in record types. Set if a pragma Convention for the record
@ -2484,6 +2484,12 @@ package Einfo is
-- Applies to all entities, true for abstract states that are subject to
-- option External.
-- Is_Finalized_Transient (Flag252)
-- Defined in constants, loop parameters of generalized iterators, and
-- variables. Set when a transient object has been finalized by one of
-- the transient finalization mechanisms. The flag prevents the double
-- finalization of the object.
-- Is_Finalizer (synthesized)
-- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects.
@ -2595,6 +2601,13 @@ package Einfo is
-- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Ignore.
-- Is_Ignored_Transient (Flag295)
-- Defined in constants, loop parameters of generalized iterators, and
-- variables. Set when a transient object must be processed by one of
-- the transient finalization mechanisms. Once marked, a transient is
-- intentionally ignored by the general finalization mechanism because
-- its clean up actions are context specific.
-- Is_Immediately_Visible (Flag7)
-- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)).
@ -2997,13 +3010,6 @@ package Einfo is
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes.
-- Is_Processed_Transient (Flag252)
-- Defined in variables, loop parameters, and constants, including the
-- loop parameters of generalized iterators. Set when a transient object
-- needs to be finalized and has already been processed by the transient
-- scope machinery. This flag signals the general finalization mechanism
-- to ignore the transient object.
-- Is_Protected_Component (synthesized)
-- Applicable to all entities, true if the entity denotes a private
-- component of a protected type.
@ -5786,8 +5792,9 @@ package Einfo is
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
-- Is_Processed_Transient (Flag252) (constants only)
-- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Uplevel_Referenced_Entity (Flag283)
@ -6552,8 +6559,9 @@ package Einfo is
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
-- Is_Processed_Transient (Flag252)
-- Is_Return_Object (Flag209)
-- Is_Safe_To_Reevaluate (Flag249)
-- Is_Shared_Passive (Flag60)
@ -7062,6 +7070,7 @@ package Einfo is
function Is_Entry_Formal (Id : E) return B;
function Is_Exception_Handler (Id : E) return B;
function Is_Exported (Id : E) return B;
function Is_Finalized_Transient (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (Id : E) return B;
@ -7070,6 +7079,7 @@ package Einfo is
function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B;
function Is_Hidden_Open_Scope (Id : E) return B;
function Is_Ignored_Ghost_Entity (Id : E) return B;
function Is_Ignored_Transient (Id : E) return B;
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
@ -7108,7 +7118,6 @@ package Einfo is
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
function Is_Processed_Transient (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
@ -7736,6 +7745,7 @@ package Einfo is
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Exception_Handler (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
procedure Set_Is_Finalized_Transient (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
@ -7748,6 +7758,7 @@ package Einfo is
procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True);
procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True);
procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True);
procedure Set_Is_Ignored_Transient (Id : E; V : B := True);
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
@ -7787,7 +7798,6 @@ package Einfo is
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
procedure Set_Is_Processed_Transient (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
@ -8544,6 +8554,7 @@ package Einfo is
pragma Inline (Is_Enumeration_Type);
pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported);
pragma Inline (Is_Finalized_Transient);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_Point_Type);
@ -8563,6 +8574,7 @@ package Einfo is
pragma Inline (Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Is_Hidden_Open_Scope);
pragma Inline (Is_Ignored_Ghost_Entity);
pragma Inline (Is_Ignored_Transient);
pragma Inline (Is_Immediately_Visible);
pragma Inline (Is_Implementation_Defined);
pragma Inline (Is_Imported);
@ -8612,7 +8624,6 @@ package Einfo is
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
pragma Inline (Is_Processed_Transient);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
@ -9039,6 +9050,7 @@ package Einfo is
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported);
pragma Inline (Set_Is_Finalized_Transient);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram);
@ -9051,6 +9063,7 @@ package Einfo is
pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Set_Is_Hidden_Open_Scope);
pragma Inline (Set_Is_Ignored_Ghost_Entity);
pragma Inline (Set_Is_Ignored_Transient);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
@ -9090,7 +9103,6 @@ package Einfo is
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
pragma Inline (Set_Is_Processed_Transient);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);

1613
gcc/ada/exp_aggr.adb
View File

File diff suppressed because it is too large Load Diff

255
gcc/ada/exp_ch4.adb
View File

@ -226,22 +226,21 @@ package body Exp_Ch4 is
procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
-- Inspect and process statement list Stmt of if or case expression N for
-- transient controlled objects. If such objects are found, the routine
-- generates code to clean them up when the context of the expression is
-- evaluated or elaborated.
-- transient objects. If such objects are found, the routine generates code
-- to clean them up when the context of the expression is evaluated.
procedure Process_Transient_Object
(Decl : Node_Id;
N : Node_Id;
Stmts : List_Id);
procedure Process_Transient_In_Expression
(Obj_Decl : Node_Id;
Expr : Node_Id;
Stmts : List_Id);
-- Subsidiary routine to the expansion of expression_with_actions, if and
-- case expressions. Generate all necessary code to finalize a transient
-- controlled object when the enclosing context is elaborated or evaluated.
-- Decl denotes the declaration of the transient controlled object which is
-- usually the result of a controlled function call. N denotes the related
-- expression_with_actions, if expression, or case expression node. Stmts
-- denotes the statement list which contains Decl, either at the top level
-- or within a nested construct.
-- object when the enclosing context is elaborated or evaluated. Obj_Decl
-- denotes the declaration of the transient object, which is usually the
-- result of a controlled function call. Expr denotes the expression with
-- actions, if expression, or case expression node. Stmts denotes the
-- statement list which contains Decl, either at the top level or within a
-- nested construct.
procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at
@ -4866,11 +4865,10 @@ package body Exp_Ch4 is
Prepend_List (Actions (Alt), Stmts);
end if;
-- Finalize any transient controlled objects on exit from the
-- alternative. This is done only in the return optimization case
-- because otherwise the case expression is converted into an
-- expression with actions which already contains this form of
-- processing.
-- Finalize any transient objects on exit from the alternative.
-- This is done only in the return optimization case because
-- otherwise the case expression is converted into an expression
-- with actions which already contains this form of processing.
if Optimize_Return_Stmt then
Process_If_Case_Statements (N, Stmts);
@ -4952,9 +4950,9 @@ package body Exp_Ch4 is
function Process_Action (Act : Node_Id) return Traverse_Result;
-- Inspect and process a single action of an expression_with_actions for
-- transient controlled objects. If such objects are found, the routine
-- generates code to clean them up when the context of the expression is
-- evaluated or elaborated.
-- transient objects. If such objects are found, the routine generates
-- code to clean them up when the context of the expression is evaluated
-- or elaborated.
------------------------------
-- Force_Boolean_Evaluation --
@ -4997,7 +4995,7 @@ package body Exp_Ch4 is
if Nkind (Act) = N_Object_Declaration
and then Is_Finalizable_Transient (Act, N)
then
Process_Transient_Object (Act, N, Acts);
Process_Transient_In_Expression (Act, N, Acts);
return Abandon;
-- Avoid processing temporary function results multiple times when
@ -5038,8 +5036,8 @@ package body Exp_Ch4 is
null;
-- Force the evaluation of the expression by capturing its value in a
-- temporary. This ensures that aliases of transient controlled objects
-- do not leak to the expression of the expression_with_actions node:
-- temporary. This ensures that aliases of transient objects do not leak
-- to the expression of the expression_with_actions node:
-- do
-- Trans_Id : Ctrl_Typ := ...;
@ -5059,12 +5057,12 @@ package body Exp_Ch4 is
-- in Val end;
-- Once this transformation is performed, it is safe to finalize the
-- transient controlled object at the end of the actions list.
-- transient object at the end of the actions list.
-- Note that Force_Evaluation does not remove side effects in operators
-- because it assumes that all operands are evaluated and side effect
-- free. This is not the case when an operand depends implicitly on the
-- transient controlled object through the use of access types.
-- transient object through the use of access types.
elsif Is_Boolean_Type (Etype (Expression (N))) then
Force_Boolean_Evaluation (Expression (N));
@ -5077,8 +5075,8 @@ package body Exp_Ch4 is
Force_Evaluation (Expression (N));
end if;
-- Process all transient controlled objects found within the actions of
-- the EWA node.
-- Process all transient objects found within the actions of the EWA
-- node.
Act := First (Acts);
while Present (Act) loop
@ -12956,44 +12954,44 @@ package body Exp_Ch4 is
if Nkind (Decl) = N_Object_Declaration
and then Is_Finalizable_Transient (Decl, N)
then
Process_Transient_Object (Decl, N, Stmts);
Process_Transient_In_Expression (Decl, N, Stmts);
end if;
Next (Decl);
end loop;
end Process_If_Case_Statements;
------------------------------
-- Process_Transient_Object --
------------------------------
-------------------------------------
-- Process_Transient_In_Expression --
-------------------------------------
procedure Process_Transient_Object
(Decl : Node_Id;
N : Node_Id;
Stmts : List_Id)
procedure Process_Transient_In_Expression
(Obj_Decl : Node_Id;
Expr : Node_Id;
Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (Decl);
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Obj_Typ : constant Node_Id := Etype (Obj_Id);
Loc : constant Source_Ptr := Sloc (Obj_Decl);
Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
Desig_Typ : Entity_Id;
Expr : Node_Id;
Hook_Id : Entity_Id;
Hook_Insert : Node_Id;
Ptr_Id : Entity_Id;
Hook_Context : constant Node_Id := Find_Hook_Context (N);
Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
-- The node on which to insert the hook as an action. This is usually
-- the innermost enclosing non-transient construct.
Fin_Call : Node_Id;
Hook_Assign : Node_Id;
Hook_Clear : Node_Id;
Hook_Decl : Node_Id;
Hook_Insert : Node_Id;
Ptr_Decl : Node_Id;
Fin_Context : Node_Id;
-- The node after which to insert the finalization actions of the
-- transient controlled object.
-- transient object.
begin
pragma Assert (Nkind_In (N, N_Case_Expression,
N_Expression_With_Actions,
N_If_Expression));
pragma Assert (Nkind_In (Expr, N_Case_Expression,
N_Expression_With_Actions,
N_If_Expression));
-- When the context is a Boolean evaluation, all three nodes capture the
-- result of their computation in a local temporary:
@ -13004,102 +13002,63 @@ package body Exp_Ch4 is
-- <finalize Trans_Id>
-- in Result end;
-- As a result, the finalization of any transient controlled objects can
-- safely take place after the result capture.
-- As a result, the finalization of any transient objects can safely
-- take place after the result capture.
-- ??? could this be extended to elementary types?
if Is_Boolean_Type (Etype (N)) then
if Is_Boolean_Type (Etype (Expr)) then
Fin_Context := Last (Stmts);
-- Otherwise the immediate context may not be safe enough to carry out
-- transient controlled object finalization due to aliasing and nesting
-- of constructs. Insert calls to [Deep_]Finalize after the innermost
-- Otherwise the immediate context may not be safe enough to carry
-- out transient object finalization due to aliasing and nesting of
-- constructs. Insert calls to [Deep_]Finalize after the innermost
-- enclosing non-transient construct.
else
Fin_Context := Hook_Context;
end if;
-- Step 1: Create the access type which provides a reference to the
-- transient controlled object.
-- Mark the transient object as successfully processed to avoid double
-- finalization.
if Is_Access_Type (Obj_Typ) then
Desig_Typ := Directly_Designated_Type (Obj_Typ);
else
Desig_Typ := Obj_Typ;
end if;
Set_Is_Finalized_Transient (Obj_Id);
Desig_Typ := Base_Type (Desig_Typ);
-- Construct all the pieces necessary to hook and finalize a transient
-- object.
Build_Transient_Object_Statements
(Obj_Decl => Obj_Decl,
Fin_Call => Fin_Call,
Hook_Assign => Hook_Assign,
Hook_Clear => Hook_Clear,
Hook_Decl => Hook_Decl,
Ptr_Decl => Ptr_Decl,
Finalize_Obj => False);
-- Add the access type which provides a reference to the transient
-- object. Generate:
-- type Ptr_Typ is access all Desig_Typ;
Insert_Action (Hook_Context, Ptr_Decl);
-- Add the temporary which acts as a hook to the transient object.
-- Generate:
-- Ann : access [all] <Desig_Typ>;
Ptr_Id := Make_Temporary (Loc, 'A');
Insert_Action (Hook_Context,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Id,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
-- Step 2: Create a temporary which acts as a hook to the transient
-- controlled object. Generate:
-- Hook : Ptr_Id := null;
Hook_Id := Make_Temporary (Loc, 'T');
Insert_Action (Hook_Context, Hook_Decl);
Insert_Action (Hook_Context,
Make_Object_Declaration (Loc,
Defining_Identifier => Hook_Id,
Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
-- When the transient object is initialized by an aggregate, the hook
-- must capture the object after the last aggregate assignment takes
-- place. Only then is the object considered initialized. Generate:
-- Mark the hook as created for the purposes of exporting the transient
-- controlled object out of the expression_with_action or if expression.
-- This signals the machinery in Build_Finalizer to treat this case in
-- a special manner.
Set_Status_Flag_Or_Transient_Decl (Hook_Id, Decl);
-- Step 3: Associate the transient object to the hook
-- This must be inserted right after the object declaration, so that
-- the assignment is executed if, and only if, the object is actually
-- created (whereas the declaration of the hook pointer, and the
-- finalization call, may be inserted at an outer level, and may
-- remain unused for some executions, if the actual creation of
-- the object is conditional).
-- The use of unchecked conversion / unrestricted access is needed to
-- avoid an accessibility violation. Note that the finalization code is
-- structured in such a way that the "hook" is processed only when it
-- points to an existing object.
if Is_Access_Type (Obj_Typ) then
Expr :=
Unchecked_Convert_To
(Typ => Ptr_Id,
Expr => New_Occurrence_Of (Obj_Id, Loc));
else
Expr :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
-- Generate:
-- Hook := Ptr_Id (Obj_Id);
-- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
-- When the transient object is initialized by an aggregate, the hook
-- must capture the object after the last component assignment takes
-- place. Only then is the object fully initialized.
if Ekind (Obj_Id) = E_Variable
if Ekind_In (Obj_Id, E_Constant, E_Variable)
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
@ -13107,54 +13066,42 @@ package body Exp_Ch4 is
-- Otherwise the hook seizes the related object immediately
else
Hook_Insert := Decl;
Hook_Insert := Obj_Decl;
end if;
Insert_After_And_Analyze (Hook_Insert,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Expr));
Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
-- Step 4: Finalize the hook after the context has been evaluated or
-- elaborated. Generate:
-- When the node is part of a return statement, there is no need to
-- insert a finalization call, as the general finalization mechanism
-- (see Build_Finalizer) would take care of the transient object on
-- subprogram exit. Note that it would also be impossible to insert the
-- finalization code after the return statement as this will render it
-- unreachable.
if Nkind (Fin_Context) = N_Simple_Return_Statement then
null;
-- Finalize the hook after the context has been evaluated. Generate:
-- if Hook /= null then
-- [Deep_]Finalize (Hook.all);
-- Hook := null;
-- end if;
-- When the node is part of a return statement, there is no need to
-- insert a finalization call, as the general finalization mechanism
-- (see Build_Finalizer) would take care of the transient controlled
-- object on subprogram exit. Note that it would also be impossible to
-- insert the finalization code after the return statement as this will
-- render it unreachable.
if Nkind (Fin_Context) = N_Simple_Return_Statement then
null;
-- Otherwise finalize the hook
else
Insert_Action_After (Fin_Context,
Make_Implicit_If_Statement (Decl,
Make_Implicit_If_Statement (Obj_Decl,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Hook_Id, Loc),
Left_Opnd =>
New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
Make_Final_Call
(Obj_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Hook_Id, Loc)),
Typ => Desig_Typ),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Make_Null (Loc)))));
Fin_Call,
Hook_Clear)));
end if;
end Process_Transient_Object;
end Process_Transient_In_Expression;
------------------------
-- Rewrite_Comparison --

24
gcc/ada/exp_ch6.adb
View File

@ -4115,10 +4115,6 @@ package body Exp_Ch6 is
and then Present (Generalized_Indexing (Ref));
end Is_Element_Reference;
-- Local variables
Is_Elem_Ref : constant Boolean := Is_Element_Reference (N);
-- Start of processing for Expand_Ctrl_Function_Call
begin
@ -4142,20 +4138,24 @@ package body Exp_Ch6 is
Remove_Side_Effects (N);
-- When the temporary function result appears inside a case expression
-- or an if expression, its lifetime must be extended to match that of
-- the context. If not, the function result will be finalized too early
-- and the evaluation of the expression could yield incorrect result. An
-- exception to this rule are references to Ada 2012 container elements.
-- The side effect removal of the function call produced a temporary.
-- When the context is a case expression, if expression, or expression
-- with actions, the lifetime of the temporary must be extended to match
-- that of the context. Otherwise the function result will be finalized
-- too early and affect the result of the expression. To prevent this
-- unwanted effect, the temporary should not be considered for clean up
-- actions by the general finalization machinery.
-- Exception to this rule are references to Ada 2012 container elements.
-- Such references must be finalized at the end of each iteration of the
-- related quantified expression, otherwise the container will remain
-- busy.
if not Is_Elem_Ref
if Nkind (N) = N_Explicit_Dereference
and then Within_Case_Or_If_Expression (N)
and then Nkind (N) = N_Explicit_Dereference
and then not Is_Element_Reference (N)
then
Set_Is_Processed_Transient (Entity (Prefix (N)));
Set_Is_Ignored_Transient (Entity (Prefix (N)));
end if;
end Expand_Ctrl_Function_Call;

436
gcc/ada/exp_ch7.adb
View File

@ -2080,11 +2080,19 @@ package body Exp_Ch7 is
if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Transient variables are treated separately in order to
-- minimize the size of the generated code. For details, see
-- Process_Transient_Objects.
-- Finalization of transient objects are treated separately in
-- order to handle sensitive cases. These include:
elsif Is_Processed_Transient (Obj_Id) then
-- * Aggregate expansion
-- * If, case, and expression with actions expansion
-- * Transient scopes
-- If one of those contexts has marked the transient object as
-- ignored, do not generate finalization actions for it.
elsif Is_Finalized_Transient (Obj_Id)
or else Is_Ignored_Transient (Obj_Id)
then
null;
-- Ignored Ghost objects do not need any cleanup actions
@ -2139,8 +2147,8 @@ package body Exp_Ch7 is
then
Processing_Actions (Has_No_Init => True);
-- Processing for "hook" objects generated for controlled
-- transients declared inside an Expression_With_Actions.
-- Processing for "hook" objects generated for transient
-- objects declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@ -2353,7 +2361,7 @@ package body Exp_Ch7 is
end if;
end if;
-- Handle a rare case caused by a controlled transient variable
-- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
@ -3124,7 +3132,7 @@ package body Exp_Ch7 is
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
-- Temporaries created for the purpose of "exporting" a
-- controlled transient out of an Expression_With_Actions (EWA)
-- transient object out of an Expression_With_Actions (EWA)
-- need guards. The following illustrates the usage of such
-- temporaries.
@ -6392,30 +6400,31 @@ package body Exp_Ch7 is
Act_Cleanup : constant List_Id :=
Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
-- Last), but this was incorrect as Process_Transient_Object may
-- Last), but this was incorrect as Process_Transients_In_Scope may
-- introduce new scopes and cause a reallocation of Scope_Stack.Table.
procedure Process_Transient_Objects
procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id);
-- First_Object and Last_Object define a list which contains potential
-- controlled transient objects. Finalization flags are inserted before
-- First_Object and finalization calls are inserted after Last_Object.
-- Related_Node is the node for which transient objects have been
-- created.
-- Find all transient objects in the list First_Object .. Last_Object
-- and generate finalization actions for them. Related_Node denotes the
-- node which created all transient objects.
-------------------------------
-- Process_Transient_Objects --
-------------------------------
---------------------------------
-- Process_Transients_In_Scope --
---------------------------------
procedure Process_Transient_Objects
procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id)
is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Must_Hook : Boolean := False;
-- Flag denoting whether the context requires transient variable
-- Flag denoting whether the context requires transient object
-- export to the outer finalizer.
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
@ -6424,6 +6433,15 @@ package body Exp_Ch7 is
procedure Detect_Subprogram_Call is
new Traverse_Proc (Is_Subprogram_Call);
procedure Process_Transient_In_Scope
(Obj_Decl : Node_Id;
Blk_Data : Finalization_Exception_Data;
Blk_Stmts : List_Id);
-- Generate finalization actions for a single transient object
-- denoted by object declaration Obj_Decl. Blk_Data is the
-- exception data of the enclosing block. Blk_Stmts denotes the
-- statements of the enclosing block.
------------------------
-- Is_Subprogram_Call --
------------------------
@ -6466,32 +6484,149 @@ package body Exp_Ch7 is
end if;
end Is_Subprogram_Call;
--------------------------------
-- Process_Transient_In_Scope --
--------------------------------
procedure Process_Transient_In_Scope
(Obj_Decl : Node_Id;
Blk_Data : Finalization_Exception_Data;
Blk_Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (Obj_Decl);
Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
Fin_Call : Node_Id;
Fin_Stmts : List_Id;
Hook_Assign : Node_Id;
Hook_Clear : Node_Id;
Hook_Decl : Node_Id;
Hook_Insert : Node_Id;
Ptr_Decl : Node_Id;
begin
-- Mark the transient object as successfully processed to avoid
-- double finalization.
Set_Is_Finalized_Transient (Obj_Id);
-- Construct all the pieces necessary to hook and finalize the
-- transient object.
Build_Transient_Object_Statements
(Obj_Decl => Obj_Decl,
Fin_Call => Fin_Call,
Hook_Assign => Hook_Assign,
Hook_Clear => Hook_Clear,
Hook_Decl => Hook_Decl,
Ptr_Decl => Ptr_Decl);
-- The context contains at least one subprogram call which may
-- raise an exception. This scenario employs "hooking" to pass
-- transient objects to the enclosing finalizer in case of an
-- exception.
if Must_Hook then
-- Add the access type which provides a reference to the
-- transient object. Generate:
-- type Ptr_Typ is access all Desig_Typ;
Insert_Action (Obj_Decl, Ptr_Decl);
-- Add the temporary which acts as a hook to the transient
-- object. Generate:
-- Hook : Ptr_Typ := null;
Insert_Action (Obj_Decl, Hook_Decl);
-- When the transient object is initialized by an aggregate,
-- the hook must capture the object after the last aggregate
-- assignment takes place. Only then is the object considered
-- fully initialized. Generate:
-- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
if Ekind_In (Obj_Id, E_Constant, E_Variable)
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
-- Otherwise the hook seizes the related object immediately
else
Hook_Insert := Obj_Decl;
end if;
Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
end if;
-- When exception propagation is enabled wrap the hook clear
-- statement and the finalization call into a block to catch
-- potential exceptions raised during finalization. Generate:
-- begin
-- [Hook := null;]
-- [Deep_]Finalize (Obj_Ref);
-- exception
-- when others =>
-- if not Raised then
-- Raised := True;
-- Save_Occurrence
-- (Enn, Get_Current_Excep.all.all);
-- end if;
-- end;
if Exceptions_OK then
Fin_Stmts := New_List;
if Must_Hook then
Append_To (Fin_Stmts, Hook_Clear);
end if;
Append_To (Fin_Stmts, Fin_Call);
Prepend_To (Blk_Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Fin_Stmts,
Exception_Handlers => New_List (
Build_Exception_Handler (Blk_Data)))));
-- Otherwise generate:
-- [Hook := null;]
-- [Deep_]Finalize (Obj_Ref);
-- Note that the statements are inserted in reverse order to
-- achieve the desired final order outlined above.
else
Prepend_To (Blk_Stmts, Fin_Call);
if Must_Hook then
Prepend_To (Blk_Stmts, Hook_Clear);
end if;
end if;
end Process_Transient_In_Scope;
-- Local variables
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Built : Boolean := False;
Blk_Data : Finalization_Exception_Data;
Blk_Decl : Node_Id := Empty;
Blk_Decls : List_Id := No_List;
Blk_Ins : Node_Id;
Blk_Stmts : List_Id;
Desig_Typ : Entity_Id;
Fin_Call : Node_Id;
Fin_Data : Finalization_Exception_Data;
Fin_Stmts : List_Id;
Hook_Clr : Node_Id := Empty;
Hook_Id : Entity_Id;
Hook_Ins : Node_Id;
Init_Expr : Node_Id;
Loc : Source_Ptr;
Obj_Decl : Node_Id;
Obj_Id : Entity_Id;
Obj_Ref : Node_Id;
Obj_Typ : Entity_Id;
Ptr_Typ : Entity_Id;
-- Start of processing for Process_Transient_Objects
-- Start of processing for Process_Transients_In_Scope
begin
-- The expansion performed by this routine is as follows:
@ -6536,11 +6671,11 @@ package body Exp_Ch7 is
-- Save_Occurrence (Ex, Get_Current_Excep.all.all);
-- end;
-- Abort_Undefer;
-- if Raised and not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
-- Abort_Undefer_Direct;
-- end;
-- Recognize a scenario where the transient context is an object
@ -6554,8 +6689,8 @@ package body Exp_Ch7 is
-- Obj : ...;
-- Res : ... := BIP_Func_Call (..., Obj, ...);
-- The finalization of any controlled transient must happen after
-- the build-in-place function call is executed.
-- The finalization of any transient object must happen after the
-- build-in-place function call is executed.
if Nkind (N) = N_Object_Declaration
and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
@ -6589,114 +6724,7 @@ package body Exp_Ch7 is
and then Obj_Decl /= Related_Node
then
Loc := Sloc (Obj_Decl);
Obj_Id := Defining_Identifier (Obj_Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
Desig_Typ := Obj_Typ;
Set_Is_Processed_Transient (Obj_Id);
-- Handle access types
if Is_Access_Type (Desig_Typ) then
Desig_Typ := Available_View (Designated_Type (Desig_Typ));
end if;
-- Transient objects associated with subprogram calls need
-- extra processing. These objects are usually created right
-- before the call and finalized immediately after the call.
-- If an exception occurs during the call, the clean up code
-- is skipped due to the sudden change in control and the
-- transient is never finalized.
-- To handle this case, such variables are "exported" to the
-- enclosing sequence of statements where their corresponding
-- "hooks" are picked up by the finalization machinery.
if Must_Hook then
-- Create an access type which provides a reference to the
-- transient object. Generate:
-- type Ptr_Typ is access [all] Desig_Typ;
Ptr_Typ := Make_Temporary (Loc, 'A');
Insert_Action (Obj_Decl,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present =>
Ekind (Obj_Typ) = E_General_Access_Type,
Subtype_Indication =>
New_Occurrence_Of (Desig_Typ, Loc))));
-- Create a temporary which acts as a hook to the transient
-- object. Generate:
-- Hook : Ptr_Typ := null;
Hook_Id := Make_Temporary (Loc, 'T');
Insert_Action (Obj_Decl,
Make_Object_Declaration (Loc,
Defining_Identifier => Hook_Id,
Object_Definition =>
New_Occurrence_Of (Ptr_Typ, Loc)));
-- Mark the temporary as a hook. This signals the machinery
-- in Build_Finalizer to recognize this special case.
Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
-- Hook the transient object to the temporary. Generate:
-- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
if Is_Access_Type (Obj_Typ) then
Init_Expr :=
Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
else
Init_Expr :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
-- When the transient object is initialized by an aggregate,
-- the hook must capture the object after the last component
-- assignment takes place. Only then is the object fully
-- initialized.
if Ekind (Obj_Id) = E_Variable
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Ins := Last_Aggregate_Assignment (Obj_Id);
-- Otherwise the hook seizes the related object immediately
else
Hook_Ins := Obj_Decl;
end if;
Insert_After_And_Analyze (Hook_Ins,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Init_Expr));
-- The transient object is about to be finalized by the
-- clean up code following the subprogram call. In order
-- to avoid double finalization, clear the hook.
-- Generate:
-- Hook := null;
Hook_Clr :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Make_Null (Loc));
end if;
Loc := Sloc (Obj_Decl);
-- Before generating the clean up code for the first transient
-- object, create a wrapper block which houses all hook clear
@ -6707,25 +6735,14 @@ package body Exp_Ch7 is
Built := True;
Blk_Stmts := New_List;
-- Create the declarations of all entities that participate
-- in exception detection and propagation.
-- Generate:
-- Abrt : constant Boolean := ...;
-- Ex : Exception_Occurrence;
-- Raised : Boolean := False;
if Exceptions_OK then
Blk_Decls := New_List;
-- Generate:
-- Abrt : constant Boolean := ...;
-- Ex : Exception_Occurrence;
-- Raised : Boolean := False;
Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
-- Generate:
-- if Raised and then not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
end if;
Blk_Decl :=
@ -6736,64 +6753,13 @@ package body Exp_Ch7 is
Statements => Blk_Stmts));
end if;
-- Generate:
-- [Deep_]Finalize (Obj_Ref);
-- Construct all necessary circuitry to hook and finalize a
-- single transient object.
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
if Is_Access_Type (Obj_Typ) then
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
Set_Etype (Obj_Ref, Desig_Typ);
end if;
Fin_Call :=
Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
-- When exception propagation is enabled wrap the hook clear
-- statement and the finalization call into a block to catch
-- potential exceptions raised during finalization. Generate:
-- begin
-- [Temp := null;]
-- [Deep_]Finalize (Obj_Ref);
-- exception
-- when others =>
-- if not Raised then
-- Raised := True;
-- Save_Occurrence
-- (Enn, Get_Current_Excep.all.all);
-- end if;
-- end;
if Exceptions_OK then
Fin_Stmts := New_List;
if Present (Hook_Clr) then
Append_To (Fin_Stmts, Hook_Clr);
end if;
Append_To (Fin_Stmts, Fin_Call);
Prepend_To (Blk_Stmts,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Fin_Stmts,
Exception_Handlers => New_List (
Build_Exception_Handler (Fin_Data)))));
-- Otherwise generate:
-- [Temp := null;]
-- [Deep_]Finalize (Obj_Ref);
else
Prepend_To (Blk_Stmts, Fin_Call);
if Present (Hook_Clr) then
Prepend_To (Blk_Stmts, Hook_Clr);
end if;
end if;
Process_Transient_In_Scope
(Obj_Decl => Obj_Decl,
Blk_Data => Blk_Data,
Blk_Stmts => Blk_Stmts);
end if;
-- Terminate the scan after the last object has been processed to
@ -6806,12 +6772,15 @@ package body Exp_Ch7 is
Next (Obj_Decl);
end loop;
-- Complete the decoration of the enclosing finalization block and
-- insert it into the tree.
if Present (Blk_Decl) then
-- Note that the abort defer / undefer pair does not require an
-- extra block because each finalization exception is caught in
-- its corresponding finalization block. As a result, the call to
-- Abort_Defer always takes place.
-- Note that this Abort_Undefer does not require a extra block or
-- an AT_END handler because each finalization exception is caught
-- in its own corresponding finalization block. As a result, the
-- call to Abort_Defer always takes place.
if Abort_Allowed then
Prepend_To (Blk_Stmts,
@ -6821,9 +6790,18 @@ package body Exp_Ch7 is
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
-- Generate:
-- if Raised and then not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
if Exceptions_OK then
Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
end if;
Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if;
end Process_Transient_Objects;
end Process_Transients_In_Scope;
-- Local variables
@ -6901,10 +6879,10 @@ package body Exp_Ch7 is
(Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
end if;
-- Check for transient controlled objects associated with Target and
-- generate the appropriate finalization actions for them.
-- Check for transient objects associated with Target and generate the
-- appropriate finalization actions for them.
Process_Transient_Objects
Process_Transients_In_Scope
(First_Object => First_Obj,
Last_Object => Last_Obj,
Related_Node => Target);

155
gcc/ada/exp_util.adb
View File

@ -1653,6 +1653,133 @@ package body Exp_Util is
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
---------------------------------------
-- Build_Transient_Object_Statements --
---------------------------------------
procedure Build_Transient_Object_Statements
(Obj_Decl : Node_Id;
Fin_Call : out Node_Id;
Hook_Assign : out Node_Id;
Hook_Clear : out Node_Id;
Hook_Decl : out Node_Id;
Ptr_Decl : out Node_Id;
Finalize_Obj : Boolean := True)
is
Loc : constant Source_Ptr := Sloc (Obj_Decl);
Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
Desig_Typ : Entity_Id;
Hook_Expr : Node_Id;
Hook_Id : Entity_Id;
Obj_Ref : Node_Id;
Ptr_Typ : Entity_Id;
begin
-- Recover the type of the object
Desig_Typ := Obj_Typ;
if Is_Access_Type (Desig_Typ) then
Desig_Typ := Available_View (Designated_Type (Desig_Typ));
end if;
-- Create an access type which provides a reference to the transient
-- object. Generate:
-- type Ptr_Typ is access all Desig_Typ;
Ptr_Typ := Make_Temporary (Loc, 'A');
Set_Ekind (Ptr_Typ, E_General_Access_Type);
Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
Ptr_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
-- Create a temporary check which acts as a hook to the transient
-- object. Generate:
-- Hook : Ptr_Typ := null;
Hook_Id := Make_Temporary (Loc, 'T');
Set_Ekind (Hook_Id, E_Variable);
Set_Etype (Hook_Id, Ptr_Typ);
Hook_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Hook_Id,
Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
Expression => Make_Null (Loc));
-- Mark the temporary as a hook. This signals the machinery in
-- Build_Finalizer to recognize this special case.
Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
-- Hook the transient object to the temporary. Generate:
-- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- Hool := Obj_Id'Unrestricted_Access;
if Is_Access_Type (Obj_Typ) then
Hook_Expr :=
Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
else
Hook_Expr :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc),
Attribute_Name => Name_Unrestricted_Access);
end if;
Hook_Assign :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Hook_Expr);
-- Crear the hook prior to finalizing the object. Generate:
-- Hook := null;
Hook_Clear :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Make_Null (Loc));
-- Finalize the object. Generate:
-- [Deep_]Finalize (Obj_Ref[.all]);
if Finalize_Obj then
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
if Is_Access_Type (Obj_Typ) then
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
Set_Etype (Obj_Ref, Desig_Typ);
end if;
Fin_Call := Make_Final_Call (Obj_Ref, Desig_Typ);
-- Otherwise finalize the hook. Generate:
-- [Deep_]Finalize (Hook.all);
else
Fin_Call :=
Make_Final_Call (
Obj_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Hook_Id, Loc)),
Typ => Desig_Typ);
end if;
end Build_Transient_Object_Statements;
-----------------------------
-- Check_Float_Op_Overflow --
-----------------------------
@ -5067,7 +5194,7 @@ package body Exp_Util is
-- explicit aliases of it:
-- do
-- Trans_Id : Ctrl_Typ ...; -- controlled transient object
-- Trans_Id : Ctrl_Typ ...; -- transient object
-- Alias : ... := Trans_Id; -- object is aliased
-- Val : constant Boolean :=
-- ... Alias ...; -- aliasing ends
@ -5236,6 +5363,10 @@ package body Exp_Util is
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
-- Do not consider a transient object that was already processed
and then not Is_Finalized_Transient (Obj_Id)
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
@ -8255,11 +8386,19 @@ package body Exp_Util is
if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Transient variables are treated separately in order to minimize
-- the size of the generated code. See Exp_Ch7.Process_Transient_
-- Objects.
-- Finalization of transient objects are treated separately in
-- order to handle sensitive cases. These include:
elsif Is_Processed_Transient (Obj_Id) then
-- * Aggregate expansion
-- * If, case, and expression with actions expansion
-- * Transient scopes
-- If one of those contexts has marked the transient object as
-- ignored, do not generate finalization actions for it.
elsif Is_Finalized_Transient (Obj_Id)
or else Is_Ignored_Transient (Obj_Id)
then
null;
-- Ignored Ghost objects do not need any cleanup actions because
@ -8315,8 +8454,8 @@ package body Exp_Util is
then
return True;
-- Processing for "hook" objects generated for controlled
-- transients declared inside an Expression_With_Actions.
-- Processing for "hook" objects generated for transient objects
-- declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@ -8464,7 +8603,7 @@ package body Exp_Util is
elsif Nkind (Decl) = N_Block_Statement
and then
-- Handle a rare case caused by a controlled transient variable
-- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.

29
gcc/ada/exp_util.ads
View File

@ -280,6 +280,35 @@ package Exp_Util is
-- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups.
procedure Build_Transient_Object_Statements
(Obj_Decl : Node_Id;
Fin_Call : out Node_Id;
Hook_Assign : out Node_Id;
Hook_Clear : out Node_Id;
Hook_Decl : out Node_Id;
Ptr_Decl : out Node_Id;
Finalize_Obj : Boolean := True);
-- Subsidiary to the processing of transient objects in transient scopes,
-- if expressions, case expressions, expression_with_action nodes, array
-- aggregates, and record aggregates. Obj_Decl denotes the declaration of
-- the transient object. Generate the following nodes:
--
-- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient
-- object if flag Finalize_Obj is set to True, or finalizes the hook when
-- the flag is False.
--
-- * Hook_Assign - the assignment statement which captures a reference to
-- the transient object in the hook.
--
-- * Hook_Clear - the assignment statement which resets the hook to null
--
-- * Hook_Decl - the declaration of the hook object
--
-- * Ptr_Decl - the full type declaration of the hook type
--
-- These nodes are inserted in specific places depending on the context by
-- the various Process_Transient_xxx routines.
procedure Check_Float_Op_Overflow (N : Node_Id);
-- Called where we could have a floating-point binary operator where we
-- must check for infinities if we are operating in Check_Float_Overflow

676
gcc/ada/sem_aggr.adb
View File

@ -2930,7 +2930,7 @@ package body Sem_Aggr is
end if;
else
Error_Msg_N ("no unique type for this aggregate", A);
Error_Msg_N ("no unique type for this aggregate", A);
end if;
Check_Function_Writable_Actuals (N);
@ -2941,25 +2941,9 @@ package body Sem_Aggr is
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
Assoc : Node_Id;
-- N_Component_Association node belonging to the input aggregate N
Expr : Node_Id;
Positional_Expr : Node_Id;
Component : Entity_Id;
Component_Elmt : Elmt_Id;
Components : constant Elist_Id := New_Elmt_List;
-- Components is the list of the record components whose value must be
-- provided in the aggregate. This list does include discriminants.
New_Assoc_List : constant List_Id := New_List;
New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
-- nodes. New_Assoc is one such N_Component_Association node in it.
-- Note that while Assoc and New_Assoc contain the same kind of nodes,
-- they are used to iterate over two different N_Component_Association
-- lists.
-- nodes.
Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component
@ -2975,7 +2959,6 @@ package body Sem_Aggr is
Box_Node : Node_Id;
Is_Box_Present : Boolean := False;
Others_Box : Integer := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
@ -2983,9 +2966,9 @@ package body Sem_Aggr is
-- (which may be a sub-aggregate of a larger one) that are default-
-- initialized. A value of One indicates that an others_box is present.
-- Any larger value indicates that the others_box is not redundant.
-- These variables, similar to Others_Etype, are also updated as a
-- side effect of function Get_Value.
-- Box_Node is used to place a warning on a redundant others_box.
-- These variables, similar to Others_Etype, are also updated as a side
-- effect of function Get_Value. Box_Node is used to place a warning on
-- a redundant others_box.
procedure Add_Association
(Component : Entity_Id;
@ -2997,14 +2980,23 @@ package body Sem_Aggr is
-- either New_Assoc_List, or the association being built for an inner
-- aggregate.
function Discr_Present (Discr : Entity_Id) return Boolean;
procedure Add_Discriminant_Values
(New_Aggr : Node_Id;
Assoc_List : List_Id);
-- The constraint to a component may be given by a discriminant of the
-- enclosing type, in which case we have to retrieve its value, which is
-- part of the enclosing aggregate. Assoc_List provides the discriminant
-- associations of the current type or of some enclosing record.
function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
-- Otherwise, if N is an extension aggregate, Discr is a discriminant
-- whose value may already have been specified by N's ancestor part.
-- This routine checks whether this is indeed the case and if so returns
-- False, signaling that no value for Discr should appear in N's
-- aggregate part. Also, in this case, the routine appends to
-- New_Assoc_List the discriminant value specified in the ancestor part.
-- Otherwise, if N is an extension aggregate, then Input_Discr denotes
-- a discriminant whose value may already have been specified by N's
-- ancestor part. This routine checks whether this is indeed the case
-- and if so returns False, signaling that no value for Input_Discr
-- should appear in N's aggregate part. Also, in this case, the routine
-- appends to New_Assoc_List the discriminant value specified in the
-- ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed. The inherited discriminant values must not be reinserted
@ -3012,11 +3004,16 @@ package body Sem_Aggr is
-- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion.
function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id;
-- AI05-0115: Find earlier ancestor in the derivation chain that is
-- derived from private view Typ. Whether the aggregate is legal depends
-- on the current visibility of the type as well as that of the parent
-- of the ancestor.
function Get_Value
(Compon : Node_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False)
return Node_Id;
Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
-- returns its value as it appears in the list From, which is a list
-- of N_Component_Association nodes.
@ -3041,7 +3038,14 @@ package body Sem_Aggr is
-- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node.
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id);
-- Nested components may themselves be discriminated types constrained
-- by outer discriminants, whose values must be captured before the
-- aggregate is expanded into assignments.
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id);
-- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr.
-- It finally saves a Expr in the newly created association list that
@ -3059,13 +3063,12 @@ package body Sem_Aggr is
Assoc_List : List_Id;
Is_Box_Present : Boolean := False)
is
Loc : Source_Ptr;
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
Loc : Source_Ptr;
begin
-- If this is a box association the expression is missing, so
-- use the Sloc of the aggregate itself for the new association.
-- If this is a box association the expression is missing, so use the
-- Sloc of the aggregate itself for the new association.
if Present (Expr) then
Loc := Sloc (Expr);
@ -3073,34 +3076,97 @@ package body Sem_Aggr is
Loc := Sloc (N);
end if;
Append (New_Occurrence_Of (Component, Loc), Choice_List);
New_Assoc :=
Append_To (Choice_List, New_Occurrence_Of (Component, Loc));
Append_To (Assoc_List,
Make_Component_Association (Loc,
Choices => Choice_List,
Expression => Expr,
Box_Present => Is_Box_Present);
Append (New_Assoc, Assoc_List);
Box_Present => Is_Box_Present));
end Add_Association;
-------------------
-- Discr_Present --
-------------------
-----------------------------
-- Add_Discriminant_Values --
-----------------------------
function Discr_Present (Discr : Entity_Id) return Boolean is
procedure Add_Discriminant_Values
(New_Aggr : Node_Id;
Assoc_List : List_Id)
is
Assoc : Node_Id;
Discr : Entity_Id;
Discr_Elmt : Elmt_Id;
Discr_Val : Node_Id;
Val : Entity_Id;
begin
Discr := First_Discriminant (Etype (New_Aggr));
Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr)));
while Present (Discr_Elmt) loop
Discr_Val := Node (Discr_Elmt);
-- If the constraint is given by a discriminant then it is a
-- discriminant of an enclosing record, and its value has already
-- been placed in the association list.
if Is_Entity_Name (Discr_Val)
and then Ekind (Entity (Discr_Val)) = E_Discriminant
then
Val := Entity (Discr_Val);
Assoc := First (Assoc_List);
while Present (Assoc) loop
if Present (Entity (First (Choices (Assoc))))
and then Entity (First (Choices (Assoc))) = Val
then
Discr_Val := Expression (Assoc);
exit;
end if;
Next (Assoc);
end loop;
end if;
Add_Association
(Discr, New_Copy_Tree (Discr_Val),
Component_Associations (New_Aggr));
-- If the discriminant constraint is a current instance, mark the
-- current aggregate so that the self-reference can be expanded
-- later. The constraint may refer to the subtype of aggregate, so
-- use base type for comparison.
if Nkind (Discr_Val) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Discr_Val))
and then Is_Type (Entity (Prefix (Discr_Val)))
and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val))
then
Set_Has_Self_Reference (N);
end if;
Next_Elmt (Discr_Elmt);
Next_Discriminant (Discr);
end loop;
end Add_Discriminant_Values;
--------------------------
-- Discriminant_Present --
--------------------------
function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is
Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
Ancestor_Is_Subtyp : Boolean;
Loc : Source_Ptr;
Ancestor : Node_Id;
Comp_Assoc : Node_Id;
Discr_Expr : Node_Id;
Ancestor_Typ : Entity_Id;
Comp_Assoc : Node_Id;
Discr : Entity_Id;
Discr_Expr : Node_Id;
Discr_Val : Elmt_Id := No_Elmt;
Orig_Discr : Entity_Id;
D : Entity_Id;
D_Val : Elmt_Id := No_Elmt; -- stop junk warning
Ancestor_Is_Subtyp : Boolean;
begin
if Regular_Aggr then
@ -3157,41 +3223,66 @@ package body Sem_Aggr is
-- Now look to see if Discr was specified in the ancestor part
if Ancestor_Is_Subtyp then
D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
Discr_Val :=
First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if;
Orig_Discr := Original_Record_Component (Discr);
Orig_Discr := Original_Record_Component (Input_Discr);
D := First_Discriminant (Ancestor_Typ);
while Present (D) loop
Discr := First_Discriminant (Ancestor_Typ);
while Present (Discr) loop
-- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate.
if Original_Record_Component (D) = Orig_Discr then
if Original_Record_Component (Discr) = Orig_Discr then
if Ancestor_Is_Subtyp then
Discr_Expr := New_Copy_Tree (Node (D_Val));
Discr_Expr := New_Copy_Tree (Node (Discr_Val));
else
Discr_Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor),
Selector_Name => New_Occurrence_Of (Discr, Loc));
Selector_Name => New_Occurrence_Of (Input_Discr, Loc));
end if;
Resolve_Aggr_Expr (Discr_Expr, Discr);
Resolve_Aggr_Expr (Discr_Expr, Input_Discr);
Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
Next_Discriminant (D);
Next_Discriminant (Discr);
if Ancestor_Is_Subtyp then
Next_Elmt (D_Val);
Next_Elmt (Discr_Val);
end if;
end loop;
return True;
end Discr_Present;
end Discriminant_Present;
---------------------------
-- Find_Private_Ancestor --
---------------------------
function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is
Par : Entity_Id;
begin
Par := Typ;
loop
if Has_Private_Ancestor (Par)
and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
then
return Par;
elsif not Is_Derived_Type (Par) then
return Empty;
else
Par := Etype (Base_Type (Par));
end if;
end loop;
end Find_Private_Ancestor;
---------------
-- Get_Value --
@ -3200,8 +3291,7 @@ package body Sem_Aggr is
function Get_Value
(Compon : Node_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False)
return Node_Id
Consider_Others_Choice : Boolean := False) return Node_Id
is
Typ : constant Entity_Id := Etype (Compon);
Assoc : Node_Id;
@ -3266,14 +3356,14 @@ package body Sem_Aggr is
null;
else
Error_Msg_N
("components in OTHERS choice must "
& "have same type", Selector_Name);
("components in OTHERS choice must have same "
& "type", Selector_Name);
end if;
end if;
Others_Etype := Typ;
-- Copy expression so that it is resolved
-- Copy the expression so that it is resolved
-- independently for each component, This is needed
-- for accessibility checks on compoents of anonymous
-- access types, even in compile_only mode.
@ -3414,11 +3504,110 @@ package body Sem_Aggr is
return New_Copy;
end New_Copy_Tree_And_Copy_Dimensions;
-----------------------------
-- Propagate_Discriminants --
-----------------------------
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Needs_Box : Boolean := False;
procedure Process_Component (Comp : Entity_Id);
-- Add one component with a box association to the inner aggregate,
-- and recurse if component is itself composite.
-----------------------
-- Process_Component --
-----------------------
procedure Process_Component (Comp : Entity_Id) is
T : constant Entity_Id := Etype (Comp);
New_Aggr : Node_Id;
begin
if Is_Record_Type (T) and then Has_Discriminants (T) then
New_Aggr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (New_Aggr, T);
Add_Association
(Comp, New_Aggr, Component_Associations (Aggr));
-- Collect discriminant values and recurse
Add_Discriminant_Values (New_Aggr, Assoc_List);
Propagate_Discriminants (New_Aggr, Assoc_List);
else
Needs_Box := True;
end if;
end Process_Component;
-- Local variables
Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr));
Components : constant Elist_Id := New_Elmt_List;
Def_Node : constant Node_Id :=
Type_Definition (Declaration_Node (Aggr_Type));
Comp : Node_Id;
Comp_Elmt : Elmt_Id;
Errors : Boolean;
-- Start of processing for Propagate_Discriminants
begin
-- The component type may be a variant type. Collect the components
-- that are ruled by the known values of the discriminants. Their
-- values have already been inserted into the component list of the
-- current aggregate.
if Nkind (Def_Node) = N_Record_Definition
and then Present (Component_List (Def_Node))
and then Present (Variant_Part (Component_List (Def_Node)))
then
Gather_Components (Aggr_Type,
Component_List (Def_Node),
Governed_By => Component_Associations (Aggr),
Into => Components,
Report_Errors => Errors);
Comp_Elmt := First_Elmt (Components);
while Present (Comp_Elmt) loop
if Ekind (Node (Comp_Elmt)) /= E_Discriminant then
Process_Component (Node (Comp_Elmt));
end if;
Next_Elmt (Comp_Elmt);
end loop;
-- No variant part, iterate over all components
else
Comp := First_Component (Etype (Aggr));
while Present (Comp) loop
Process_Component (Comp);
Next_Component (Comp);
end loop;
end if;
if Needs_Box then
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices => New_List (Make_Others_Choice (Loc)),
Expression => Empty,
Box_Present => True));
end if;
end Propagate_Discriminants;
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
-- expansion is delayed until the enclosing aggregate is expanded
@ -3433,14 +3622,15 @@ package body Sem_Aggr is
---------------------------
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Expr);
begin
return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)
and then Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Expansion_Delayed (Expr))
or else (Kind = N_Qualified_Expression
and then Has_Expansion_Delayed (Expression (Expr)));
return
(Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
and then Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Expansion_Delayed (Expr))
or else
(Nkind (Expr) = N_Qualified_Expression
and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
-- Local variables
@ -3580,6 +3770,8 @@ package body Sem_Aggr is
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if;
-- Add association Component => Expr if the caller requests it
if Relocate then
New_Expr := Relocate_Node (Expr);
@ -3595,6 +3787,17 @@ package body Sem_Aggr is
Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr;
-- Local variables
Components : constant Elist_Id := New_Elmt_List;
-- Components is the list of the record components whose value must be
-- provided in the aggregate. This list does include discriminants.
Expr : Node_Id;
Component : Entity_Id;
Component_Elmt : Elmt_Id;
Positional_Expr : Node_Id;
-- Start of processing for Resolve_Record_Aggregate
begin
@ -3607,7 +3810,6 @@ package body Sem_Aggr is
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
then
if Present (Expressions (N)) then
Check_SPARK_05_Restriction
("named association cannot follow positional one",
@ -3678,8 +3880,9 @@ package body Sem_Aggr is
-- STEP 2: Verify aggregate structure
Step_2 : declare
Selector_Name : Node_Id;
Assoc : Node_Id;
Bad_Aggregate : Boolean := False;
Selector_Name : Node_Id;
begin
if Present (Component_Associations (N)) then
@ -3774,7 +3977,7 @@ package body Sem_Aggr is
-- First find the discriminant values in the positional components
while Present (Discrim) and then Present (Positional_Expr) loop
if Discr_Present (Discrim) then
if Discriminant_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
-- Ada 2005 (AI-231)
@ -3802,7 +4005,7 @@ package body Sem_Aggr is
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
if not Discr_Present (Discrim) then
if not Discriminant_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
("more than one value supplied for discriminant &",
@ -3850,17 +4053,17 @@ package body Sem_Aggr is
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype : declare
Constrs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
Indic : Node_Id;
Subtyp_Decl : Node_Id;
Def_Id : Entity_Id;
C : constant List_Id := New_List;
Indic : Node_Id;
New_Assoc : Node_Id;
Subtyp_Decl : Node_Id;
begin
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
Next (New_Assoc);
end loop;
@ -3872,14 +4075,16 @@ package body Sem_Aggr is
Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C));
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constrs));
else
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C));
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constrs));
end if;
Def_Id := Create_Itype (Ekind (Typ), N);
@ -3906,45 +4111,13 @@ package body Sem_Aggr is
-- STEP 5: Get remaining components according to discriminant values
Step_5 : declare
Dnode : Node_Id;
Errors_Found : Boolean := False;
Record_Def : Node_Id;
Parent_Typ : Entity_Id;
Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id;
Errors_Found : Boolean := False;
Dnode : Node_Id;
function Find_Private_Ancestor return Entity_Id;
-- AI05-0115: Find earlier ancestor in the derivation chain that is
-- derived from a private view. Whether the aggregate is legal
-- depends on the current visibility of the type as well as that
-- of the parent of the ancestor.
---------------------------
-- Find_Private_Ancestor --
---------------------------
function Find_Private_Ancestor return Entity_Id is
Par : Entity_Id;
begin
Par := Typ;
loop
if Has_Private_Ancestor (Par)
and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
then
return Par;
elsif not Is_Derived_Type (Par) then
return Empty;
else
Par := Etype (Base_Type (Par));
end if;
end loop;
end Find_Private_Ancestor;
-- Start of processing for Step_5
Root_Typ : Entity_Id;
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
@ -3959,19 +4132,20 @@ package body Sem_Aggr is
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
-- AI05-0115: check legality of aggregate for type with
-- aa private ancestor.
-- AI05-0115: check legality of aggregate for type with a
-- private ancestor.
Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then
declare
Ancestor : constant Entity_Id :=
Find_Private_Ancestor;
Find_Private_Ancestor (Typ);
Ancestor_Unit : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Ancestor));
Cunit_Entity
(Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
Cunit_Entity
(Get_Source_Unit (Base_Type (Etype (Ancestor))));
Cunit_Entity (Get_Source_Unit
(Base_Type (Etype (Ancestor))));
begin
-- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
@ -4189,8 +4363,7 @@ package body Sem_Aggr is
-- object of the aggregate.
if Present (Parent (Component))
and then
Nkind (Parent (Component)) = N_Component_Declaration
and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
Expr :=
@ -4213,26 +4386,18 @@ package body Sem_Aggr is
elsif Present (Underlying_Type (Ctyp))
and then Is_Access_Type (Underlying_Type (Ctyp))
then
if not Is_Private_Type (Ctyp) then
Expr := Make_Null (Sloc (N));
Set_Etype (Expr, Ctyp);
Add_Association
(Component => Component,
Expr => Expr,
Assoc_List => New_Assoc_List);
-- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked
-- conversion to satisfy type checking.
else
if Is_Private_Type (Ctyp) then
declare
Qual_Null : constant Node_Id :=
Make_Qualified_Expression (Sloc (N),
Subtype_Mark =>
New_Occurrence_Of
(Underlying_Type (Ctyp), Sloc (N)),
Expression => Make_Null (Sloc (N)));
Expression => Make_Null (Sloc (N)));
Convert_Null : constant Node_Id :=
Unchecked_Convert_To
@ -4245,6 +4410,17 @@ package body Sem_Aggr is
Expr => Convert_Null,
Assoc_List => New_Assoc_List);
end;
-- Otherwise the component type is non-private
else
Expr := Make_Null (Sloc (N));
Set_Etype (Expr, Ctyp);
Add_Association
(Component => Component,
Expr => Expr,
Assoc_List => New_Assoc_List);
end if;
-- Ada 2012: If component is scalar with default value, use it
@ -4254,8 +4430,9 @@ package body Sem_Aggr is
then
Add_Association
(Component => Component,
Expr => Default_Aspect_Value
(First_Subtype (Underlying_Type (Ctyp))),
Expr =>
Default_Aspect_Value
(First_Subtype (Underlying_Type (Ctyp))),
Assoc_List => New_Assoc_List);
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
@ -4270,8 +4447,8 @@ package body Sem_Aggr is
-- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of
-- the component. The capture of discriminants must
-- be recursive because subcomponents may be constrained
-- the component. The capture of discriminants must be
-- recursive because subcomponents may be constrained
-- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no
@ -4281,206 +4458,6 @@ package body Sem_Aggr is
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id;
procedure Add_Discriminant_Values
(New_Aggr : Node_Id;
Assoc_List : List_Id);
-- The constraint to a component may be given by a
-- discriminant of the enclosing type, in which case
-- we have to retrieve its value, which is part of the
-- enclosing aggregate. Assoc_List provides the
-- discriminant associations of the current type or
-- of some enclosing record.
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id);
-- Nested components may themselves be discriminated
-- types constrained by outer discriminants, whose
-- values must be captured before the aggregate is
-- expanded into assignments.
-----------------------------
-- Add_Discriminant_Values --
-----------------------------
procedure Add_Discriminant_Values
(New_Aggr : Node_Id;
Assoc_List : List_Id)
is
Assoc : Node_Id;
Discr : Entity_Id;
Discr_Elmt : Elmt_Id;
Discr_Val : Node_Id;
Val : Entity_Id;
begin
Discr := First_Discriminant (Etype (New_Aggr));
Discr_Elmt :=
First_Elmt
(Discriminant_Constraint (Etype (New_Aggr)));
while Present (Discr_Elmt) loop
Discr_Val := Node (Discr_Elmt);
-- If the constraint is given by a discriminant
-- it is a discriminant of an enclosing record,
-- and its value has already been placed in the
-- association list.
if Is_Entity_Name (Discr_Val)
and then
Ekind (Entity (Discr_Val)) = E_Discriminant
then
Val := Entity (Discr_Val);
Assoc := First (Assoc_List);
while Present (Assoc) loop
if Present
(Entity (First (Choices (Assoc))))
and then
Entity (First (Choices (Assoc))) = Val
then
Discr_Val := Expression (Assoc);
exit;
end if;
Next (Assoc);
end loop;
end if;
Add_Association
(Discr, New_Copy_Tree (Discr_Val),
Component_Associations (New_Aggr));
-- If the discriminant constraint is a current
-- instance, mark the current aggregate so that
-- the self-reference can be expanded later.
-- The constraint may refer to the subtype of
-- aggregate, so use base type for comparison.
if Nkind (Discr_Val) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Discr_Val))
and then Is_Type (Entity (Prefix (Discr_Val)))
and then Base_Type (Etype (N)) =
Entity (Prefix (Discr_Val))
then
Set_Has_Self_Reference (N);
end if;
Next_Elmt (Discr_Elmt);
Next_Discriminant (Discr);
end loop;
end Add_Discriminant_Values;
-----------------------------
-- Propagate_Discriminants --
-----------------------------
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id)
is
Aggr_Type : constant Entity_Id :=
Base_Type (Etype (Aggr));
Def_Node : constant Node_Id :=
Type_Definition
(Declaration_Node (Aggr_Type));
Comp : Node_Id;
Comp_Elmt : Elmt_Id;
Components : constant Elist_Id := New_Elmt_List;
Needs_Box : Boolean := False;
Errors : Boolean;
procedure Process_Component (Comp : Entity_Id);
-- Add one component with a box association to the
-- inner aggregate, and recurse if component is
-- itself composite.
-----------------------
-- Process_Component --
-----------------------
procedure Process_Component (Comp : Entity_Id) is
T : constant Entity_Id := Etype (Comp);
New_Aggr : Node_Id;
begin
if Is_Record_Type (T)
and then Has_Discriminants (T)
then
New_Aggr :=
Make_Aggregate (Loc, New_List, New_List);
Set_Etype (New_Aggr, T);
Add_Association
(Comp, New_Aggr,
Component_Associations (Aggr));
-- Collect discriminant values and recurse
Add_Discriminant_Values
(New_Aggr, Assoc_List);
Propagate_Discriminants
(New_Aggr, Assoc_List);
else
Needs_Box := True;
end if;
end Process_Component;
-- Start of processing for Propagate_Discriminants
begin
-- The component type may be a variant type, so
-- collect the components that are ruled by the
-- known values of the discriminants. Their values
-- have already been inserted into the component
-- list of the current aggregate.
if Nkind (Def_Node) = N_Record_Definition
and then Present (Component_List (Def_Node))
and then
Present
(Variant_Part (Component_List (Def_Node)))
then
Gather_Components (Aggr_Type,
Component_List (Def_Node),
Governed_By => Component_Associations (Aggr),
Into => Components,
Report_Errors => Errors);
Comp_Elmt := First_Elmt (Components);
while Present (Comp_Elmt) loop
if Ekind (Node (Comp_Elmt)) /=
E_Discriminant
then
Process_Component (Node (Comp_Elmt));
end if;
Next_Elmt (Comp_Elmt);
end loop;
-- No variant part, iterate over all components
else
Comp := First_Component (Etype (Aggr));
while Present (Comp) loop
Process_Component (Comp);
Next_Component (Comp);
end loop;
end if;
if Needs_Box then
Append_To (Component_Associations (Aggr),
Make_Component_Association (Loc,
Choices =>
New_List (Make_Others_Choice (Loc)),
Expression => Empty,
Box_Present => True));
end if;
end Propagate_Discriminants;
-- Start of processing for Capture_Discriminants
begin
Expr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (Expr, Ctyp);
@ -4498,9 +4475,9 @@ package body Sem_Aggr is
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
(Expr, Component_Associations (Expr));
(Expr, Component_Associations (Expr));
Propagate_Discriminants
(Expr, Component_Associations (Expr));
(Expr, Component_Associations (Expr));
else
declare
@ -4523,6 +4500,7 @@ package body Sem_Aggr is
Expression => Empty,
Box_Present => True));
end if;
exit;
end if;
@ -4537,6 +4515,9 @@ package body Sem_Aggr is
Assoc_List => New_Assoc_List);
end Capture_Discriminants;
-- Otherwise the component type is not a record, or it has
-- not discriminants, or it is private.
else
Add_Association
(Component => Component,
@ -4576,6 +4557,9 @@ package body Sem_Aggr is
-- STEP 7: check for invalid components + check type in choice list
Step_7 : declare
Assoc : Node_Id;
New_Assoc : Node_Id;
Selectr : Node_Id;
-- Selector name
@ -4651,7 +4635,7 @@ package body Sem_Aggr is
if Nkind (N) /= N_Extension_Aggregate
or else
Scope (Original_Record_Component (C)) /=
Etype (Ancestor_Part (N))
Etype (Ancestor_Part (N))
then
exit;
end if;

18
gcc/ada/sem_ch3.adb
View File

@ -4802,6 +4802,24 @@ package body Sem_Ch3 is
then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
-- Generated subtypes inherit the predicate function from the parent
-- (no aspects to examine on the generated declaration).
if not Comes_From_Source (N) then
Set_Ekind (Id, Ekind (T));
if Present (Predicate_Function (T)) then
Set_Predicate_Function (Id, Predicate_Function (T));
elsif Present (Ancestor_Subtype (T))
and then Has_Predicates (Ancestor_Subtype (T))
and then Present (Predicate_Function (Ancestor_Subtype (T)))
then
Set_Predicate_Function (Id,
Predicate_Function (Ancestor_Subtype (T)));
end if;
end if;
end if;
-- Subtype of Boolean cannot have a constraint in SPARK

8
gcc/ada/sem_res.adb
View File

@ -9951,10 +9951,10 @@ package body Sem_Res is
begin
-- Ensure all actions associated with the left operand (e.g.
-- finalization of transient controlled objects) are fully evaluated
-- locally within an expression with actions. This is particularly
-- helpful for coverage analysis. However this should not happen in
-- generics or if Minimize_Expression_With_Actions is set.
-- finalization of transient objects) are fully evaluated locally within
-- an expression with actions. This is particularly helpful for coverage
-- analysis. However this should not happen in generics or if option
-- Minimize_Expression_With_Actions is set.
if Expander_Active and not Minimize_Expression_With_Actions then
declare