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> 2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting. * 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_Predicates Flag250
-- Has_Implicit_Dereference Flag251 -- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252 -- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253 -- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254 -- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255 -- Is_Predicate_Function Flag255
@ -609,8 +609,8 @@ package body Einfo is
-- Is_Partial_Invariant_Procedure Flag292 -- Is_Partial_Invariant_Procedure Flag292
-- Is_Actual_Subtype Flag293 -- Is_Actual_Subtype Flag293
-- Has_Pragma_Unused Flag294 -- Has_Pragma_Unused Flag294
-- Is_Ignored_Transient Flag295
-- (unused) Flag295
-- (unused) Flag296 -- (unused) Flag296
-- (unused) Flag297 -- (unused) Flag297
-- (unused) Flag298 -- (unused) Flag298
@ -2185,6 +2185,12 @@ package body Einfo is
return Flag99 (Id); return Flag99 (Id);
end Is_Exported; 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 function Is_First_Subtype (Id : E) return B is
begin begin
return Flag70 (Id); return Flag70 (Id);
@ -2250,6 +2256,12 @@ package body Einfo is
return Flag278 (Id); return Flag278 (Id);
end Is_Ignored_Ghost_Entity; 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 function Is_Immediately_Visible (Id : E) return B is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
@ -2466,12 +2478,6 @@ package body Einfo is
return Flag245 (Id); return Flag245 (Id);
end Is_Private_Primitive; 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 function Is_Public (Id : E) return B is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
@ -5248,6 +5254,12 @@ package body Einfo is
Set_Flag99 (Id, V); Set_Flag99 (Id, V);
end Set_Is_Exported; 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 procedure Set_Is_First_Subtype (Id : E; V : B := True) is
begin begin
Set_Flag70 (Id, V); Set_Flag70 (Id, V);
@ -5329,6 +5341,12 @@ package body Einfo is
Set_Flag278 (Id, V); Set_Flag278 (Id, V);
end Set_Is_Ignored_Ghost_Entity; 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 procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
@ -5543,12 +5561,6 @@ package body Einfo is
Set_Flag245 (Id, V); Set_Flag245 (Id, V);
end Set_Is_Private_Primitive; 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 procedure Set_Is_Public (Id : E; V : B := True) is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
@ -9241,6 +9253,7 @@ package body Einfo is
W ("Is_Entry_Formal", Flag52 (Id)); W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exception_Handler", Flag286 (Id)); W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id)); W ("Is_Exported", Flag99 (Id));
W ("Is_Finalized_Transient", Flag252 (Id));
W ("Is_First_Subtype", Flag70 (Id)); W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id)); W ("Is_For_Access_Subtype", Flag118 (Id));
W ("Is_Formal_Subprogram", Flag111 (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_Non_Overridden_Subpgm", Flag2 (Id));
W ("Is_Hidden_Open_Scope", Flag171 (Id)); W ("Is_Hidden_Open_Scope", Flag171 (Id));
W ("Is_Ignored_Ghost_Entity", Flag278 (Id)); W ("Is_Ignored_Ghost_Entity", Flag278 (Id));
W ("Is_Ignored_Transient", Flag295 (Id));
W ("Is_Immediately_Visible", Flag7 (Id)); W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Implementation_Defined", Flag254 (Id)); W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id)); W ("Is_Imported", Flag24 (Id));
@ -9292,7 +9306,6 @@ package body Einfo is
W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id)); W ("Is_Private_Primitive", Flag245 (Id));
W ("Is_Processed_Transient", Flag252 (Id));
W ("Is_Public", Flag10 (Id)); W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id)); W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (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 -- a build-in-place function call. Contains the relocated build-in-place
-- call after the expansion has decoupled the call from the object. This -- call after the expansion has decoupled the call from the object. This
-- attribute is used by the finalization machinery to insert cleanup code -- 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] -- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Defined in record types. Set if a pragma Convention for the record -- 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 -- Applies to all entities, true for abstract states that are subject to
-- option External. -- 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) -- Is_Finalizer (synthesized)
-- Applies to all entities, true for procedures containing finalization -- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects. -- 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 -- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Ignore. -- 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) -- Is_Immediately_Visible (Flag7)
-- Defined in all entities. Set if entity is immediately visible, i.e. -- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)). -- 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, -- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as 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) -- Is_Protected_Component (synthesized)
-- Applicable to all entities, true if the entity denotes a private -- Applicable to all entities, true if the entity denotes a private
-- component of a protected type. -- component of a protected type.
@ -5786,8 +5792,9 @@ package Einfo is
-- Has_Volatile_Components (Flag87) -- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85) -- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124) -- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268) -- Is_Independent (Flag268)
-- Is_Processed_Transient (Flag252) (constants only)
-- Is_Return_Object (Flag209) -- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163) -- Is_True_Constant (Flag163)
-- Is_Uplevel_Referenced_Entity (Flag283) -- Is_Uplevel_Referenced_Entity (Flag283)
@ -6552,8 +6559,9 @@ package Einfo is
-- Has_Volatile_Components (Flag87) -- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85) -- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124) -- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268) -- Is_Independent (Flag268)
-- Is_Processed_Transient (Flag252)
-- Is_Return_Object (Flag209) -- Is_Return_Object (Flag209)
-- Is_Safe_To_Reevaluate (Flag249) -- Is_Safe_To_Reevaluate (Flag249)
-- Is_Shared_Passive (Flag60) -- Is_Shared_Passive (Flag60)
@ -7062,6 +7070,7 @@ package Einfo is
function Is_Entry_Formal (Id : E) return B; function Is_Entry_Formal (Id : E) return B;
function Is_Exception_Handler (Id : E) return B; function Is_Exception_Handler (Id : E) return B;
function Is_Exported (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_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B; function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (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_Non_Overridden_Subpgm (Id : E) return B;
function Is_Hidden_Open_Scope (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_Ghost_Entity (Id : E) return B;
function Is_Ignored_Transient (Id : E) return B;
function Is_Immediately_Visible (Id : E) return B; function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B; function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (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_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B; function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (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_Public (Id : E) return B;
function Is_Pure (Id : E) return B; function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (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_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Exception_Handler (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_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_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_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); 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_Non_Overridden_Subpgm (Id : E; V : B := True);
procedure Set_Is_Hidden_Open_Scope (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_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_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True); procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (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_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (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_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_Public (Id : E; V : B := True);
procedure Set_Is_Pure (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); 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_Enumeration_Type);
pragma Inline (Is_Exception_Handler); pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported); pragma Inline (Is_Exported);
pragma Inline (Is_Finalized_Transient);
pragma Inline (Is_First_Subtype); pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type); pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_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_Non_Overridden_Subpgm);
pragma Inline (Is_Hidden_Open_Scope); pragma Inline (Is_Hidden_Open_Scope);
pragma Inline (Is_Ignored_Ghost_Entity); pragma Inline (Is_Ignored_Ghost_Entity);
pragma Inline (Is_Ignored_Transient);
pragma Inline (Is_Immediately_Visible); pragma Inline (Is_Immediately_Visible);
pragma Inline (Is_Implementation_Defined); pragma Inline (Is_Implementation_Defined);
pragma Inline (Is_Imported); pragma Inline (Is_Imported);
@ -8612,7 +8624,6 @@ package Einfo is
pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type); pragma Inline (Is_Private_Type);
pragma Inline (Is_Processed_Transient);
pragma Inline (Is_Protected_Type); pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public); pragma Inline (Is_Public);
pragma Inline (Is_Pure); pragma Inline (Is_Pure);
@ -9039,6 +9050,7 @@ package Einfo is
pragma Inline (Set_Is_Entry_Formal); pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Exception_Handler); pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported); pragma Inline (Set_Is_Exported);
pragma Inline (Set_Is_Finalized_Transient);
pragma Inline (Set_Is_First_Subtype); pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype); pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram); 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_Non_Overridden_Subpgm);
pragma Inline (Set_Is_Hidden_Open_Scope); pragma Inline (Set_Is_Hidden_Open_Scope);
pragma Inline (Set_Is_Ignored_Ghost_Entity); pragma Inline (Set_Is_Ignored_Ghost_Entity);
pragma Inline (Set_Is_Ignored_Transient);
pragma Inline (Set_Is_Immediately_Visible); pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined); pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported); pragma Inline (Set_Is_Imported);
@ -9090,7 +9103,6 @@ package Einfo is
pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive); pragma Inline (Set_Is_Private_Primitive);
pragma Inline (Set_Is_Processed_Transient);
pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type); pragma Inline (Set_Is_Pure_Unit_Access_Type);

1553
gcc/ada/exp_aggr.adb
View File

File diff suppressed because it is too large Load Diff

247
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); procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
-- Inspect and process statement list Stmt of if or case expression N for -- Inspect and process statement list Stmt of if or case expression N for
-- transient controlled objects. If such objects are found, the routine -- transient objects. If such objects are found, the routine generates code
-- generates code to clean them up when the context of the expression is -- to clean them up when the context of the expression is evaluated.
-- evaluated or elaborated.
procedure Process_Transient_Object procedure Process_Transient_In_Expression
(Decl : Node_Id; (Obj_Decl : Node_Id;
N : Node_Id; Expr : Node_Id;
Stmts : List_Id); Stmts : List_Id);
-- Subsidiary routine to the expansion of expression_with_actions, if and -- Subsidiary routine to the expansion of expression_with_actions, if and
-- case expressions. Generate all necessary code to finalize a transient -- case expressions. Generate all necessary code to finalize a transient
-- controlled object when the enclosing context is elaborated or evaluated. -- object when the enclosing context is elaborated or evaluated. Obj_Decl
-- Decl denotes the declaration of the transient controlled object which is -- denotes the declaration of the transient object, which is usually the
-- usually the result of a controlled function call. N denotes the related -- result of a controlled function call. Expr denotes the expression with
-- expression_with_actions, if expression, or case expression node. Stmts -- actions, if expression, or case expression node. Stmts denotes the
-- denotes the statement list which contains Decl, either at the top level -- statement list which contains Decl, either at the top level or within a
-- or within a nested construct. -- nested construct.
procedure Rewrite_Comparison (N : Node_Id); procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at -- 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); Prepend_List (Actions (Alt), Stmts);
end if; end if;
-- Finalize any transient controlled objects on exit from the -- Finalize any transient objects on exit from the alternative.
-- alternative. This is done only in the return optimization case -- This is done only in the return optimization case because
-- because otherwise the case expression is converted into an -- otherwise the case expression is converted into an expression
-- expression with actions which already contains this form of -- with actions which already contains this form of processing.
-- processing.
if Optimize_Return_Stmt then if Optimize_Return_Stmt then
Process_If_Case_Statements (N, Stmts); Process_If_Case_Statements (N, Stmts);
@ -4952,9 +4950,9 @@ package body Exp_Ch4 is
function Process_Action (Act : Node_Id) return Traverse_Result; function Process_Action (Act : Node_Id) return Traverse_Result;
-- Inspect and process a single action of an expression_with_actions for -- Inspect and process a single action of an expression_with_actions for
-- transient controlled objects. If such objects are found, the routine -- transient objects. If such objects are found, the routine generates
-- generates code to clean them up when the context of the expression is -- code to clean them up when the context of the expression is evaluated
-- evaluated or elaborated. -- or elaborated.
------------------------------ ------------------------------
-- Force_Boolean_Evaluation -- -- Force_Boolean_Evaluation --
@ -4997,7 +4995,7 @@ package body Exp_Ch4 is
if Nkind (Act) = N_Object_Declaration if Nkind (Act) = N_Object_Declaration
and then Is_Finalizable_Transient (Act, N) and then Is_Finalizable_Transient (Act, N)
then then
Process_Transient_Object (Act, N, Acts); Process_Transient_In_Expression (Act, N, Acts);
return Abandon; return Abandon;
-- Avoid processing temporary function results multiple times when -- Avoid processing temporary function results multiple times when
@ -5038,8 +5036,8 @@ package body Exp_Ch4 is
null; null;
-- Force the evaluation of the expression by capturing its value in a -- Force the evaluation of the expression by capturing its value in a
-- temporary. This ensures that aliases of transient controlled objects -- temporary. This ensures that aliases of transient objects do not leak
-- do not leak to the expression of the expression_with_actions node: -- to the expression of the expression_with_actions node:
-- do -- do
-- Trans_Id : Ctrl_Typ := ...; -- Trans_Id : Ctrl_Typ := ...;
@ -5059,12 +5057,12 @@ package body Exp_Ch4 is
-- in Val end; -- in Val end;
-- Once this transformation is performed, it is safe to finalize the -- 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 -- Note that Force_Evaluation does not remove side effects in operators
-- because it assumes that all operands are evaluated and side effect -- because it assumes that all operands are evaluated and side effect
-- free. This is not the case when an operand depends implicitly on the -- 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 elsif Is_Boolean_Type (Etype (Expression (N))) then
Force_Boolean_Evaluation (Expression (N)); Force_Boolean_Evaluation (Expression (N));
@ -5077,8 +5075,8 @@ package body Exp_Ch4 is
Force_Evaluation (Expression (N)); Force_Evaluation (Expression (N));
end if; end if;
-- Process all transient controlled objects found within the actions of -- Process all transient objects found within the actions of the EWA
-- the EWA node. -- node.
Act := First (Acts); Act := First (Acts);
while Present (Act) loop while Present (Act) loop
@ -12956,42 +12954,42 @@ package body Exp_Ch4 is
if Nkind (Decl) = N_Object_Declaration if Nkind (Decl) = N_Object_Declaration
and then Is_Finalizable_Transient (Decl, N) and then Is_Finalizable_Transient (Decl, N)
then then
Process_Transient_Object (Decl, N, Stmts); Process_Transient_In_Expression (Decl, N, Stmts);
end if; end if;
Next (Decl); Next (Decl);
end loop; end loop;
end Process_If_Case_Statements; end Process_If_Case_Statements;
------------------------------ -------------------------------------
-- Process_Transient_Object -- -- Process_Transient_In_Expression --
------------------------------ -------------------------------------
procedure Process_Transient_Object procedure Process_Transient_In_Expression
(Decl : Node_Id; (Obj_Decl : Node_Id;
N : Node_Id; Expr : Node_Id;
Stmts : List_Id) Stmts : List_Id)
is is
Loc : constant Source_Ptr := Sloc (Decl); Loc : constant Source_Ptr := Sloc (Obj_Decl);
Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
Obj_Typ : constant Node_Id := Etype (Obj_Id);
Desig_Typ : Entity_Id; Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
Expr : Node_Id;
Hook_Id : Entity_Id;
Hook_Insert : Node_Id;
Ptr_Id : Entity_Id;
Hook_Context : constant Node_Id := Find_Hook_Context (N);
-- The node on which to insert the hook as an action. This is usually -- The node on which to insert the hook as an action. This is usually
-- the innermost enclosing non-transient construct. -- 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; Fin_Context : Node_Id;
-- The node after which to insert the finalization actions of the -- The node after which to insert the finalization actions of the
-- transient controlled object. -- transient object.
begin begin
pragma Assert (Nkind_In (N, N_Case_Expression, pragma Assert (Nkind_In (Expr, N_Case_Expression,
N_Expression_With_Actions, N_Expression_With_Actions,
N_If_Expression)); N_If_Expression));
@ -13004,102 +13002,63 @@ package body Exp_Ch4 is
-- <finalize Trans_Id> -- <finalize Trans_Id>
-- in Result end; -- in Result end;
-- As a result, the finalization of any transient controlled objects can -- As a result, the finalization of any transient objects can safely
-- safely take place after the result capture. -- take place after the result capture.
-- ??? could this be extended to elementary types? -- ??? 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); Fin_Context := Last (Stmts);
-- Otherwise the immediate context may not be safe enough to carry out -- Otherwise the immediate context may not be safe enough to carry
-- transient controlled object finalization due to aliasing and nesting -- out transient object finalization due to aliasing and nesting of
-- of constructs. Insert calls to [Deep_]Finalize after the innermost -- constructs. Insert calls to [Deep_]Finalize after the innermost
-- enclosing non-transient construct. -- enclosing non-transient construct.
else else
Fin_Context := Hook_Context; Fin_Context := Hook_Context;
end if; end if;
-- Step 1: Create the access type which provides a reference to the -- Mark the transient object as successfully processed to avoid double
-- transient controlled object. -- finalization.
if Is_Access_Type (Obj_Typ) then Set_Is_Finalized_Transient (Obj_Id);
Desig_Typ := Directly_Designated_Type (Obj_Typ);
else
Desig_Typ := Obj_Typ;
end if;
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: -- 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 : Ptr_Id := null;
Hook_Id := Make_Temporary (Loc, 'T'); Insert_Action (Hook_Context, Hook_Decl);
Insert_Action (Hook_Context, -- When the transient object is initialized by an aggregate, the hook
Make_Object_Declaration (Loc, -- must capture the object after the last aggregate assignment takes
Defining_Identifier => Hook_Id, -- place. Only then is the object considered initialized. Generate:
Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
-- Mark the hook as created for the purposes of exporting the transient -- Hook := Ptr_Typ (Obj_Id);
-- 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);
-- <or> -- <or>
-- Hook := Obj_Id'Unrestricted_Access; -- Hook := Obj_Id'Unrestricted_Access;
-- When the transient object is initialized by an aggregate, the hook if Ekind_In (Obj_Id, E_Constant, E_Variable)
-- 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)) and then Present (Last_Aggregate_Assignment (Obj_Id))
then then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id); Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
@ -13107,54 +13066,42 @@ package body Exp_Ch4 is
-- Otherwise the hook seizes the related object immediately -- Otherwise the hook seizes the related object immediately
else else
Hook_Insert := Decl; Hook_Insert := Obj_Decl;
end if; end if;
Insert_After_And_Analyze (Hook_Insert, Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Hook_Id, Loc),
Expression => Expr));
-- Step 4: Finalize the hook after the context has been evaluated or -- When the node is part of a return statement, there is no need to
-- elaborated. Generate: -- 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 -- if Hook /= null then
-- [Deep_]Finalize (Hook.all); -- [Deep_]Finalize (Hook.all);
-- Hook := null; -- Hook := null;
-- end if; -- 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 else
Insert_Action_After (Fin_Context, Insert_Action_After (Fin_Context,
Make_Implicit_If_Statement (Decl, Make_Implicit_If_Statement (Obj_Decl,
Condition => Condition =>
Make_Op_Ne (Loc, 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)), Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Final_Call Fin_Call,
(Obj_Ref => Hook_Clear)));
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)))));
end if; end if;
end Process_Transient_Object; end Process_Transient_In_Expression;
------------------------ ------------------------
-- Rewrite_Comparison -- -- 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)); and then Present (Generalized_Indexing (Ref));
end Is_Element_Reference; end Is_Element_Reference;
-- Local variables
Is_Elem_Ref : constant Boolean := Is_Element_Reference (N);
-- Start of processing for Expand_Ctrl_Function_Call -- Start of processing for Expand_Ctrl_Function_Call
begin begin
@ -4142,20 +4138,24 @@ package body Exp_Ch6 is
Remove_Side_Effects (N); Remove_Side_Effects (N);
-- When the temporary function result appears inside a case expression -- The side effect removal of the function call produced a temporary.
-- or an if expression, its lifetime must be extended to match that of -- When the context is a case expression, if expression, or expression
-- the context. If not, the function result will be finalized too early -- with actions, the lifetime of the temporary must be extended to match
-- and the evaluation of the expression could yield incorrect result. An -- that of the context. Otherwise the function result will be finalized
-- exception to this rule are references to Ada 2012 container elements. -- 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 -- Such references must be finalized at the end of each iteration of the
-- related quantified expression, otherwise the container will remain -- related quantified expression, otherwise the container will remain
-- busy. -- busy.
if not Is_Elem_Ref if Nkind (N) = N_Explicit_Dereference
and then Within_Case_Or_If_Expression (N) and then Within_Case_Or_If_Expression (N)
and then Nkind (N) = N_Explicit_Dereference and then not Is_Element_Reference (N)
then then
Set_Is_Processed_Transient (Entity (Prefix (N))); Set_Is_Ignored_Transient (Entity (Prefix (N)));
end if; end if;
end Expand_Ctrl_Function_Call; end Expand_Ctrl_Function_Call;

430
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 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null; null;
-- Transient variables are treated separately in order to -- Finalization of transient objects are treated separately in
-- minimize the size of the generated code. For details, see -- order to handle sensitive cases. These include:
-- Process_Transient_Objects.
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; null;
-- Ignored Ghost objects do not need any cleanup actions -- Ignored Ghost objects do not need any cleanup actions
@ -2139,8 +2147,8 @@ package body Exp_Ch7 is
then then
Processing_Actions (Has_No_Init => True); Processing_Actions (Has_No_Init => True);
-- Processing for "hook" objects generated for controlled -- Processing for "hook" objects generated for transient
-- transients declared inside an Expression_With_Actions. -- objects declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ) elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@ -2353,7 +2361,7 @@ package body Exp_Ch7 is
end if; end if;
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 -- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient -- in a block, but the block is not associated with a transient
-- scope. -- scope.
@ -3124,7 +3132,7 @@ package body Exp_Ch7 is
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then then
-- Temporaries created for the purpose of "exporting" a -- 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 -- need guards. The following illustrates the usage of such
-- temporaries. -- temporaries.
@ -6392,30 +6400,31 @@ package body Exp_Ch7 is
Act_Cleanup : constant List_Id := Act_Cleanup : constant List_Id :=
Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup); Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. -- 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. -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
procedure Process_Transient_Objects procedure Process_Transients_In_Scope
(First_Object : Node_Id; (First_Object : Node_Id;
Last_Object : Node_Id; Last_Object : Node_Id;
Related_Node : Node_Id); Related_Node : Node_Id);
-- First_Object and Last_Object define a list which contains potential -- Find all transient objects in the list First_Object .. Last_Object
-- controlled transient objects. Finalization flags are inserted before -- and generate finalization actions for them. Related_Node denotes the
-- First_Object and finalization calls are inserted after Last_Object. -- node which created all transient objects.
-- Related_Node is the node for which transient objects have been
-- created.
------------------------------- ---------------------------------
-- Process_Transient_Objects -- -- Process_Transients_In_Scope --
------------------------------- ---------------------------------
procedure Process_Transient_Objects procedure Process_Transients_In_Scope
(First_Object : Node_Id; (First_Object : Node_Id;
Last_Object : Node_Id; Last_Object : Node_Id;
Related_Node : Node_Id) Related_Node : Node_Id)
is is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Must_Hook : Boolean := False; 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. -- export to the outer finalizer.
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result; function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
@ -6424,6 +6433,15 @@ package body Exp_Ch7 is
procedure Detect_Subprogram_Call is procedure Detect_Subprogram_Call is
new Traverse_Proc (Is_Subprogram_Call); 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 -- -- Is_Subprogram_Call --
------------------------ ------------------------
@ -6466,32 +6484,149 @@ package body Exp_Ch7 is
end if; end if;
end Is_Subprogram_Call; 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 -- Local variables
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Built : Boolean := False; Built : Boolean := False;
Blk_Data : Finalization_Exception_Data;
Blk_Decl : Node_Id := Empty; Blk_Decl : Node_Id := Empty;
Blk_Decls : List_Id := No_List; Blk_Decls : List_Id := No_List;
Blk_Ins : Node_Id; Blk_Ins : Node_Id;
Blk_Stmts : List_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; Loc : Source_Ptr;
Obj_Decl : Node_Id; 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 begin
-- The expansion performed by this routine is as follows: -- 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); -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
-- end; -- end;
-- Abort_Undefer;
-- if Raised and not Abrt then -- if Raised and not Abrt then
-- Raise_From_Controlled_Operation (Ex); -- Raise_From_Controlled_Operation (Ex);
-- end if; -- end if;
-- Abort_Undefer_Direct;
-- end; -- end;
-- Recognize a scenario where the transient context is an object -- Recognize a scenario where the transient context is an object
@ -6554,8 +6689,8 @@ package body Exp_Ch7 is
-- Obj : ...; -- Obj : ...;
-- Res : ... := BIP_Func_Call (..., Obj, ...); -- Res : ... := BIP_Func_Call (..., Obj, ...);
-- The finalization of any controlled transient must happen after -- The finalization of any transient object must happen after the
-- the build-in-place function call is executed. -- build-in-place function call is executed.
if Nkind (N) = N_Object_Declaration if Nkind (N) = N_Object_Declaration
and then Present (BIP_Initialization_Call (Defining_Identifier (N))) and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
@ -6590,113 +6725,6 @@ package body Exp_Ch7 is
and then Obj_Decl /= Related_Node and then Obj_Decl /= Related_Node
then then
Loc := Sloc (Obj_Decl); 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;
-- Before generating the clean up code for the first transient -- Before generating the clean up code for the first transient
-- object, create a wrapper block which houses all hook clear -- object, create a wrapper block which houses all hook clear
@ -6707,25 +6735,14 @@ package body Exp_Ch7 is
Built := True; Built := True;
Blk_Stmts := New_List; Blk_Stmts := New_List;
-- Create the declarations of all entities that participate
-- in exception detection and propagation.
if Exceptions_OK then
Blk_Decls := New_List;
-- Generate: -- Generate:
-- Abrt : constant Boolean := ...; -- Abrt : constant Boolean := ...;
-- Ex : Exception_Occurrence; -- Ex : Exception_Occurrence;
-- Raised : Boolean := False; -- Raised : Boolean := False;
Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); if Exceptions_OK then
Blk_Decls := New_List;
-- Generate: Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
-- if Raised and then not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
end if; end if;
Blk_Decl := Blk_Decl :=
@ -6736,64 +6753,13 @@ package body Exp_Ch7 is
Statements => Blk_Stmts)); Statements => Blk_Stmts));
end if; end if;
-- Generate: -- Construct all necessary circuitry to hook and finalize a
-- [Deep_]Finalize (Obj_Ref); -- single transient object.
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); Process_Transient_In_Scope
(Obj_Decl => Obj_Decl,
if Is_Access_Type (Obj_Typ) then Blk_Data => Blk_Data,
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); Blk_Stmts => Blk_Stmts);
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;
end if; end if;
-- Terminate the scan after the last object has been processed to -- Terminate the scan after the last object has been processed to
@ -6806,12 +6772,15 @@ package body Exp_Ch7 is
Next (Obj_Decl); Next (Obj_Decl);
end loop; end loop;
-- Complete the decoration of the enclosing finalization block and
-- insert it into the tree.
if Present (Blk_Decl) then if Present (Blk_Decl) then
-- Note that the abort defer / undefer pair does not require an -- Note that this Abort_Undefer does not require a extra block or
-- extra block because each finalization exception is caught in -- an AT_END handler because each finalization exception is caught
-- its corresponding finalization block. As a result, the call to -- in its own corresponding finalization block. As a result, the
-- Abort_Defer always takes place. -- call to Abort_Defer always takes place.
if Abort_Allowed then if Abort_Allowed then
Prepend_To (Blk_Stmts, Prepend_To (Blk_Stmts,
@ -6821,9 +6790,18 @@ package body Exp_Ch7 is
Build_Runtime_Call (Loc, RE_Abort_Undefer)); Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if; 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); Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if; end if;
end Process_Transient_Objects; end Process_Transients_In_Scope;
-- Local variables -- Local variables
@ -6901,10 +6879,10 @@ package body Exp_Ch7 is
(Last_Obj, Build_SS_Release_Call (Loc, Mark_Id)); (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
end if; end if;
-- Check for transient controlled objects associated with Target and -- Check for transient objects associated with Target and generate the
-- generate the appropriate finalization actions for them. -- appropriate finalization actions for them.
Process_Transient_Objects Process_Transients_In_Scope
(First_Object => First_Obj, (First_Object => First_Obj,
Last_Object => Last_Obj, Last_Object => Last_Obj,
Related_Node => Target); 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); return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image; 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 -- -- Check_Float_Op_Overflow --
----------------------------- -----------------------------
@ -5067,7 +5194,7 @@ package body Exp_Util is
-- explicit aliases of it: -- explicit aliases of it:
-- do -- do
-- Trans_Id : Ctrl_Typ ...; -- controlled transient object -- Trans_Id : Ctrl_Typ ...; -- transient object
-- Alias : ... := Trans_Id; -- object is aliased -- Alias : ... := Trans_Id; -- object is aliased
-- Val : constant Boolean := -- Val : constant Boolean :=
-- ... Alias ...; -- aliasing ends -- ... Alias ...; -- aliasing ends
@ -5236,6 +5363,10 @@ package body Exp_Util is
and then Requires_Transient_Scope (Desig) and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement 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 -- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime. -- 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 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null; null;
-- Transient variables are treated separately in order to minimize -- Finalization of transient objects are treated separately in
-- the size of the generated code. See Exp_Ch7.Process_Transient_ -- order to handle sensitive cases. These include:
-- Objects.
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; null;
-- Ignored Ghost objects do not need any cleanup actions because -- Ignored Ghost objects do not need any cleanup actions because
@ -8315,8 +8454,8 @@ package body Exp_Util is
then then
return True; return True;
-- Processing for "hook" objects generated for controlled -- Processing for "hook" objects generated for transient objects
-- transients declared inside an Expression_With_Actions. -- declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ) elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) 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 elsif Nkind (Decl) = N_Block_Statement
and then 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 -- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient -- in a block, but the block is not associated with a transient
-- scope. -- 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 -- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups. -- 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); procedure Check_Float_Op_Overflow (N : Node_Id);
-- Called where we could have a floating-point binary operator where we -- Called where we could have a floating-point binary operator where we
-- must check for infinities if we are operating in Check_Float_Overflow -- must check for infinities if we are operating in Check_Float_Overflow

656
gcc/ada/sem_aggr.adb
View File

@ -2941,25 +2941,9 @@ package body Sem_Aggr is
------------------------------ ------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) 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_List : constant List_Id := New_List;
New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association -- New_Assoc_List is the newly built list of N_Component_Association
-- nodes. New_Assoc is one such N_Component_Association node in it. -- nodes.
-- 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.
Others_Etype : Entity_Id := Empty; Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component -- 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; Box_Node : Node_Id;
Is_Box_Present : Boolean := False; Is_Box_Present : Boolean := False;
Others_Box : Integer := 0; Others_Box : Integer := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization -- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present -- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization; -- 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- -- (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. -- initialized. A value of One indicates that an others_box is present.
-- Any larger value indicates that the others_box is not redundant. -- Any larger value indicates that the others_box is not redundant.
-- These variables, similar to Others_Etype, are also updated as a -- These variables, similar to Others_Etype, are also updated as a side
-- side effect of function Get_Value. -- effect of function Get_Value. Box_Node is used to place a warning on
-- Box_Node is used to place a warning on a redundant others_box. -- a redundant others_box.
procedure Add_Association procedure Add_Association
(Component : Entity_Id; (Component : Entity_Id;
@ -2997,14 +2980,23 @@ package body Sem_Aggr is
-- either New_Assoc_List, or the association being built for an inner -- either New_Assoc_List, or the association being built for an inner
-- aggregate. -- 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. -- If aggregate N is a regular aggregate this routine will return True.
-- Otherwise, if N is an extension aggregate, Discr is a discriminant -- Otherwise, if N is an extension aggregate, then Input_Discr denotes
-- whose value may already have been specified by N's ancestor part. -- a discriminant whose value may already have been specified by N's
-- This routine checks whether this is indeed the case and if so returns -- ancestor part. This routine checks whether this is indeed the case
-- False, signaling that no value for Discr should appear in N's -- and if so returns False, signaling that no value for Input_Discr
-- aggregate part. Also, in this case, the routine appends to -- should appear in N's aggregate part. Also, in this case, the routine
-- New_Assoc_List the discriminant value specified in the ancestor part. -- 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 -- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed. The inherited discriminant values must not be reinserted -- 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. -- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion. -- 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 function Get_Value
(Compon : Node_Id; (Compon : Node_Id;
From : List_Id; From : List_Id;
Consider_Others_Choice : Boolean := False) Consider_Others_Choice : Boolean := False) return Node_Id;
return Node_Id;
-- Given a record component stored in parameter Compon, this function -- Given a record component stored in parameter Compon, this function
-- returns its value as it appears in the list From, which is a list -- returns its value as it appears in the list From, which is a list
-- of N_Component_Association nodes. -- 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 -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node. -- 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 -- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr. -- Component. This routine also applies all appropriate checks to Expr.
-- It finally saves a Expr in the newly created association list that -- 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; Assoc_List : List_Id;
Is_Box_Present : Boolean := False) Is_Box_Present : Boolean := False)
is is
Loc : Source_Ptr;
Choice_List : constant List_Id := New_List; Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id; Loc : Source_Ptr;
begin begin
-- If this is a box association the expression is missing, so -- If this is a box association the expression is missing, so use the
-- use the Sloc of the aggregate itself for the new association. -- Sloc of the aggregate itself for the new association.
if Present (Expr) then if Present (Expr) then
Loc := Sloc (Expr); Loc := Sloc (Expr);
@ -3073,34 +3076,97 @@ package body Sem_Aggr is
Loc := Sloc (N); Loc := Sloc (N);
end if; end if;
Append (New_Occurrence_Of (Component, Loc), Choice_List); Append_To (Choice_List, New_Occurrence_Of (Component, Loc));
New_Assoc :=
Append_To (Assoc_List,
Make_Component_Association (Loc, Make_Component_Association (Loc,
Choices => Choice_List, Choices => Choice_List,
Expression => Expr, Expression => Expr,
Box_Present => Is_Box_Present); Box_Present => Is_Box_Present));
Append (New_Assoc, Assoc_List);
end Add_Association; 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; Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
Ancestor_Is_Subtyp : Boolean;
Loc : Source_Ptr; Loc : Source_Ptr;
Ancestor : Node_Id; Ancestor : Node_Id;
Comp_Assoc : Node_Id;
Discr_Expr : Node_Id;
Ancestor_Typ : Entity_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; Orig_Discr : Entity_Id;
D : Entity_Id;
D_Val : Elmt_Id := No_Elmt; -- stop junk warning
Ancestor_Is_Subtyp : Boolean;
begin begin
if Regular_Aggr then 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 -- Now look to see if Discr was specified in the ancestor part
if Ancestor_Is_Subtyp then if Ancestor_Is_Subtyp then
D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor))); Discr_Val :=
First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if; end if;
Orig_Discr := Original_Record_Component (Discr); Orig_Discr := Original_Record_Component (Input_Discr);
D := First_Discriminant (Ancestor_Typ); Discr := First_Discriminant (Ancestor_Typ);
while Present (D) loop while Present (Discr) loop
-- If Ancestor has already specified Disc value then insert its -- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate. -- 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 if Ancestor_Is_Subtyp then
Discr_Expr := New_Copy_Tree (Node (D_Val)); Discr_Expr := New_Copy_Tree (Node (Discr_Val));
else else
Discr_Expr := Discr_Expr :=
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor), Prefix => Duplicate_Subexpr (Ancestor),
Selector_Name => New_Occurrence_Of (Discr, Loc)); Selector_Name => New_Occurrence_Of (Input_Discr, Loc));
end if; end if;
Resolve_Aggr_Expr (Discr_Expr, Discr); Resolve_Aggr_Expr (Discr_Expr, Input_Discr);
Set_Inherited_Discriminant (Last (New_Assoc_List)); Set_Inherited_Discriminant (Last (New_Assoc_List));
return False; return False;
end if; end if;
Next_Discriminant (D); Next_Discriminant (Discr);
if Ancestor_Is_Subtyp then if Ancestor_Is_Subtyp then
Next_Elmt (D_Val); Next_Elmt (Discr_Val);
end if; end if;
end loop; end loop;
return True; 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 -- -- Get_Value --
@ -3200,8 +3291,7 @@ package body Sem_Aggr is
function Get_Value function Get_Value
(Compon : Node_Id; (Compon : Node_Id;
From : List_Id; From : List_Id;
Consider_Others_Choice : Boolean := False) Consider_Others_Choice : Boolean := False) return Node_Id
return Node_Id
is is
Typ : constant Entity_Id := Etype (Compon); Typ : constant Entity_Id := Etype (Compon);
Assoc : Node_Id; Assoc : Node_Id;
@ -3266,14 +3356,14 @@ package body Sem_Aggr is
null; null;
else else
Error_Msg_N Error_Msg_N
("components in OTHERS choice must " ("components in OTHERS choice must have same "
& "have same type", Selector_Name); & "type", Selector_Name);
end if; end if;
end if; end if;
Others_Etype := Typ; 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 -- independently for each component, This is needed
-- for accessibility checks on compoents of anonymous -- for accessibility checks on compoents of anonymous
-- access types, even in compile_only mode. -- access types, even in compile_only mode.
@ -3414,11 +3504,110 @@ package body Sem_Aggr is
return New_Copy; return New_Copy;
end New_Copy_Tree_And_Copy_Dimensions; 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 -- -- 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; function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its -- If the expression is an aggregate (possibly qualified) then its
-- expansion is delayed until the enclosing aggregate is expanded -- expansion is delayed until the enclosing aggregate is expanded
@ -3433,13 +3622,14 @@ package body Sem_Aggr is
--------------------------- ---------------------------
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Expr);
begin begin
return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) return
(Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
and then Present (Etype (Expr)) and then Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr)) and then Is_Record_Type (Etype (Expr))
and then Expansion_Delayed (Expr)) and then Expansion_Delayed (Expr))
or else (Kind = N_Qualified_Expression or else
(Nkind (Expr) = N_Qualified_Expression
and then Has_Expansion_Delayed (Expression (Expr))); and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed; end Has_Expansion_Delayed;
@ -3580,6 +3770,8 @@ package body Sem_Aggr is
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed); Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if; end if;
-- Add association Component => Expr if the caller requests it
if Relocate then if Relocate then
New_Expr := Relocate_Node (Expr); New_Expr := Relocate_Node (Expr);
@ -3595,6 +3787,17 @@ package body Sem_Aggr is
Add_Association (New_C, New_Expr, New_Assoc_List); Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr; 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 -- Start of processing for Resolve_Record_Aggregate
begin begin
@ -3607,7 +3810,6 @@ package body Sem_Aggr is
if Present (Component_Associations (N)) if Present (Component_Associations (N))
and then Present (First (Component_Associations (N))) and then Present (First (Component_Associations (N)))
then then
if Present (Expressions (N)) then if Present (Expressions (N)) then
Check_SPARK_05_Restriction Check_SPARK_05_Restriction
("named association cannot follow positional one", ("named association cannot follow positional one",
@ -3678,8 +3880,9 @@ package body Sem_Aggr is
-- STEP 2: Verify aggregate structure -- STEP 2: Verify aggregate structure
Step_2 : declare Step_2 : declare
Selector_Name : Node_Id; Assoc : Node_Id;
Bad_Aggregate : Boolean := False; Bad_Aggregate : Boolean := False;
Selector_Name : Node_Id;
begin begin
if Present (Component_Associations (N)) then if Present (Component_Associations (N)) then
@ -3774,7 +3977,7 @@ package body Sem_Aggr is
-- First find the discriminant values in the positional components -- First find the discriminant values in the positional components
while Present (Discrim) and then Present (Positional_Expr) loop 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); Resolve_Aggr_Expr (Positional_Expr, Discrim);
-- Ada 2005 (AI-231) -- Ada 2005 (AI-231)
@ -3802,7 +4005,7 @@ package body Sem_Aggr is
while Present (Discrim) loop while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True); Expr := Get_Value (Discrim, Component_Associations (N), True);
if not Discr_Present (Discrim) then if not Discriminant_Present (Discrim) then
if Present (Expr) then if Present (Expr) then
Error_Msg_NE Error_Msg_NE
("more than one value supplied for discriminant &", ("more than one value supplied for discriminant &",
@ -3850,17 +4053,17 @@ package body Sem_Aggr is
and then Present (Underlying_Record_View (Typ))) and then Present (Underlying_Record_View (Typ)))
then then
Build_Constrained_Itype : declare Build_Constrained_Itype : declare
Constrs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Indic : Node_Id;
Subtyp_Decl : Node_Id;
Def_Id : Entity_Id; Def_Id : Entity_Id;
Indic : Node_Id;
C : constant List_Id := New_List; New_Assoc : Node_Id;
Subtyp_Decl : Node_Id;
begin begin
New_Assoc := First (New_Assoc_List); New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop while Present (New_Assoc) loop
Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C); Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
Next (New_Assoc); Next (New_Assoc);
end loop; end loop;
@ -3872,14 +4075,16 @@ package body Sem_Aggr is
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc), New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C)); Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constrs));
else else
Indic := Indic :=
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc), New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C)); Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constrs));
end if; end if;
Def_Id := Create_Itype (Ekind (Typ), N); 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: Get remaining components according to discriminant values
Step_5 : declare Step_5 : declare
Dnode : Node_Id;
Errors_Found : Boolean := False;
Record_Def : Node_Id; Record_Def : Node_Id;
Parent_Typ : Entity_Id; Parent_Typ : Entity_Id;
Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id; Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id; Parent_Elmt : Elmt_Id;
Errors_Found : Boolean := False; Root_Typ : Entity_Id;
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
begin begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then 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))); Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else else
-- AI05-0115: check legality of aggregate for type with -- AI05-0115: check legality of aggregate for type with a
-- aa private ancestor. -- private ancestor.
Root_Typ := Root_Type (Typ); Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then if Has_Private_Ancestor (Typ) then
declare declare
Ancestor : constant Entity_Id := Ancestor : constant Entity_Id :=
Find_Private_Ancestor; Find_Private_Ancestor (Typ);
Ancestor_Unit : constant Entity_Id := Ancestor_Unit : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
Cunit_Entity Cunit_Entity
(Get_Source_Unit (Base_Type (Etype (Ancestor)))); (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit
(Base_Type (Etype (Ancestor))));
begin begin
-- Check whether we are in a scope that has full view -- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can -- over the private ancestor and its parent. This can
@ -4189,8 +4363,7 @@ package body Sem_Aggr is
-- object of the aggregate. -- object of the aggregate.
if Present (Parent (Component)) if Present (Parent (Component))
and then and then Nkind (Parent (Component)) = N_Component_Declaration
Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component))) and then Present (Expression (Parent (Component)))
then then
Expr := Expr :=
@ -4213,19 +4386,11 @@ package body Sem_Aggr is
elsif Present (Underlying_Type (Ctyp)) elsif Present (Underlying_Type (Ctyp))
and then Is_Access_Type (Underlying_Type (Ctyp)) and then Is_Access_Type (Underlying_Type (Ctyp))
then 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 -- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked -- its underlying type then we have to create an unchecked
-- conversion to satisfy type checking. -- conversion to satisfy type checking.
else if Is_Private_Type (Ctyp) then
declare declare
Qual_Null : constant Node_Id := Qual_Null : constant Node_Id :=
Make_Qualified_Expression (Sloc (N), Make_Qualified_Expression (Sloc (N),
@ -4245,6 +4410,17 @@ package body Sem_Aggr is
Expr => Convert_Null, Expr => Convert_Null,
Assoc_List => New_Assoc_List); Assoc_List => New_Assoc_List);
end; 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; end if;
-- Ada 2012: If component is scalar with default value, use it -- Ada 2012: If component is scalar with default value, use it
@ -4254,7 +4430,8 @@ package body Sem_Aggr is
then then
Add_Association Add_Association
(Component => Component, (Component => Component,
Expr => Default_Aspect_Value Expr =>
Default_Aspect_Value
(First_Subtype (Underlying_Type (Ctyp))), (First_Subtype (Underlying_Type (Ctyp))),
Assoc_List => New_Assoc_List); Assoc_List => New_Assoc_List);
@ -4270,8 +4447,8 @@ package body Sem_Aggr is
-- for the rest, if other components are present. -- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of -- The type of the aggregate is the known subtype of
-- the component. The capture of discriminants must -- the component. The capture of discriminants must be
-- be recursive because subcomponents may be constrained -- recursive because subcomponents may be constrained
-- (transitively) by discriminants of enclosing types. -- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the -- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no -- initialization procedure will be generated, and no
@ -4281,206 +4458,6 @@ package body Sem_Aggr is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id; 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 begin
Expr := Make_Aggregate (Loc, New_List, New_List); Expr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (Expr, Ctyp); Set_Etype (Expr, Ctyp);
@ -4523,6 +4500,7 @@ package body Sem_Aggr is
Expression => Empty, Expression => Empty,
Box_Present => True)); Box_Present => True));
end if; end if;
exit; exit;
end if; end if;
@ -4537,6 +4515,9 @@ package body Sem_Aggr is
Assoc_List => New_Assoc_List); Assoc_List => New_Assoc_List);
end Capture_Discriminants; end Capture_Discriminants;
-- Otherwise the component type is not a record, or it has
-- not discriminants, or it is private.
else else
Add_Association Add_Association
(Component => Component, (Component => Component,
@ -4576,6 +4557,9 @@ package body Sem_Aggr is
-- STEP 7: check for invalid components + check type in choice list -- STEP 7: check for invalid components + check type in choice list
Step_7 : declare Step_7 : declare
Assoc : Node_Id;
New_Assoc : Node_Id;
Selectr : Node_Id; Selectr : Node_Id;
-- Selector name -- Selector name

18
gcc/ada/sem_ch3.adb
View File

@ -4802,6 +4802,24 @@ package body Sem_Ch3 is
then then
Set_Has_Predicates (Id); Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (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; end if;
-- Subtype of Boolean cannot have a constraint in SPARK -- 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 begin
-- Ensure all actions associated with the left operand (e.g. -- Ensure all actions associated with the left operand (e.g.
-- finalization of transient controlled objects) are fully evaluated -- finalization of transient objects) are fully evaluated locally within
-- locally within an expression with actions. This is particularly -- an expression with actions. This is particularly helpful for coverage
-- helpful for coverage analysis. However this should not happen in -- analysis. However this should not happen in generics or if option
-- generics or if Minimize_Expression_With_Actions is set. -- Minimize_Expression_With_Actions is set.
if Expander_Active and not Minimize_Expression_With_Actions then if Expander_Active and not Minimize_Expression_With_Actions then
declare declare