From 937e96763e42c48c29e3a5edf2eea3fb2c59fb27 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Jul 2016 14:37:54 +0200 Subject: [PATCH] [multiple changes] 2016-07-06 Hristian Kirtchev * 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 * 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 --- gcc/ada/ChangeLog | 62 ++ gcc/ada/einfo.adb | 43 +- gcc/ada/einfo.ads | 40 +- gcc/ada/exp_aggr.adb | 1565 ++++++++++++++++++++++++++++-------------- gcc/ada/exp_ch4.adb | 251 +++---- gcc/ada/exp_ch6.adb | 24 +- gcc/ada/exp_ch7.adb | 436 ++++++------ gcc/ada/exp_util.adb | 155 ++++- gcc/ada/exp_util.ads | 29 + gcc/ada/sem_aggr.adb | 672 +++++++++--------- gcc/ada/sem_ch3.adb | 18 + gcc/ada/sem_res.adb | 8 +- 12 files changed, 2022 insertions(+), 1281 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c52781752d1..be8759c4274 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,65 @@ +2016-07-06 Hristian Kirtchev + + * 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 + + * 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 * exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ae4a3bb2c6e..1748efd0b66 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -561,7 +561,7 @@ package body Einfo is -- Has_Predicates Flag250 -- Has_Implicit_Dereference Flag251 - -- Is_Processed_Transient Flag252 + -- Is_Finalized_Transient Flag252 -- Disable_Controlled Flag253 -- Is_Implementation_Defined Flag254 -- Is_Predicate_Function Flag255 @@ -609,8 +609,8 @@ package body Einfo is -- Is_Partial_Invariant_Procedure Flag292 -- Is_Actual_Subtype Flag293 -- Has_Pragma_Unused Flag294 + -- Is_Ignored_Transient Flag295 - -- (unused) Flag295 -- (unused) Flag296 -- (unused) Flag297 -- (unused) Flag298 @@ -2185,6 +2185,12 @@ package body Einfo is return Flag99 (Id); end Is_Exported; + function Is_Finalized_Transient (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + return Flag252 (Id); + end Is_Finalized_Transient; + function Is_First_Subtype (Id : E) return B is begin return Flag70 (Id); @@ -2250,6 +2256,12 @@ package body Einfo is return Flag278 (Id); end Is_Ignored_Ghost_Entity; + function Is_Ignored_Transient (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + return Flag295 (Id); + end Is_Ignored_Transient; + function Is_Immediately_Visible (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2466,12 +2478,6 @@ package body Einfo is return Flag245 (Id); end Is_Private_Primitive; - function Is_Processed_Transient (Id : E) return B is - begin - pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); - return Flag252 (Id); - end Is_Processed_Transient; - function Is_Public (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -5248,6 +5254,12 @@ package body Einfo is Set_Flag99 (Id, V); end Set_Is_Exported; + procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + Set_Flag252 (Id, V); + end Set_Is_Finalized_Transient; + procedure Set_Is_First_Subtype (Id : E; V : B := True) is begin Set_Flag70 (Id, V); @@ -5329,6 +5341,12 @@ package body Einfo is Set_Flag278 (Id, V); end Set_Is_Ignored_Ghost_Entity; + procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); + Set_Flag295 (Id, V); + end Set_Is_Ignored_Transient; + procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -5543,12 +5561,6 @@ package body Einfo is Set_Flag245 (Id, V); end Set_Is_Private_Primitive; - procedure Set_Is_Processed_Transient (Id : E; V : B := True) is - begin - pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); - Set_Flag252 (Id, V); - end Set_Is_Processed_Transient; - procedure Set_Is_Public (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -9241,6 +9253,7 @@ package body Einfo is W ("Is_Entry_Formal", Flag52 (Id)); W ("Is_Exception_Handler", Flag286 (Id)); W ("Is_Exported", Flag99 (Id)); + W ("Is_Finalized_Transient", Flag252 (Id)); W ("Is_First_Subtype", Flag70 (Id)); W ("Is_For_Access_Subtype", Flag118 (Id)); W ("Is_Formal_Subprogram", Flag111 (Id)); @@ -9253,6 +9266,7 @@ package body Einfo is W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id)); W ("Is_Hidden_Open_Scope", Flag171 (Id)); W ("Is_Ignored_Ghost_Entity", Flag278 (Id)); + W ("Is_Ignored_Transient", Flag295 (Id)); W ("Is_Immediately_Visible", Flag7 (Id)); W ("Is_Implementation_Defined", Flag254 (Id)); W ("Is_Imported", Flag24 (Id)); @@ -9292,7 +9306,6 @@ package body Einfo is W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Primitive", Flag245 (Id)); - W ("Is_Processed_Transient", Flag252 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e2a8d6115f1..ec065a91a02 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -535,7 +535,7 @@ package Einfo is -- a build-in-place function call. Contains the relocated build-in-place -- call after the expansion has decoupled the call from the object. This -- attribute is used by the finalization machinery to insert cleanup code --- for all additional transient variables found in the transient block. +-- for all additional transient objects found in the transient block. -- C_Pass_By_Copy (Flag125) [implementation base type only] -- Defined in record types. Set if a pragma Convention for the record @@ -2484,6 +2484,12 @@ package Einfo is -- Applies to all entities, true for abstract states that are subject to -- option External. +-- Is_Finalized_Transient (Flag252) +-- Defined in constants, loop parameters of generalized iterators, and +-- variables. Set when a transient object has been finalized by one of +-- the transient finalization mechanisms. The flag prevents the double +-- finalization of the object. + -- Is_Finalizer (synthesized) -- Applies to all entities, true for procedures containing finalization -- code to process local or library level objects. @@ -2595,6 +2601,13 @@ package Einfo is -- pragma Ghost or inherit "ghostness" from an enclosing construct, and -- subject to Assertion_Policy Ghost => Ignore. +-- Is_Ignored_Transient (Flag295) +-- Defined in constants, loop parameters of generalized iterators, and +-- variables. Set when a transient object must be processed by one of +-- the transient finalization mechanisms. Once marked, a transient is +-- intentionally ignored by the general finalization mechanism because +-- its clean up actions are context specific. + -- Is_Immediately_Visible (Flag7) -- Defined in all entities. Set if entity is immediately visible, i.e. -- is defined in some currently open scope (RM 8.3(4)). @@ -2997,13 +3010,6 @@ package Einfo is -- Applies to all entities, true for private types and subtypes, -- as well as for record with private types as subtypes. --- Is_Processed_Transient (Flag252) --- Defined in variables, loop parameters, and constants, including the --- loop parameters of generalized iterators. Set when a transient object --- needs to be finalized and has already been processed by the transient --- scope machinery. This flag signals the general finalization mechanism --- to ignore the transient object. - -- Is_Protected_Component (synthesized) -- Applicable to all entities, true if the entity denotes a private -- component of a protected type. @@ -5786,8 +5792,9 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Finalized_Transient (Flag252) + -- Is_Ignored_Transient (Flag295) -- Is_Independent (Flag268) - -- Is_Processed_Transient (Flag252) (constants only) -- Is_Return_Object (Flag209) -- Is_True_Constant (Flag163) -- Is_Uplevel_Referenced_Entity (Flag283) @@ -6552,8 +6559,9 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Finalized_Transient (Flag252) + -- Is_Ignored_Transient (Flag295) -- Is_Independent (Flag268) - -- Is_Processed_Transient (Flag252) -- Is_Return_Object (Flag209) -- Is_Safe_To_Reevaluate (Flag249) -- Is_Shared_Passive (Flag60) @@ -7062,6 +7070,7 @@ package Einfo is function Is_Entry_Formal (Id : E) return B; function Is_Exception_Handler (Id : E) return B; function Is_Exported (Id : E) return B; + function Is_Finalized_Transient (Id : E) return B; function Is_First_Subtype (Id : E) return B; function Is_For_Access_Subtype (Id : E) return B; function Is_Frozen (Id : E) return B; @@ -7070,6 +7079,7 @@ package Einfo is function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B; function Is_Hidden_Open_Scope (Id : E) return B; function Is_Ignored_Ghost_Entity (Id : E) return B; + function Is_Ignored_Transient (Id : E) return B; function Is_Immediately_Visible (Id : E) return B; function Is_Implementation_Defined (Id : E) return B; function Is_Imported (Id : E) return B; @@ -7108,7 +7118,6 @@ package Einfo is function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; function Is_Private_Primitive (Id : E) return B; - function Is_Processed_Transient (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; @@ -7736,6 +7745,7 @@ package Einfo is procedure Set_Is_Entry_Formal (Id : E; V : B := True); procedure Set_Is_Exception_Handler (Id : E; V : B := True); procedure Set_Is_Exported (Id : E; V : B := True); + procedure Set_Is_Finalized_Transient (Id : E; V : B := True); procedure Set_Is_First_Subtype (Id : E; V : B := True); procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); @@ -7748,6 +7758,7 @@ package Einfo is procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True); procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True); + procedure Set_Is_Ignored_Transient (Id : E; V : B := True); procedure Set_Is_Immediately_Visible (Id : E; V : B := True); procedure Set_Is_Implementation_Defined (Id : E; V : B := True); procedure Set_Is_Imported (Id : E; V : B := True); @@ -7787,7 +7798,6 @@ package Einfo is procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Private_Primitive (Id : E; V : B := True); - procedure Set_Is_Processed_Transient (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); @@ -8544,6 +8554,7 @@ package Einfo is pragma Inline (Is_Enumeration_Type); pragma Inline (Is_Exception_Handler); pragma Inline (Is_Exported); + pragma Inline (Is_Finalized_Transient); pragma Inline (Is_First_Subtype); pragma Inline (Is_Fixed_Point_Type); pragma Inline (Is_Floating_Point_Type); @@ -8563,6 +8574,7 @@ package Einfo is pragma Inline (Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Is_Hidden_Open_Scope); pragma Inline (Is_Ignored_Ghost_Entity); + pragma Inline (Is_Ignored_Transient); pragma Inline (Is_Immediately_Visible); pragma Inline (Is_Implementation_Defined); pragma Inline (Is_Imported); @@ -8612,7 +8624,6 @@ package Einfo is pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Type); - pragma Inline (Is_Processed_Transient); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); @@ -9039,6 +9050,7 @@ package Einfo is pragma Inline (Set_Is_Entry_Formal); pragma Inline (Set_Is_Exception_Handler); pragma Inline (Set_Is_Exported); + pragma Inline (Set_Is_Finalized_Transient); pragma Inline (Set_Is_First_Subtype); pragma Inline (Set_Is_For_Access_Subtype); pragma Inline (Set_Is_Formal_Subprogram); @@ -9051,6 +9063,7 @@ package Einfo is pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Set_Is_Hidden_Open_Scope); pragma Inline (Set_Is_Ignored_Ghost_Entity); + pragma Inline (Set_Is_Ignored_Transient); pragma Inline (Set_Is_Immediately_Visible); pragma Inline (Set_Is_Implementation_Defined); pragma Inline (Set_Is_Imported); @@ -9090,7 +9103,6 @@ package Einfo is pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Primitive); - pragma Inline (Set_Is_Processed_Transient); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index f40b56d718e..7d1db3e4987 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -35,10 +35,12 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; +with Exp_Ch11; use Exp_Ch11; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Fname; use Fname; with Freeze; use Freeze; +with Inline; use Inline; with Itypes; use Itypes; with Lib; use Lib; with Namet; use Namet; @@ -95,6 +97,25 @@ package body Exp_Aggr is -- Returns true if N is an aggregate used to initialize the components -- of a statically allocated dispatch table. + function Late_Expansion + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id) return List_Id; + -- This routine implements top-down expansion of nested aggregates. In + -- doing so, it avoids the generation of temporaries at each level. N is + -- a nested record or array aggregate with the Expansion_Delayed flag. + -- Typ is the expected type of the aggregate. Target is a (duplicatable) + -- expression that will hold the result of the aggregate expansion. + + function Make_OK_Assignment_Statement + (Sloc : Source_Ptr; + Name : Node_Id; + Expression : Node_Id) return Node_Id; + -- This is like Make_Assignment_Statement, except that Assignment_OK + -- is set in the left operand. All assignments built by this unit use + -- this routine. This is needed to deal with assignments to initialized + -- constants that are done in place. + function Must_Slide (Obj_Type : Entity_Id; Typ : Entity_Id) return Boolean; @@ -109,6 +130,41 @@ package body Exp_Aggr is -- when a component may be given with bounds that differ from those of the -- component type. + function Number_Of_Choices (N : Node_Id) return Nat; + -- Returns the number of discrete choices (not including the others choice + -- if present) contained in (sub-)aggregate N. + + procedure Process_Transient_Component + (Loc : Source_Ptr; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Fin_Call : out Node_Id; + Hook_Clear : out Node_Id; + Aggr : Node_Id := Empty; + Stmts : List_Id := No_List); + -- Subsidiary to the expansion of array and record aggregates. Generate + -- part of the necessary code to finalize a transient component. Comp_Typ + -- is the component type. Init_Expr is the initialization expression of the + -- component which is always a function call. Fin_Call is the finalization + -- call used to clean up the transient function result. Hook_Clear is the + -- hook reset statement. Aggr and Stmts both control the placement of the + -- generated code. Aggr is the related aggregate. If present, all code is + -- inserted prior to Aggr using Insert_Action. Stmts is the initialization + -- statements of the component. If present, all code is added to Stmts. + + procedure Process_Transient_Component_Completion + (Loc : Source_Ptr; + Aggr : Node_Id; + Fin_Call : Node_Id; + Hook_Clear : Node_Id; + Stmts : List_Id); + -- Subsidiary to the expansion of array and record aggregates. Generate + -- part of the necessary code to finalize a transient component. Aggr is + -- the related aggregate. Fin_Clear is the finalization call used to clean + -- up the transient component. Hook_Clear is the hook reset statment. Stmts + -- is the initialization statement list for the component. All generated + -- code is added to Stmts. + procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); -- Sort the Case Table using the Lower Bound of each Choice as the key. -- A simple insertion sort is used since the number of choices in a case @@ -260,29 +316,6 @@ package body Exp_Aggr is -- an array that is suitable for this optimization: it returns True if Typ -- is a two dimensional bit packed array with component size 1, 2, or 4. - function Late_Expansion - (N : Node_Id; - Typ : Entity_Id; - Target : Node_Id) return List_Id; - -- This routine implements top-down expansion of nested aggregates. In - -- doing so, it avoids the generation of temporaries at each level. N is - -- a nested record or array aggregate with the Expansion_Delayed flag. - -- Typ is the expected type of the aggregate. Target is a (duplicatable) - -- expression that will hold the result of the aggregate expansion. - - function Make_OK_Assignment_Statement - (Sloc : Source_Ptr; - Name : Node_Id; - Expression : Node_Id) return Node_Id; - -- This is like Make_Assignment_Statement, except that Assignment_OK - -- is set in the left operand. All assignments built by this unit use - -- this routine. This is needed to deal with assignments to initialized - -- constants that are done in place. - - function Number_Of_Choices (N : Node_Id) return Nat; - -- Returns the number of discrete choices (not including the others choice - -- if present) contained in (sub-)aggregate N. - function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean; -- Given an array aggregate, this function handles the case of a packed -- array aggregate with all constant values, where the aggregate can be @@ -794,14 +827,18 @@ package body Exp_Aggr is function Index_Base_Name return Node_Id; -- Returns a new reference to the index type name - function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id; + function Gen_Assign + (Ind : Node_Id; + Expr : Node_Id; + In_Loop : Boolean := False) return List_Id; -- Ind must be a side-effect-free expression. If the input aggregate N -- to Build_Loop contains no subaggregates, then this function returns -- the assignment statement: -- -- Into (Indexes, Ind) := Expr; -- - -- Otherwise we call Build_Code recursively + -- Otherwise we call Build_Code recursively. Flag In_Loop should be set + -- when the assignment appears within a generated loop. -- -- Ada 2005 (AI-287): In case of default initialized component, Expr -- is empty and we generate a call to the corresponding IP subprogram. @@ -815,9 +852,9 @@ package body Exp_Aggr is -- Into (Indexes, J) := Expr; -- end loop; -- - -- Otherwise we call Build_Code recursively. - -- As an optimization if the loop covers 3 or fewer scalar elements we - -- generate a sequence of assignments. + -- Otherwise we call Build_Code recursively. As an optimization if the + -- loop covers 3 or fewer scalar elements we generate a sequence of + -- assignments. function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id; -- Nodes L and H must be side-effect-free expressions. If the input @@ -1016,20 +1053,36 @@ package body Exp_Aggr is -- Gen_Assign -- ---------------- - function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is + function Gen_Assign + (Ind : Node_Id; + Expr : Node_Id; + In_Loop : Boolean := False) return List_Id + is function Add_Loop_Actions (Lis : List_Id) return List_Id; - -- Collect insert_actions generated in the construction of a - -- loop, and prepend them to the sequence of assignments to - -- complete the eventual body of the loop. - - function Ctrl_Init_Expression - (Comp_Typ : Entity_Id; - Stmts : List_Id) return Node_Id; - -- Perform in-place side effect removal if expression Expr denotes a - -- controlled function call. Return a reference to the entity which - -- captures the result of the call. Comp_Typ is the expected type of - -- the component. Stmts is the list of initialization statmenets. Any - -- generated code is added to Stmts. + -- Collect insert_actions generated in the construction of a loop, + -- and prepend them to the sequence of assignments to complete the + -- eventual body of the loop. + + procedure Initialize_Array_Component + (Arr_Comp : Node_Id; + Comp_Typ : Node_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of array component Arr_Comp with + -- expected type Comp_Typ. Init_Expr denotes the initialization + -- expression of the array component. All generated code is added + -- to list Stmts. + + procedure Initialize_Ctrl_Array_Component + (Arr_Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of array component Arr_Comp when its + -- expected type Comp_Typ needs finalization actions. Init_Expr is + -- the initialization expression of the array component. All hook- + -- related declarations are inserted prior to aggregate N. Remaining + -- code is added to list Stmts. ---------------------- -- Add_Loop_Actions -- @@ -1058,79 +1111,208 @@ package body Exp_Aggr is end if; end Add_Loop_Actions; - -------------------------- - -- Ctrl_Init_Expression -- - -------------------------- + -------------------------------- + -- Initialize_Array_Component -- + -------------------------------- - function Ctrl_Init_Expression - (Comp_Typ : Entity_Id; - Stmts : List_Id) return Node_Id - is + procedure Initialize_Array_Component + (Arr_Comp : Node_Id; + Comp_Typ : Node_Id; Init_Expr : Node_Id; - Obj_Id : Entity_Id; - Ptr_Typ : Entity_Id; + Stmts : List_Id) + is + Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); + Init_Stmt : Node_Id; begin - Init_Expr := New_Copy_Tree (Expr); + -- Initialize the array element. Generate: - -- Perform a preliminary analysis and resolution to determine - -- what the expression denotes. Note that a function call may - -- appear as an identifier or an indexed component. + -- Arr_Comp := Init_Expr; - Preanalyze_And_Resolve (Init_Expr, Comp_Typ); + -- Note that the initialization expression is replicated because + -- it has to be reevaluated within a generated loop. - -- The initialization expression is a controlled function call. - -- Perform in-place removal of side effects to avoid creating a - -- transient scope. In the end the temporary function result is - -- finalized by the general finalization machinery. + Init_Stmt := + Make_OK_Assignment_Statement (Loc, + Name => New_Copy_Tree (Arr_Comp), + Expression => New_Copy_Tree (Init_Expr)); + Set_No_Ctrl_Actions (Init_Stmt); - if Nkind (Init_Expr) = N_Function_Call then + -- If this is an aggregate for an array of arrays, each + -- subaggregate will be expanded as well, and even with + -- No_Ctrl_Actions the assignments of inner components will + -- require attachment in their assignments to temporaries. These + -- temporaries must be finalized for each subaggregate. Generate: - -- Suppress the removal of side effects by generatal analysis - -- because this behavior is emulated here. + -- begin + -- Arr_Comp := Init_Expr; + -- end; - Set_No_Side_Effect_Removal (Init_Expr); + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then Is_Array_Type (Comp_Typ) + then + Init_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Init_Stmt))); + end if; - -- Generate: - -- type Ptr_Typ is access all Comp_Typ; + Append_To (Stmts, Init_Stmt); - Ptr_Typ := Make_Temporary (Loc, 'A'); + -- Adjust the tag due to a possible view conversion. Generate: + -- Arr_Comp._tag := Full_TypP; + + if Tagged_Type_Expansion + and then Present (Comp_Typ) + and then Is_Tagged_Type (Comp_Typ) + then Append_To (Stmts, - 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 (Comp_Typ, Loc)))); + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Arr_Comp), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Full_Typ), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Full_Typ))), + Loc)))); + end if; - -- Generate: - -- Obj : constant Ptr_Typ := Init_Expr'Reference; + -- Adjust the array component. Controlled subaggregates are not + -- considered because each of their individual elements will + -- receive an adjustment of its own. Generate: - Obj_Id := Make_Temporary (Loc, 'R'); + -- [Deep_]Adjust (Arr_Comp); + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then not Is_Limited_Type (Comp_Typ) + and then not + (Is_Array_Type (Comp_Typ) + and then Is_Controlled (Component_Type (Comp_Typ)) + and then Nkind (Expr) = N_Aggregate) + then Append_To (Stmts, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), - Expression => Make_Reference (Loc, Init_Expr))); + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Arr_Comp), + Typ => Comp_Typ)); + end if; + end Initialize_Array_Component; - -- Generate: - -- Obj.all; + ------------------------------------- + -- Initialize_Ctrl_Array_Component -- + ------------------------------------- - return - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc)); + procedure Initialize_Ctrl_Array_Component + (Arr_Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id) + is + Act_Aggr : Node_Id; + Act_Stmts : List_Id; + Fin_Call : Node_Id; + Hook_Clear : Node_Id; - -- Otherwise the initialization expression denotes a controlled - -- object. There is nothing special to be done here as there is - -- no possible transient scope involvement. + In_Place_Expansion : Boolean; + -- Flag set when a nonlimited controlled function call requires + -- in-place expansion. - else - return Init_Expr; + begin + -- Perform a preliminary analysis and resolution to determine what + -- the initialization expression denotes. An unanalyzed function + -- call may appear as an identifier or an indexed component. + + if Nkind_In (Init_Expr, N_Function_Call, + N_Identifier, + N_Indexed_Component) + and then not Analyzed (Init_Expr) + then + Preanalyze_And_Resolve (Init_Expr, Comp_Typ); + end if; + + In_Place_Expansion := + Nkind (Init_Expr) = N_Function_Call + and then not Is_Limited_Type (Comp_Typ); + + -- The initialization expression is a controlled function call. + -- Perform in-place removal of side effects to avoid creating a + -- transient scope, which leads to premature finalization. + + -- This in-place expansion is not performed for limited transient + -- objects because the initialization is already done in-place. + + if In_Place_Expansion then + + -- Suppress the removal of side effects by general analysis + -- because this behavior is emulated here. This avoids the + -- generation of a transient scope, which leads to out-of-order + -- adjustment and finalization. + + Set_No_Side_Effect_Removal (Init_Expr); + + -- When the transient component initialization is related to a + -- range or an "others", keep all generated statements within + -- the enclosing loop. This way the controlled function call + -- will be evaluated at each iteration, and its result will be + -- finalized at the end of each iteration. + + if In_Loop then + Act_Aggr := Empty; + Act_Stmts := Stmts; + + -- Otherwise this is a single component initialization. Hook- + -- related statements are inserted prior to the aggregate. + + else + Act_Aggr := N; + Act_Stmts := No_List; + end if; + + -- Install all hook-related declarations and prepare the clean + -- up statements. + + Process_Transient_Component + (Loc => Loc, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Fin_Call => Fin_Call, + Hook_Clear => Hook_Clear, + Aggr => Act_Aggr, + Stmts => Act_Stmts); end if; - end Ctrl_Init_Expression; + + -- Use the noncontrolled component initialization circuitry to + -- assign the result of the function call to the array element. + -- This also performs subaggregate wrapping, tag adjustment, and + -- [deep] adjustment of the array element. + + Initialize_Array_Component + (Arr_Comp => Arr_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Stmts => Stmts); + + -- At this point the array element is fully initialized. Complete + -- the processing of the controlled array component by finalizing + -- the transient function result. + + if In_Place_Expansion then + Process_Transient_Component_Completion + (Loc => Loc, + Aggr => N, + Fin_Call => Fin_Call, + Hook_Clear => Hook_Clear, + Stmts => Stmts); + end if; + end Initialize_Ctrl_Array_Component; -- Local variables @@ -1140,8 +1322,6 @@ package body Exp_Aggr is Expr_Q : Node_Id; Indexed_Comp : Node_Id; New_Indexes : List_Id; - Stmt : Node_Id; - Stmt_Expr : Node_Id; -- Start of processing for Gen_Assign @@ -1253,7 +1433,7 @@ package body Exp_Aggr is -- component associations that provide different bounds from -- those of the component type, and sliding must occur. Instead -- of decomposing the current aggregate assignment, force the - -- re-analysis of the assignment, so that a temporary will be + -- reanalysis of the assignment, so that a temporary will be -- generated in the usual fashion, and sliding will take place. if Nkind (Parent (N)) = N_Assignment_Statement @@ -1272,6 +1452,59 @@ package body Exp_Aggr is end if; end if; + if Present (Expr) then + + -- Handle an initialization expression of a controlled type in + -- case it denotes a function call. In general such a scenario + -- will produce a transient scope, but this will lead to wrong + -- order of initialization, adjustment, and finalization in the + -- context of aggregates. + + -- Target (1) := Ctrl_Func_Call; + + -- begin -- scope + -- Trans_Obj : ... := Ctrl_Func_Call; -- object + -- Target (1) := Trans_Obj; + -- Finalize (Trans_Obj); + -- end; + -- Target (1)._tag := ...; + -- Adjust (Target (1)); + + -- In the example above, the call to Finalize occurs too early + -- and as a result it may leave the array component in a bad + -- state. Finalization of the transient object should really + -- happen after adjustment. + + -- To avoid this scenario, perform in-place side-effect removal + -- of the function call. This eliminates the transient property + -- of the function result and ensures correct order of actions. + + -- Res : ... := Ctrl_Func_Call; + -- Target (1) := Res; + -- Target (1)._tag := ...; + -- Adjust (Target (1)); + -- Finalize (Res); + + if Present (Comp_Typ) + and then Needs_Finalization (Comp_Typ) + and then Nkind (Expr) /= N_Aggregate + then + Initialize_Ctrl_Array_Component + (Arr_Comp => Indexed_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Expr, + Stmts => Stmts); + + -- Otherwise perform simple component initialization + + else + Initialize_Array_Component + (Arr_Comp => Indexed_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Expr, + Stmts => Stmts); + end if; + -- Ada 2005 (AI-287): In case of default initialized component, call -- the initialization subprogram associated with the component type. -- If the component type is an access type, add an explicit null @@ -1283,7 +1516,7 @@ package body Exp_Aggr is -- its Initialize procedure explicitly, because there is no explicit -- object creation that will invoke it otherwise. - if No (Expr) then + else if Present (Base_Init_Proc (Base_Type (Ctype))) or else Has_Task (Base_Type (Ctype)) then @@ -1316,154 +1549,6 @@ package body Exp_Aggr is (Obj_Ref => New_Copy_Tree (Indexed_Comp), Typ => Ctype)); end if; - - else - -- Handle an initialization expression of a controlled type in - -- case it denotes a function call. In general such a scenario - -- will produce a transient scope, but this will lead to wrong - -- order of initialization, adjustment, and finalization in the - -- context of aggregates. - - -- Arr_Comp (1) := Ctrl_Func_Call; - - -- begin -- transient scope - -- Trans_Obj : ... := Ctrl_Func_Call; -- transient object - -- Arr_Comp (1) := Trans_Obj; - -- Finalize (Trans_Obj); - -- end; - -- Arr_Comp (1)._tag := ...; - -- Adjust (Arr_Comp (1)); - - -- In the example above, the call to Finalize occurs too early - -- and as a result it may leave the array component in a bad - -- state. Finalization of the transient object should really - -- happen after adjustment. - - -- To avoid this scenario, perform in-place side effect removal - -- of the function call. This eliminates the transient property - -- of the function result and ensures correct order of actions. - -- Note that the function result behaves as a source controlled - -- object and is finalized by the general finalization mechanism. - - -- begin - -- Res : ... := Ctrl_Func_Call; - -- Arr_Comp (1) := Res; - -- Arr_Comp (1)._tag := ...; - -- Adjust (Arr_Comp (1)); - -- at end - -- Finalize (Res); - -- end; - - -- There is no need to perform this kind of light expansion when - -- the component type is limited controlled because everything is - -- already done in place. - - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - and then not Is_Limited_Type (Comp_Typ) - and then Nkind (Expr) /= N_Aggregate - then - Stmt_Expr := Ctrl_Init_Expression (Comp_Typ, Stmts); - - -- Otherwise use the initialization expression directly - - else - Stmt_Expr := New_Copy_Tree (Expr); - end if; - - Stmt := - Make_OK_Assignment_Statement (Loc, - Name => New_Copy_Tree (Indexed_Comp), - Expression => Stmt_Expr); - - -- The target of the assignment may not have been initialized, - -- so it is not possible to call Finalize as expected in normal - -- controlled assignments. We must also avoid using the primitive - -- _assign (which depends on a valid target, and may for example - -- perform discriminant checks on it). - - -- Both Finalize and usage of _assign are disabled by setting - -- No_Ctrl_Actions on the assignment. The rest of the controlled - -- actions are done manually with the proper finalization list - -- coming from the context. - - Set_No_Ctrl_Actions (Stmt); - - -- If this is an aggregate for an array of arrays, each - -- subaggregate will be expanded as well, and even with - -- No_Ctrl_Actions the assignments of inner components will - -- require attachment in their assignments to temporaries. These - -- temporaries must be finalized for each subaggregate, to prevent - -- multiple attachments of the same temporary location to same - -- finalization chain (and consequently circular lists). To ensure - -- that finalization takes place for each subaggregate we wrap the - -- assignment in a block. - - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - and then Is_Array_Type (Comp_Typ) - and then Present (Expr) - then - Stmt := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Stmt))); - end if; - - Append_To (Stmts, Stmt); - - -- Adjust the tag due to a possible view conversion - - if Present (Comp_Typ) - and then Is_Tagged_Type (Comp_Typ) - and then Tagged_Type_Expansion - then - declare - Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); - - begin - Append_To (Stmts, - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Indexed_Comp), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Full_Typ), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Full_Typ))), - Loc)))); - end; - end if; - - -- Adjust and attach the component to the proper final list, which - -- can be the controller of the outer record object or the final - -- list associated with the scope. - - -- If the component is itself an array of controlled types, whose - -- value is given by a subaggregate, then the attach calls have - -- been generated when individual subcomponent are assigned, and - -- must not be done again to prevent malformed finalization chains - -- (see comments above, concerning the creation of a block to hold - -- inner finalization actions). - - if Present (Comp_Typ) - and then Needs_Finalization (Comp_Typ) - and then not Is_Limited_Type (Comp_Typ) - and then not - (Is_Array_Type (Comp_Typ) - and then Is_Controlled (Component_Type (Comp_Typ)) - and then Nkind (Expr) = N_Aggregate) - then - Append_To (Stmts, - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Indexed_Comp), - Typ => Comp_Typ)); - end if; end if; return Add_Loop_Actions (Stmts); @@ -1545,7 +1630,6 @@ package body Exp_Aggr is and then Local_Compile_Time_Known_Value (H) and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2 then - Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr)); Append_List_To (S, Gen_Assign (Add (1, To => L), Expr)); @@ -1600,7 +1684,8 @@ package body Exp_Aggr is -- Construct the statements to execute in the loop body - L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr); + L_Body := + Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True); -- Construct the final loop @@ -1707,8 +1792,9 @@ package body Exp_Aggr is Expression => W_Index_Succ); Append_To (W_Body, W_Increment); + Append_List_To (W_Body, - Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr)); + Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True)); -- Construct the final loop @@ -1784,14 +1870,9 @@ package body Exp_Aggr is end if; end Local_Expr_Value; - -- Build_Array_Aggr_Code Variables - - Assoc : Node_Id; - Choice : Node_Id; - Expr : Node_Id; - Typ : Entity_Id; + -- Local variables - Others_Assoc : Node_Id := Empty; + New_Code : constant List_Id := New_List; Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); @@ -1803,8 +1884,12 @@ package body Exp_Aggr is Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H); -- After Duplicate_Subexpr these are side-effect free - Low : Node_Id; - High : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + High : Node_Id; + Low : Node_Id; + Typ : Entity_Id; Nb_Choices : Nat := 0; Table : Case_Table_Type (1 .. Number_Of_Choices (N)); @@ -1813,7 +1898,7 @@ package body Exp_Aggr is Nb_Elements : Int; -- Number of elements in the positional aggregate - New_Code : constant List_Id := New_List; + Others_Assoc : Node_Id := Empty; -- Start of processing for Build_Array_Aggr_Code @@ -2076,13 +2161,42 @@ package body Exp_Aggr is -- The type of the aggregate is a subtype created ealier using the -- given values of the discriminant components of the aggregate. + procedure Initialize_Ctrl_Record_Component + (Rec_Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of controlled record component Rec_Comp. + -- Comp_Typ is the component type. Init_Expr is the initialization + -- expression for the record component. Hook-related declarations are + -- inserted prior to aggregate N using Insert_Action. All remaining + -- generated code is added to list Stmts. + + procedure Initialize_Record_Component + (Rec_Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id); + -- Perform the initialization of record component Rec_Comp. Comp_Typ + -- is the component type. Init_Expr is the initialization expression + -- of the record component. All generated code is added to list Stmts. + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; -- Check whether Bounds is a range node and its lower and higher bounds -- are integers literals. - --------------------------------- - -- Ancestor_Discriminant_Value -- - --------------------------------- + function Replace_Type (Expr : Node_Id) return Traverse_Result; + -- If the aggregate contains a self-reference, traverse each expression + -- to replace a possible self-reference with a reference to the proper + -- component of the target of the assignment. + + function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; + -- If default expression of a component mentions a discriminant of the + -- type, it must be rewritten as the discriminant of the target object. + + --------------------------------- + -- Ancestor_Discriminant_Value -- + --------------------------------- function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id is Assoc : Node_Id; @@ -2259,6 +2373,39 @@ package body Exp_Aggr is return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi; end Compatible_Int_Bounds; + ----------------------------------- + -- Generate_Finalization_Actions -- + ----------------------------------- + + procedure Generate_Finalization_Actions is + begin + -- Do the work only the first time this is called + + if Finalization_Done then + return; + end if; + + Finalization_Done := True; + + -- Determine the external finalization list. It is either the + -- finalization list of the outer scope or the one coming from an + -- outer aggregate. When the target is not a temporary, the proper + -- scope is the scope of the target rather than the potentially + -- transient current scope. + + if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then + Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); + Set_Assignment_OK (Ref); + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + end if; + end Generate_Finalization_Actions; + -------------------------------- -- Get_Constraint_Association -- -------------------------------- @@ -2528,80 +2675,167 @@ package body Exp_Aggr is end loop; end Init_Stored_Discriminants; - ------------------------- - -- Is_Int_Range_Bounds -- - ------------------------- + -------------------------------------- + -- Initialize_Ctrl_Record_Component -- + -------------------------------------- - function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is - begin - return Nkind (Bounds) = N_Range - and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal - and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; - end Is_Int_Range_Bounds; + procedure Initialize_Ctrl_Record_Component + (Rec_Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id) + is + Fin_Call : Node_Id; + Hook_Clear : Node_Id; - ----------------------------------- - -- Generate_Finalization_Actions -- - ----------------------------------- + In_Place_Expansion : Boolean; + -- Flag set when a nonlimited controlled function call requires + -- in-place expansion. - procedure Generate_Finalization_Actions is begin - -- Do the work only the first time this is called - - if Finalization_Done then - return; + -- Perform a preliminary analysis and resolution to determine what + -- the initialization expression denotes. Unanalyzed function calls + -- may appear as identifiers or indexed components. + + if Nkind_In (Init_Expr, N_Function_Call, + N_Identifier, + N_Indexed_Component) + and then not Analyzed (Init_Expr) + then + Preanalyze_And_Resolve (Init_Expr, Comp_Typ); end if; - Finalization_Done := True; + In_Place_Expansion := + Nkind (Init_Expr) = N_Function_Call + and then not Is_Limited_Type (Comp_Typ); - -- Determine the external finalization list. It is either the - -- finalization list of the outer-scope or the one coming from an - -- outer aggregate. When the target is not a temporary, the proper - -- scope is the scope of the target rather than the potentially - -- transient current scope. + -- The initialization expression is a controlled function call. + -- Perform in-place removal of side effects to avoid creating a + -- transient scope. - if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then - Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); - Set_Assignment_OK (Ref); + -- This in-place expansion is not performed for limited transient + -- objects because the initialization is already done in place. - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), - Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + if In_Place_Expansion then + + -- Suppress the removal of side effects by general analysis + -- because this behavior is emulated here. This avoids the + -- generation of a transient scope, which leads to out-of-order + -- adjustment and finalization. + + Set_No_Side_Effect_Removal (Init_Expr); + + -- Install all hook-related declarations and prepare the clean up + -- statements. + + Process_Transient_Component + (Loc => Loc, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Fin_Call => Fin_Call, + Hook_Clear => Hook_Clear, + Aggr => N); end if; - end Generate_Finalization_Actions; - function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result; - -- If default expression of a component mentions a discriminant of the - -- type, it must be rewritten as the discriminant of the target object. + -- Use the noncontrolled component initialization circuitry to + -- assign the result of the function call to the record component. + -- This also performs tag adjustment and [deep] adjustment of the + -- record component. + + Initialize_Record_Component + (Rec_Comp => Rec_Comp, + Comp_Typ => Comp_Typ, + Init_Expr => Init_Expr, + Stmts => Stmts); + + -- At this point the record component is fully initialized. Complete + -- the processing of the controlled record component by finalizing + -- the transient function result. + + if In_Place_Expansion then + Process_Transient_Component_Completion + (Loc => Loc, + Aggr => N, + Fin_Call => Fin_Call, + Hook_Clear => Hook_Clear, + Stmts => Stmts); + end if; + end Initialize_Ctrl_Record_Component; - function Replace_Type (Expr : Node_Id) return Traverse_Result; - -- If the aggregate contains a self-reference, traverse each expression - -- to replace a possible self-reference with a reference to the proper - -- component of the target of the assignment. + --------------------------------- + -- Initialize_Record_Component -- + --------------------------------- - -------------------------- - -- Rewrite_Discriminant -- - -------------------------- + procedure Initialize_Record_Component + (Rec_Comp : Node_Id; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Stmts : List_Id) + is + Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); + Init_Stmt : Node_Id; - function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is begin - if Is_Entity_Name (Expr) - and then Present (Entity (Expr)) - and then Ekind (Entity (Expr)) = E_In_Parameter - and then Present (Discriminal_Link (Entity (Expr))) - and then Scope (Discriminal_Link (Entity (Expr))) = - Base_Type (Etype (N)) + -- Initialize the record component. Generate: + + -- Rec_Comp := Init_Expr; + + -- Note that the initialization expression is NOT replicated because + -- only a single component may be initialized by it. + + Init_Stmt := + Make_OK_Assignment_Statement (Loc, + Name => New_Copy_Tree (Rec_Comp), + Expression => Init_Expr); + Set_No_Ctrl_Actions (Init_Stmt); + + Append_To (Stmts, Init_Stmt); + + -- Adjust the tag due to a possible view conversion. Generate: + + -- Rec_Comp._tag := Full_TypeP; + + if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then + Append_To (Stmts, + Make_OK_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Rec_Comp), + Selector_Name => + New_Occurrence_Of + (First_Tag_Component (Full_Typ), Loc)), + + Expression => + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Full_Typ))), + Loc)))); + end if; + + -- Adjust the component. Generate: + + -- [Deep_]Adjust (Rec_Comp); + + if Needs_Finalization (Comp_Typ) + and then not Is_Limited_Type (Comp_Typ) then - Rewrite (Expr, - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Lhs), - Selector_Name => Make_Identifier (Loc, Chars (Expr)))); + Append_To (Stmts, + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Rec_Comp), + Typ => Comp_Typ)); end if; + end Initialize_Record_Component; - return OK; - end Rewrite_Discriminant; + ------------------------- + -- Is_Int_Range_Bounds -- + ------------------------- + + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is + begin + return Nkind (Bounds) = N_Range + and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal + and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; + end Is_Int_Range_Bounds; ------------------ -- Replace_Type -- @@ -2646,12 +2880,34 @@ package body Exp_Aggr is return OK; end Replace_Type; - procedure Replace_Self_Reference is - new Traverse_Proc (Replace_Type); + -------------------------- + -- Rewrite_Discriminant -- + -------------------------- + + function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is + begin + if Is_Entity_Name (Expr) + and then Present (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_In_Parameter + and then Present (Discriminal_Link (Entity (Expr))) + and then Scope (Discriminal_Link (Entity (Expr))) = + Base_Type (Etype (N)) + then + Rewrite (Expr, + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Selector_Name => Make_Identifier (Loc, Chars (Expr)))); + end if; + + return OK; + end Rewrite_Discriminant; procedure Replace_Discriminants is new Traverse_Proc (Rewrite_Discriminant); + procedure Replace_Self_Reference is + new Traverse_Proc (Replace_Type); + -- Start of processing for Build_Record_Aggr_Code begin @@ -3238,57 +3494,61 @@ package body Exp_Aggr is Ctype => Component_Type (Expr_Q_Type), Index => First_Index (Expr_Q_Type), Into => Comp_Expr, - Scalar_Comp => Is_Scalar_Type - (Component_Type (Expr_Q_Type)))); + Scalar_Comp => + Is_Scalar_Type (Component_Type (Expr_Q_Type)))); end; else - Instr := - Make_OK_Assignment_Statement (Loc, - Name => Comp_Expr, - Expression => Expr_Q); - - Set_No_Ctrl_Actions (Instr); - Append_To (L, Instr); - end if; - - -- Adjust the tag if tagged (because of possible view - -- conversions), unless compiling for a VM where tags are - -- implicit. - - -- tmp.comp._tag := comp_typ'tag; - - if Is_Tagged_Type (Comp_Type) - and then Tagged_Type_Expansion - then - Instr := - Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Comp_Expr), - Selector_Name => - New_Occurrence_Of - (First_Tag_Component (Comp_Type), Loc)), - - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Comp_Type))), - Loc))); - - Append_To (L, Instr); - end if; + -- Handle an initialization expression of a controlled type + -- in case it denotes a function call. In general such a + -- scenario will produce a transient scope, but this will + -- lead to wrong order of initialization, adjustment, and + -- finalization in the context of aggregates. + + -- Target.Comp := Ctrl_Func_Call; + + -- begin -- scope + -- Trans_Obj : ... := Ctrl_Func_Call; -- object + -- Target.Comp := Trans_Obj; + -- Finalize (Trans_Obj); + -- end + -- Target.Comp._tag := ...; + -- Adjust (Target.Comp); + + -- In the example above, the call to Finalize occurs too + -- early and as a result it may leave the record component + -- in a bad state. Finalization of the transient object + -- should really happen after adjustment. + + -- To avoid this scenario, perform in-place side-effect + -- removal of the function call. This eliminates the + -- transient property of the function result and ensures + -- correct order of actions. + + -- Res : ... := Ctrl_Func_Call; + -- Target.Comp := Res; + -- Target.Comp._tag := ...; + -- Adjust (Target.Comp); + -- Finalize (Res); + + if Needs_Finalization (Comp_Type) + and then Nkind (Expr_Q) /= N_Aggregate + then + Initialize_Ctrl_Record_Component + (Rec_Comp => Comp_Expr, + Comp_Typ => Etype (Selector), + Init_Expr => Expr_Q, + Stmts => L); - -- Generate: - -- Adjust (tmp.comp); + -- Otherwise perform single component initialization - if Needs_Finalization (Comp_Type) - and then not Is_Limited_Type (Comp_Type) - then - Append_To (L, - Make_Adjust_Call - (Obj_Ref => New_Copy_Tree (Comp_Expr), - Typ => Comp_Type)); + else + Initialize_Record_Component + (Rec_Comp => Comp_Expr, + Comp_Typ => Etype (Selector), + Init_Expr => Expr_Q, + Stmts => L); + end if; end if; end if; @@ -3692,19 +3952,17 @@ package body Exp_Aggr is -- case the current delayed expansion mechanism doesn't work when -- the declared object size depend on the initializing expr. - begin - Parent_Node := Parent (Parent_Node); - Parent_Kind := Nkind (Parent_Node); + Parent_Node := Parent (Parent_Node); + Parent_Kind := Nkind (Parent_Node); - if Parent_Kind = N_Object_Declaration then - Unc_Decl := - not Is_Entity_Name (Object_Definition (Parent_Node)) - or else Has_Discriminants - (Entity (Object_Definition (Parent_Node))) - or else Is_Class_Wide_Type - (Entity (Object_Definition (Parent_Node))); - end if; - end; + if Parent_Kind = N_Object_Declaration then + Unc_Decl := + not Is_Entity_Name (Object_Definition (Parent_Node)) + or else Has_Discriminants + (Entity (Object_Definition (Parent_Node))) + or else Is_Class_Wide_Type + (Entity (Object_Definition (Parent_Node))); + end if; end if; -- Just set the Delay flag in the cases where the transformation will be @@ -3758,13 +4016,14 @@ package body Exp_Aggr is -- the target of the assignment must not be declared within a local -- block, and because cleanup will take place on return from the -- initialization procedure. + -- Should the condition be more restrictive ??? if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ)); end if; - -- If the aggregate is non-limited, create a temporary. If it is limited + -- If the aggregate is nonlimited, create a temporary. If it is limited -- and context is an assignment, this is a subaggregate for an enclosing -- aggregate being expanded. It must be built in place, so use target of -- the current assignment. @@ -7295,176 +7554,305 @@ package body Exp_Aggr is end if; end Must_Slide; - ---------------------------------- - -- Two_Dim_Packed_Array_Handled -- - ---------------------------------- + --------------------------------- + -- Process_Transient_Component -- + --------------------------------- - function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); - Ctyp : constant Entity_Id := Component_Type (Typ); - Comp_Size : constant Int := UI_To_Int (Component_Size (Typ)); - Packed_Array : constant Entity_Id := - Packed_Array_Impl_Type (Base_Type (Typ)); + procedure Process_Transient_Component + (Loc : Source_Ptr; + Comp_Typ : Entity_Id; + Init_Expr : Node_Id; + Fin_Call : out Node_Id; + Hook_Clear : out Node_Id; + Aggr : Node_Id := Empty; + Stmts : List_Id := No_List) + is + procedure Add_Item (Item : Node_Id); + -- Insert arbitrary node Item into the tree depending on the values of + -- Aggr and Stmts. - One_Comp : Node_Id; - -- Expression in original aggregate + -------------- + -- Add_Item -- + -------------- - One_Dim : Node_Id; - -- One-dimensional subaggregate + procedure Add_Item (Item : Node_Id) is + begin + if Present (Aggr) then + Insert_Action (Aggr, Item); + else + pragma Assert (Present (Stmts)); + Append_To (Stmts, Item); + end if; + end Add_Item; + + -- Local variables + + Hook_Assign : Node_Id; + Hook_Decl : Node_Id; + Ptr_Decl : Node_Id; + Res_Decl : Node_Id; + Res_Id : Entity_Id; + Res_Typ : Entity_Id; + + -- Start of processing for Process_Transient_Component begin + -- Add the access type, which provides a reference to the function + -- result. Generate: - -- For now, only deal with cases where an integral number of elements - -- fit in a single byte. This includes the most common boolean case. + -- type Res_Typ is access all Comp_Typ; - if not (Comp_Size = 1 or else - Comp_Size = 2 or else - Comp_Size = 4) - then - return False; - end if; + Res_Typ := Make_Temporary (Loc, 'A'); + Set_Ekind (Res_Typ, E_General_Access_Type); + Set_Directly_Designated_Type (Res_Typ, Comp_Typ); - Convert_To_Positional - (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); + Add_Item + (Make_Full_Type_Declaration (Loc, + Defining_Identifier => Res_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc)))); - -- Verify that all components are static + -- Add the temporary which captures the result of the function call. + -- Generate: - if Nkind (N) = N_Aggregate - and then Compile_Time_Known_Aggregate (N) - then - null; + -- Res : constant Res_Typ := Init_Expr'Reference; - -- The aggregate may have been re-analyzed and converted already + -- Note that this temporary is effectively a transient object because + -- its lifetime is bounded by the current array or record component. - elsif Nkind (N) /= N_Aggregate then - return True; + Res_Id := Make_Temporary (Loc, 'R'); + Set_Ekind (Res_Id, E_Constant); + Set_Etype (Res_Id, Res_Typ); - -- If component associations remain, the aggregate is not static + -- Mark the transient object as successfully processed to avoid double + -- finalization. - elsif Present (Component_Associations (N)) then - return False; + Set_Is_Finalized_Transient (Res_Id); - else - One_Dim := First (Expressions (N)); - while Present (One_Dim) loop - if Present (Component_Associations (One_Dim)) then - return False; - end if; + -- Signal the general finalization machinery that this transient object + -- should not be considered for finalization actions because its cleanup + -- will be performed by Process_Transient_Component_Completion. - One_Comp := First (Expressions (One_Dim)); - while Present (One_Comp) loop - if not Is_OK_Static_Expression (One_Comp) then - return False; - end if; + Set_Is_Ignored_Transient (Res_Id); - Next (One_Comp); - end loop; + Res_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Res_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Res_Typ, Loc), + Expression => + Make_Reference (Loc, New_Copy_Tree (Init_Expr))); - Next (One_Dim); - end loop; - end if; + Add_Item (Res_Decl); - -- Two-dimensional aggregate is now fully positional so pack one - -- dimension to create a static one-dimensional array, and rewrite - -- as an unchecked conversion to the original type. + -- Construct all pieces necessary to hook and finalize the transient + -- result. - declare - Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array)); - -- The packed array type is a byte array + Build_Transient_Object_Statements + (Obj_Decl => Res_Decl, + Fin_Call => Fin_Call, + Hook_Assign => Hook_Assign, + Hook_Clear => Hook_Clear, + Hook_Decl => Hook_Decl, + Ptr_Decl => Ptr_Decl); - Packed_Num : Nat; - -- Number of components accumulated in current byte + -- Add the access type which provides a reference to the transient + -- result. Generate: - Comps : List_Id; - -- Assembled list of packed values for equivalent aggregate + -- type Ptr_Typ is access all Comp_Typ; - Comp_Val : Uint; - -- integer value of component + Add_Item (Ptr_Decl); - Incr : Int; - -- Step size for packing + -- Add the temporary which acts as a hook to the transient result. + -- Generate: - Init_Shift : Int; - -- Endian-dependent start position for packing + -- Hook : Ptr_Typ := null; - Shift : Int; - -- Current insertion position + Add_Item (Hook_Decl); - Val : Int; - -- Component of packed array being assembled. + -- Attach the transient result to the hook. Generate: - begin - Comps := New_List; - Val := 0; - Packed_Num := 0; + -- Hook := Ptr_Typ (Res); - -- Account for endianness. See corresponding comment in - -- Packed_Array_Aggregate_Handled concerning the following. + Add_Item (Hook_Assign); - if Bytes_Big_Endian - xor Debug_Flag_8 - xor Reverse_Storage_Order (Base_Type (Typ)) - then - Init_Shift := Byte_Size - Comp_Size; - Incr := -Comp_Size; - else - Init_Shift := 0; - Incr := +Comp_Size; - end if; + -- The original initialization expression now references the value of + -- the temporary function result. Generate: - -- Iterate over each subaggregate + -- Res.all - Shift := Init_Shift; - One_Dim := First (Expressions (N)); - while Present (One_Dim) loop - One_Comp := First (Expressions (One_Dim)); - while Present (One_Comp) loop - if Packed_Num = Byte_Size / Comp_Size then + Rewrite (Init_Expr, + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Res_Id, Loc))); + end Process_Transient_Component; - -- Byte is complete, add to list of expressions + -------------------------------------------- + -- Process_Transient_Component_Completion -- + -------------------------------------------- - Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); - Val := 0; - Shift := Init_Shift; - Packed_Num := 0; + procedure Process_Transient_Component_Completion + (Loc : Source_Ptr; + Aggr : Node_Id; + Fin_Call : Node_Id; + Hook_Clear : Node_Id; + Stmts : List_Id) + is + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); - else - Comp_Val := Expr_Rep_Value (One_Comp); + begin + pragma Assert (Present (Fin_Call)); + pragma Assert (Present (Hook_Clear)); - -- Adjust for bias, and strip proper number of bits + -- Generate the following code if exception propagation is allowed: - if Has_Biased_Representation (Ctyp) then - Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp)); - end if; + -- declare + -- Abort : constant Boolean := Triggered_By_Abort; + -- + -- Abort : constant Boolean := False; -- no abort - Comp_Val := Comp_Val mod Uint_2 ** Comp_Size; - Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift); - Shift := Shift + Incr; - One_Comp := Next (One_Comp); - Packed_Num := Packed_Num + 1; - end if; - end loop; + -- E : Exception_Occurrence; + -- Raised : Boolean := False; - One_Dim := Next (One_Dim); - end loop; + -- begin + -- [Abort_Defer;] - if Packed_Num > 0 then + -- begin + -- Hook := null; + -- [Deep_]Finalize (Res.all); - -- Add final incomplete byte if present + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, + -- Get_Curent_Excep.all.all); + -- end if; + -- end; - Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); - end if; + -- [Abort_Undefer;] - Rewrite (N, - Unchecked_Convert_To (Typ, - Make_Qualified_Expression (Loc, - Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), - Expression => Make_Aggregate (Loc, Expressions => Comps)))); - Analyze_And_Resolve (N); - return True; - end; - end Two_Dim_Packed_Array_Handled; + -- if Raised and then not Abort then + -- Raise_From_Controlled_Operation (E); + -- end if; + -- end; + + if Exceptions_OK then + Abort_And_Exception : declare + Blk_Decls : constant List_Id := New_List; + Blk_Stmts : constant List_Id := New_List; + + Fin_Data : Finalization_Exception_Data; + + begin + -- Create the declarations of the two flags and the exception + -- occurrence. + + Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); + + -- Generate: + -- Abort_Defer; + + if Abort_Allowed then + Append_To (Blk_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Defer)); + end if; + + -- Wrap the hook clear and the finalization call in order to trap + -- a potential exception. + + Append_To (Blk_Stmts, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Hook_Clear, + Fin_Call), + Exception_Handlers => New_List ( + Build_Exception_Handler (Fin_Data))))); + + -- Generate: + -- Abort_Undefer; + + if Abort_Allowed then + Append_To (Blk_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + + -- Reraise the potential exception with a proper "upgrade" to + -- Program_Error if needed. + + Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); + + -- Wrap everything in a block + + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => Blk_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Blk_Stmts))); + end Abort_And_Exception; + + -- Generate the following code if exception propagation is not allowed + -- and aborts are allowed: + + -- begin + -- Abort_Defer; + -- Hook := null; + -- [Deep_]Finalize (Res.all); + -- at end + -- Abort_Undefer; + -- end; + + elsif Abort_Allowed then + Abort_Only : declare + Blk_Stmts : constant List_Id := New_List; + + AUD : Entity_Id; + Blk : Node_Id; + Blk_HSS : Node_Id; + Blk_Id : Entity_Id; + + begin + Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + Append_To (Blk_Stmts, Hook_Clear); + Append_To (Blk_Stmts, Fin_Call); + + AUD := RTE (RE_Abort_Undefer_Direct); + + Blk_HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Blk_Stmts, + At_End_Proc => New_Occurrence_Of (AUD, Loc)); + + Blk := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Blk_HSS); + + Add_Block_Identifier (Blk, Blk_Id); + Expand_At_End_Handler (Blk_HSS, Blk_Id); + + -- Present the Abort_Undefer_Direct function to the back end so + -- that it can inline the call to the function. + + Add_Inlined_Body (AUD, Aggr); + + Append_To (Stmts, Blk); + end Abort_Only; + + -- Otherwise generate: + + -- Hook := null; + -- [Deep_]Finalize (Res.all); + + else + Append_To (Stmts, Hook_Clear); + Append_To (Stmts, Fin_Call); + end if; + end Process_Transient_Component_Completion; --------------------- -- Sort_Case_Table -- @@ -7612,4 +8000,175 @@ package body Exp_Aggr is end if; end Static_Array_Aggregate; + ---------------------------------- + -- Two_Dim_Packed_Array_Handled -- + ---------------------------------- + + function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ctyp : constant Entity_Id := Component_Type (Typ); + Comp_Size : constant Int := UI_To_Int (Component_Size (Typ)); + Packed_Array : constant Entity_Id := + Packed_Array_Impl_Type (Base_Type (Typ)); + + One_Comp : Node_Id; + -- Expression in original aggregate + + One_Dim : Node_Id; + -- One-dimensional subaggregate + + begin + + -- For now, only deal with cases where an integral number of elements + -- fit in a single byte. This includes the most common boolean case. + + if not (Comp_Size = 1 or else + Comp_Size = 2 or else + Comp_Size = 4) + then + return False; + end if; + + Convert_To_Positional + (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True); + + -- Verify that all components are static + + if Nkind (N) = N_Aggregate + and then Compile_Time_Known_Aggregate (N) + then + null; + + -- The aggregate may have been reanalyzed and converted already + + elsif Nkind (N) /= N_Aggregate then + return True; + + -- If component associations remain, the aggregate is not static + + elsif Present (Component_Associations (N)) then + return False; + + else + One_Dim := First (Expressions (N)); + while Present (One_Dim) loop + if Present (Component_Associations (One_Dim)) then + return False; + end if; + + One_Comp := First (Expressions (One_Dim)); + while Present (One_Comp) loop + if not Is_OK_Static_Expression (One_Comp) then + return False; + end if; + + Next (One_Comp); + end loop; + + Next (One_Dim); + end loop; + end if; + + -- Two-dimensional aggregate is now fully positional so pack one + -- dimension to create a static one-dimensional array, and rewrite + -- as an unchecked conversion to the original type. + + declare + Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array)); + -- The packed array type is a byte array + + Packed_Num : Nat; + -- Number of components accumulated in current byte + + Comps : List_Id; + -- Assembled list of packed values for equivalent aggregate + + Comp_Val : Uint; + -- Integer value of component + + Incr : Int; + -- Step size for packing + + Init_Shift : Int; + -- Endian-dependent start position for packing + + Shift : Int; + -- Current insertion position + + Val : Int; + -- Component of packed array being assembled + + begin + Comps := New_List; + Val := 0; + Packed_Num := 0; + + -- Account for endianness. See corresponding comment in + -- Packed_Array_Aggregate_Handled concerning the following. + + if Bytes_Big_Endian + xor Debug_Flag_8 + xor Reverse_Storage_Order (Base_Type (Typ)) + then + Init_Shift := Byte_Size - Comp_Size; + Incr := -Comp_Size; + else + Init_Shift := 0; + Incr := +Comp_Size; + end if; + + -- Iterate over each subaggregate + + Shift := Init_Shift; + One_Dim := First (Expressions (N)); + while Present (One_Dim) loop + One_Comp := First (Expressions (One_Dim)); + while Present (One_Comp) loop + if Packed_Num = Byte_Size / Comp_Size then + + -- Byte is complete, add to list of expressions + + Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); + Val := 0; + Shift := Init_Shift; + Packed_Num := 0; + + else + Comp_Val := Expr_Rep_Value (One_Comp); + + -- Adjust for bias, and strip proper number of bits + + if Has_Biased_Representation (Ctyp) then + Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp)); + end if; + + Comp_Val := Comp_Val mod Uint_2 ** Comp_Size; + Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift); + Shift := Shift + Incr; + One_Comp := Next (One_Comp); + Packed_Num := Packed_Num + 1; + end if; + end loop; + + One_Dim := Next (One_Dim); + end loop; + + if Packed_Num > 0 then + + -- Add final incomplete byte if present + + Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps); + end if; + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), + Expression => Make_Aggregate (Loc, Expressions => Comps)))); + Analyze_And_Resolve (N); + return True; + end; + end Two_Dim_Packed_Array_Handled; + end Exp_Aggr; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 1cdfa1ac880..f6a5c2c9067 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -226,22 +226,21 @@ package body Exp_Ch4 is procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id); -- Inspect and process statement list Stmt of if or case expression N for - -- transient controlled objects. If such objects are found, the routine - -- generates code to clean them up when the context of the expression is - -- evaluated or elaborated. - - procedure Process_Transient_Object - (Decl : Node_Id; - N : Node_Id; - Stmts : List_Id); + -- transient objects. If such objects are found, the routine generates code + -- to clean them up when the context of the expression is evaluated. + + procedure Process_Transient_In_Expression + (Obj_Decl : Node_Id; + Expr : Node_Id; + Stmts : List_Id); -- Subsidiary routine to the expansion of expression_with_actions, if and -- case expressions. Generate all necessary code to finalize a transient - -- controlled object when the enclosing context is elaborated or evaluated. - -- Decl denotes the declaration of the transient controlled object which is - -- usually the result of a controlled function call. N denotes the related - -- expression_with_actions, if expression, or case expression node. Stmts - -- denotes the statement list which contains Decl, either at the top level - -- or within a nested construct. + -- object when the enclosing context is elaborated or evaluated. Obj_Decl + -- denotes the declaration of the transient object, which is usually the + -- result of a controlled function call. Expr denotes the expression with + -- actions, if expression, or case expression node. Stmts denotes the + -- statement list which contains Decl, either at the top level or within a + -- nested construct. procedure Rewrite_Comparison (N : Node_Id); -- If N is the node for a comparison whose outcome can be determined at @@ -4866,11 +4865,10 @@ package body Exp_Ch4 is Prepend_List (Actions (Alt), Stmts); end if; - -- Finalize any transient controlled objects on exit from the - -- alternative. This is done only in the return optimization case - -- because otherwise the case expression is converted into an - -- expression with actions which already contains this form of - -- processing. + -- Finalize any transient objects on exit from the alternative. + -- This is done only in the return optimization case because + -- otherwise the case expression is converted into an expression + -- with actions which already contains this form of processing. if Optimize_Return_Stmt then Process_If_Case_Statements (N, Stmts); @@ -4952,9 +4950,9 @@ package body Exp_Ch4 is function Process_Action (Act : Node_Id) return Traverse_Result; -- Inspect and process a single action of an expression_with_actions for - -- transient controlled objects. If such objects are found, the routine - -- generates code to clean them up when the context of the expression is - -- evaluated or elaborated. + -- transient objects. If such objects are found, the routine generates + -- code to clean them up when the context of the expression is evaluated + -- or elaborated. ------------------------------ -- Force_Boolean_Evaluation -- @@ -4997,7 +4995,7 @@ package body Exp_Ch4 is if Nkind (Act) = N_Object_Declaration and then Is_Finalizable_Transient (Act, N) then - Process_Transient_Object (Act, N, Acts); + Process_Transient_In_Expression (Act, N, Acts); return Abandon; -- Avoid processing temporary function results multiple times when @@ -5038,8 +5036,8 @@ package body Exp_Ch4 is null; -- Force the evaluation of the expression by capturing its value in a - -- temporary. This ensures that aliases of transient controlled objects - -- do not leak to the expression of the expression_with_actions node: + -- temporary. This ensures that aliases of transient objects do not leak + -- to the expression of the expression_with_actions node: -- do -- Trans_Id : Ctrl_Typ := ...; @@ -5059,12 +5057,12 @@ package body Exp_Ch4 is -- in Val end; -- Once this transformation is performed, it is safe to finalize the - -- transient controlled object at the end of the actions list. + -- transient object at the end of the actions list. -- Note that Force_Evaluation does not remove side effects in operators -- because it assumes that all operands are evaluated and side effect -- free. This is not the case when an operand depends implicitly on the - -- transient controlled object through the use of access types. + -- transient object through the use of access types. elsif Is_Boolean_Type (Etype (Expression (N))) then Force_Boolean_Evaluation (Expression (N)); @@ -5077,8 +5075,8 @@ package body Exp_Ch4 is Force_Evaluation (Expression (N)); end if; - -- Process all transient controlled objects found within the actions of - -- the EWA node. + -- Process all transient objects found within the actions of the EWA + -- node. Act := First (Acts); while Present (Act) loop @@ -12956,44 +12954,44 @@ package body Exp_Ch4 is if Nkind (Decl) = N_Object_Declaration and then Is_Finalizable_Transient (Decl, N) then - Process_Transient_Object (Decl, N, Stmts); + Process_Transient_In_Expression (Decl, N, Stmts); end if; Next (Decl); end loop; end Process_If_Case_Statements; - ------------------------------ - -- Process_Transient_Object -- - ------------------------------ + ------------------------------------- + -- Process_Transient_In_Expression -- + ------------------------------------- - procedure Process_Transient_Object - (Decl : Node_Id; - N : Node_Id; - Stmts : List_Id) + procedure Process_Transient_In_Expression + (Obj_Decl : Node_Id; + Expr : Node_Id; + Stmts : List_Id) is - Loc : constant Source_Ptr := Sloc (Decl); - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - Obj_Typ : constant Node_Id := Etype (Obj_Id); + Loc : constant Source_Ptr := Sloc (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); - Desig_Typ : Entity_Id; - Expr : Node_Id; - Hook_Id : Entity_Id; - Hook_Insert : Node_Id; - Ptr_Id : Entity_Id; - - Hook_Context : constant Node_Id := Find_Hook_Context (N); + Hook_Context : constant Node_Id := Find_Hook_Context (Expr); -- The node on which to insert the hook as an action. This is usually -- the innermost enclosing non-transient construct. + Fin_Call : Node_Id; + Hook_Assign : Node_Id; + Hook_Clear : Node_Id; + Hook_Decl : Node_Id; + Hook_Insert : Node_Id; + Ptr_Decl : Node_Id; + Fin_Context : Node_Id; -- The node after which to insert the finalization actions of the - -- transient controlled object. + -- transient object. begin - pragma Assert (Nkind_In (N, N_Case_Expression, - N_Expression_With_Actions, - N_If_Expression)); + pragma Assert (Nkind_In (Expr, N_Case_Expression, + N_Expression_With_Actions, + N_If_Expression)); -- When the context is a Boolean evaluation, all three nodes capture the -- result of their computation in a local temporary: @@ -13004,102 +13002,63 @@ package body Exp_Ch4 is -- -- in Result end; - -- As a result, the finalization of any transient controlled objects can - -- safely take place after the result capture. + -- As a result, the finalization of any transient objects can safely + -- take place after the result capture. -- ??? could this be extended to elementary types? - if Is_Boolean_Type (Etype (N)) then + if Is_Boolean_Type (Etype (Expr)) then Fin_Context := Last (Stmts); - -- Otherwise the immediate context may not be safe enough to carry out - -- transient controlled object finalization due to aliasing and nesting - -- of constructs. Insert calls to [Deep_]Finalize after the innermost + -- Otherwise the immediate context may not be safe enough to carry + -- out transient object finalization due to aliasing and nesting of + -- constructs. Insert calls to [Deep_]Finalize after the innermost -- enclosing non-transient construct. else Fin_Context := Hook_Context; end if; - -- Step 1: Create the access type which provides a reference to the - -- transient controlled object. + -- Mark the transient object as successfully processed to avoid double + -- finalization. - if Is_Access_Type (Obj_Typ) then - Desig_Typ := Directly_Designated_Type (Obj_Typ); - else - Desig_Typ := Obj_Typ; - end if; + Set_Is_Finalized_Transient (Obj_Id); - Desig_Typ := Base_Type (Desig_Typ); + -- Construct all the pieces necessary to hook and finalize a transient + -- object. - -- Generate: - -- Ann : access [all] ; + 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); - Ptr_Id := Make_Temporary (Loc, 'A'); + -- Add the access type which provides a reference to the transient + -- object. Generate: - 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)))); + -- type Ptr_Typ is access all Desig_Typ; - -- Step 2: Create a temporary which acts as a hook to the transient - -- controlled object. Generate: + Insert_Action (Hook_Context, Ptr_Decl); + + -- Add the temporary which acts as a hook to the transient object. + -- Generate: -- Hook : Ptr_Id := null; - Hook_Id := Make_Temporary (Loc, 'T'); + Insert_Action (Hook_Context, Hook_Decl); - Insert_Action (Hook_Context, - Make_Object_Declaration (Loc, - Defining_Identifier => Hook_Id, - Object_Definition => New_Occurrence_Of (Ptr_Id, Loc))); - - -- Mark the hook as created for the purposes of exporting the transient - -- controlled object out of the expression_with_action or if expression. - -- This signals the machinery in Build_Finalizer to treat this case in - -- a special manner. - - Set_Status_Flag_Or_Transient_Decl (Hook_Id, Decl); - - -- Step 3: Associate the transient object to the hook - - -- This must be inserted right after the object declaration, so that - -- the assignment is executed if, and only if, the object is actually - -- created (whereas the declaration of the hook pointer, and the - -- finalization call, may be inserted at an outer level, and may - -- remain unused for some executions, if the actual creation of - -- the object is conditional). - - -- The use of unchecked conversion / unrestricted access is needed to - -- avoid an accessibility violation. Note that the finalization code is - -- structured in such a way that the "hook" is processed only when it - -- points to an existing object. - - if Is_Access_Type (Obj_Typ) then - Expr := - Unchecked_Convert_To - (Typ => Ptr_Id, - Expr => New_Occurrence_Of (Obj_Id, Loc)); - else - Expr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Attribute_Name => Name_Unrestricted_Access); - end if; + -- When the transient object is initialized by an aggregate, the hook + -- must capture the object after the last aggregate assignment takes + -- place. Only then is the object considered initialized. Generate: - -- Generate: - -- Hook := Ptr_Id (Obj_Id); + -- Hook := Ptr_Typ (Obj_Id); -- -- Hook := Obj_Id'Unrestricted_Access; - -- When the transient object is initialized by an aggregate, the hook - -- must capture the object after the last component assignment takes - -- place. Only then is the object fully initialized. - - if Ekind (Obj_Id) = E_Variable + if Ekind_In (Obj_Id, E_Constant, E_Variable) and then Present (Last_Aggregate_Assignment (Obj_Id)) then Hook_Insert := Last_Aggregate_Assignment (Obj_Id); @@ -13107,54 +13066,42 @@ package body Exp_Ch4 is -- Otherwise the hook seizes the related object immediately else - Hook_Insert := Decl; + Hook_Insert := Obj_Decl; end if; - Insert_After_And_Analyze (Hook_Insert, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Hook_Id, Loc), - Expression => Expr)); - - -- Step 4: Finalize the hook after the context has been evaluated or - -- elaborated. Generate: - - -- if Hook /= null then - -- [Deep_]Finalize (Hook.all); - -- Hook := null; - -- end if; + Insert_After_And_Analyze (Hook_Insert, Hook_Assign); -- 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. + -- (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; - -- Otherwise finalize the hook + -- Finalize the hook after the context has been evaluated. Generate: + + -- if Hook /= null then + -- [Deep_]Finalize (Hook.all); + -- Hook := null; + -- end if; else Insert_Action_After (Fin_Context, - Make_Implicit_If_Statement (Decl, + Make_Implicit_If_Statement (Obj_Decl, Condition => Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Hook_Id, Loc), + Left_Opnd => + New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc), Right_Opnd => Make_Null (Loc)), Then_Statements => New_List ( - Make_Final_Call - (Obj_Ref => - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Hook_Id, Loc)), - Typ => Desig_Typ), - - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Hook_Id, Loc), - Expression => Make_Null (Loc))))); + Fin_Call, + Hook_Clear))); end if; - end Process_Transient_Object; + end Process_Transient_In_Expression; ------------------------ -- Rewrite_Comparison -- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cc593537892..938484b22a2 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4115,10 +4115,6 @@ package body Exp_Ch6 is and then Present (Generalized_Indexing (Ref)); end Is_Element_Reference; - -- Local variables - - Is_Elem_Ref : constant Boolean := Is_Element_Reference (N); - -- Start of processing for Expand_Ctrl_Function_Call begin @@ -4142,20 +4138,24 @@ package body Exp_Ch6 is Remove_Side_Effects (N); - -- When the temporary function result appears inside a case expression - -- or an if expression, its lifetime must be extended to match that of - -- the context. If not, the function result will be finalized too early - -- and the evaluation of the expression could yield incorrect result. An - -- exception to this rule are references to Ada 2012 container elements. + -- The side effect removal of the function call produced a temporary. + -- When the context is a case expression, if expression, or expression + -- with actions, the lifetime of the temporary must be extended to match + -- that of the context. Otherwise the function result will be finalized + -- too early and affect the result of the expression. To prevent this + -- unwanted effect, the temporary should not be considered for clean up + -- actions by the general finalization machinery. + + -- Exception to this rule are references to Ada 2012 container elements. -- Such references must be finalized at the end of each iteration of the -- related quantified expression, otherwise the container will remain -- busy. - if not Is_Elem_Ref + if Nkind (N) = N_Explicit_Dereference and then Within_Case_Or_If_Expression (N) - and then Nkind (N) = N_Explicit_Dereference + and then not Is_Element_Reference (N) then - Set_Is_Processed_Transient (Entity (Prefix (N))); + Set_Is_Ignored_Transient (Entity (Prefix (N))); end if; end Expand_Ctrl_Function_Call; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f46f57ec321..2338deb675f 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2080,11 +2080,19 @@ package body Exp_Ch7 is if For_Package and then Finalize_Storage_Only (Obj_Typ) then null; - -- Transient variables are treated separately in order to - -- minimize the size of the generated code. For details, see - -- Process_Transient_Objects. + -- Finalization of transient objects are treated separately in + -- order to handle sensitive cases. These include: - elsif Is_Processed_Transient (Obj_Id) then + -- * Aggregate expansion + -- * If, case, and expression with actions expansion + -- * Transient scopes + + -- If one of those contexts has marked the transient object as + -- ignored, do not generate finalization actions for it. + + elsif Is_Finalized_Transient (Obj_Id) + or else Is_Ignored_Transient (Obj_Id) + then null; -- Ignored Ghost objects do not need any cleanup actions @@ -2139,8 +2147,8 @@ package body Exp_Ch7 is then Processing_Actions (Has_No_Init => True); - -- Processing for "hook" objects generated for controlled - -- transients declared inside an Expression_With_Actions. + -- Processing for "hook" objects generated for transient + -- objects declared inside an Expression_With_Actions. elsif Is_Access_Type (Obj_Typ) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) @@ -2353,7 +2361,7 @@ package body Exp_Ch7 is end if; end if; - -- Handle a rare case caused by a controlled transient variable + -- Handle a rare case caused by a controlled transient object -- created as part of a record init proc. The variable is wrapped -- in a block, but the block is not associated with a transient -- scope. @@ -3124,7 +3132,7 @@ package body Exp_Ch7 is and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) then -- Temporaries created for the purpose of "exporting" a - -- controlled transient out of an Expression_With_Actions (EWA) + -- transient object out of an Expression_With_Actions (EWA) -- need guards. The following illustrates the usage of such -- temporaries. @@ -6392,30 +6400,31 @@ package body Exp_Ch7 is Act_Cleanup : constant List_Id := Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup); -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. - -- Last), but this was incorrect as Process_Transient_Object may + -- Last), but this was incorrect as Process_Transients_In_Scope may -- introduce new scopes and cause a reallocation of Scope_Stack.Table. - procedure Process_Transient_Objects + procedure Process_Transients_In_Scope (First_Object : Node_Id; Last_Object : Node_Id; Related_Node : Node_Id); - -- First_Object and Last_Object define a list which contains potential - -- controlled transient objects. Finalization flags are inserted before - -- First_Object and finalization calls are inserted after Last_Object. - -- Related_Node is the node for which transient objects have been - -- created. + -- Find all transient objects in the list First_Object .. Last_Object + -- and generate finalization actions for them. Related_Node denotes the + -- node which created all transient objects. - ------------------------------- - -- Process_Transient_Objects -- - ------------------------------- + --------------------------------- + -- Process_Transients_In_Scope -- + --------------------------------- - procedure Process_Transient_Objects + procedure Process_Transients_In_Scope (First_Object : Node_Id; Last_Object : Node_Id; Related_Node : Node_Id) is + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Must_Hook : Boolean := False; - -- Flag denoting whether the context requires transient variable + -- Flag denoting whether the context requires transient object -- export to the outer finalizer. function Is_Subprogram_Call (N : Node_Id) return Traverse_Result; @@ -6424,6 +6433,15 @@ package body Exp_Ch7 is procedure Detect_Subprogram_Call is new Traverse_Proc (Is_Subprogram_Call); + procedure Process_Transient_In_Scope + (Obj_Decl : Node_Id; + Blk_Data : Finalization_Exception_Data; + Blk_Stmts : List_Id); + -- Generate finalization actions for a single transient object + -- denoted by object declaration Obj_Decl. Blk_Data is the + -- exception data of the enclosing block. Blk_Stmts denotes the + -- statements of the enclosing block. + ------------------------ -- Is_Subprogram_Call -- ------------------------ @@ -6466,32 +6484,149 @@ package body Exp_Ch7 is end if; end Is_Subprogram_Call; - -- Local variables + -------------------------------- + -- Process_Transient_In_Scope -- + -------------------------------- - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); + 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); + -- + -- 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 Built : Boolean := False; + Blk_Data : Finalization_Exception_Data; Blk_Decl : Node_Id := Empty; Blk_Decls : List_Id := No_List; Blk_Ins : Node_Id; Blk_Stmts : List_Id; - Desig_Typ : Entity_Id; - Fin_Call : Node_Id; - Fin_Data : Finalization_Exception_Data; - Fin_Stmts : List_Id; - Hook_Clr : Node_Id := Empty; - Hook_Id : Entity_Id; - Hook_Ins : Node_Id; - Init_Expr : Node_Id; Loc : Source_Ptr; Obj_Decl : Node_Id; - Obj_Id : Entity_Id; - Obj_Ref : Node_Id; - Obj_Typ : Entity_Id; - Ptr_Typ : Entity_Id; - -- Start of processing for Process_Transient_Objects + -- Start of processing for Process_Transients_In_Scope begin -- The expansion performed by this routine is as follows: @@ -6536,11 +6671,11 @@ package body Exp_Ch7 is -- Save_Occurrence (Ex, Get_Current_Excep.all.all); -- end; + -- Abort_Undefer; + -- if Raised and not Abrt then -- Raise_From_Controlled_Operation (Ex); -- end if; - - -- Abort_Undefer_Direct; -- end; -- Recognize a scenario where the transient context is an object @@ -6554,8 +6689,8 @@ package body Exp_Ch7 is -- Obj : ...; -- Res : ... := BIP_Func_Call (..., Obj, ...); - -- The finalization of any controlled transient must happen after - -- the build-in-place function call is executed. + -- The finalization of any transient object must happen after the + -- build-in-place function call is executed. if Nkind (N) = N_Object_Declaration and then Present (BIP_Initialization_Call (Defining_Identifier (N))) @@ -6589,114 +6724,7 @@ package body Exp_Ch7 is and then Obj_Decl /= Related_Node then - Loc := Sloc (Obj_Decl); - Obj_Id := Defining_Identifier (Obj_Decl); - Obj_Typ := Base_Type (Etype (Obj_Id)); - Desig_Typ := Obj_Typ; - - Set_Is_Processed_Transient (Obj_Id); - - -- Handle access types - - if Is_Access_Type (Desig_Typ) then - Desig_Typ := Available_View (Designated_Type (Desig_Typ)); - end if; - - -- Transient objects associated with subprogram calls need - -- extra processing. These objects are usually created right - -- before the call and finalized immediately after the call. - -- If an exception occurs during the call, the clean up code - -- is skipped due to the sudden change in control and the - -- transient is never finalized. - - -- To handle this case, such variables are "exported" to the - -- enclosing sequence of statements where their corresponding - -- "hooks" are picked up by the finalization machinery. - - if Must_Hook then - - -- Create an access type which provides a reference to the - -- transient object. Generate: - -- type Ptr_Typ is access [all] Desig_Typ; - - Ptr_Typ := Make_Temporary (Loc, 'A'); - - Insert_Action (Obj_Decl, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => - Ekind (Obj_Typ) = E_General_Access_Type, - Subtype_Indication => - New_Occurrence_Of (Desig_Typ, Loc)))); - - -- Create a temporary which acts as a hook to the transient - -- object. Generate: - -- Hook : Ptr_Typ := null; - - Hook_Id := Make_Temporary (Loc, 'T'); - - Insert_Action (Obj_Decl, - Make_Object_Declaration (Loc, - Defining_Identifier => Hook_Id, - Object_Definition => - New_Occurrence_Of (Ptr_Typ, Loc))); - - -- Mark the temporary as a hook. This signals the machinery - -- in Build_Finalizer to recognize this special case. - - Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl); - - -- Hook the transient object to the temporary. Generate: - -- Hook := Ptr_Typ (Obj_Id); - -- - -- Hook := Obj_Id'Unrestricted_Access; - - if Is_Access_Type (Obj_Typ) then - Init_Expr := - Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc)); - - else - Init_Expr := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Attribute_Name => Name_Unrestricted_Access); - end if; - - -- When the transient object is initialized by an aggregate, - -- the hook must capture the object after the last component - -- assignment takes place. Only then is the object fully - -- initialized. - - if Ekind (Obj_Id) = E_Variable - and then Present (Last_Aggregate_Assignment (Obj_Id)) - then - Hook_Ins := Last_Aggregate_Assignment (Obj_Id); - - -- Otherwise the hook seizes the related object immediately - - else - Hook_Ins := Obj_Decl; - end if; - - Insert_After_And_Analyze (Hook_Ins, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Hook_Id, Loc), - Expression => Init_Expr)); - - -- The transient object is about to be finalized by the - -- clean up code following the subprogram call. In order - -- to avoid double finalization, clear the hook. - - -- Generate: - -- Hook := null; - - Hook_Clr := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Hook_Id, Loc), - Expression => Make_Null (Loc)); - end if; + Loc := Sloc (Obj_Decl); -- Before generating the clean up code for the first transient -- object, create a wrapper block which houses all hook clear @@ -6707,25 +6735,14 @@ package body Exp_Ch7 is Built := True; Blk_Stmts := New_List; - -- Create the declarations of all entities that participate - -- in exception detection and propagation. + -- Generate: + -- Abrt : constant Boolean := ...; + -- Ex : Exception_Occurrence; + -- Raised : Boolean := False; if Exceptions_OK then Blk_Decls := New_List; - - -- Generate: - -- Abrt : constant Boolean := ...; - -- Ex : Exception_Occurrence; - -- Raised : Boolean := False; - - Build_Object_Declarations (Fin_Data, Blk_Decls, Loc); - - -- Generate: - -- if Raised and then not Abrt then - -- Raise_From_Controlled_Operation (Ex); - -- end if; - - Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data)); + Build_Object_Declarations (Blk_Data, Blk_Decls, Loc); end if; Blk_Decl := @@ -6736,64 +6753,13 @@ package body Exp_Ch7 is Statements => Blk_Stmts)); end if; - -- Generate: - -- [Deep_]Finalize (Obj_Ref); - - Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); - - if Is_Access_Type (Obj_Typ) then - Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - Set_Etype (Obj_Ref, Desig_Typ); - end if; - - Fin_Call := - Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); - - -- When exception propagation is enabled wrap the hook clear - -- statement and the finalization call into a block to catch - -- potential exceptions raised during finalization. Generate: - - -- begin - -- [Temp := null;] - -- [Deep_]Finalize (Obj_Ref); - - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence - -- (Enn, Get_Current_Excep.all.all); - -- end if; - -- end; - - if Exceptions_OK then - Fin_Stmts := New_List; + -- Construct all necessary circuitry to hook and finalize a + -- single transient object. - if Present (Hook_Clr) then - Append_To (Fin_Stmts, Hook_Clr); - end if; - - Append_To (Fin_Stmts, Fin_Call); - - Prepend_To (Blk_Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - Exception_Handlers => New_List ( - Build_Exception_Handler (Fin_Data))))); - - -- Otherwise generate: - -- [Temp := null;] - -- [Deep_]Finalize (Obj_Ref); - - else - Prepend_To (Blk_Stmts, Fin_Call); - - if Present (Hook_Clr) then - Prepend_To (Blk_Stmts, Hook_Clr); - end if; - end if; + Process_Transient_In_Scope + (Obj_Decl => Obj_Decl, + Blk_Data => Blk_Data, + Blk_Stmts => Blk_Stmts); end if; -- Terminate the scan after the last object has been processed to @@ -6806,12 +6772,15 @@ package body Exp_Ch7 is Next (Obj_Decl); end loop; + -- Complete the decoration of the enclosing finalization block and + -- insert it into the tree. + if Present (Blk_Decl) then - -- Note that the abort defer / undefer pair does not require an - -- extra block because each finalization exception is caught in - -- its corresponding finalization block. As a result, the call to - -- Abort_Defer always takes place. + -- Note that this Abort_Undefer does not require a extra block or + -- an AT_END handler because each finalization exception is caught + -- in its own corresponding finalization block. As a result, the + -- call to Abort_Defer always takes place. if Abort_Allowed then Prepend_To (Blk_Stmts, @@ -6821,9 +6790,18 @@ package body Exp_Ch7 is Build_Runtime_Call (Loc, RE_Abort_Undefer)); end if; + -- Generate: + -- if Raised and then not Abrt then + -- Raise_From_Controlled_Operation (Ex); + -- end if; + + if Exceptions_OK then + Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data)); + end if; + Insert_After_And_Analyze (Blk_Ins, Blk_Decl); end if; - end Process_Transient_Objects; + end Process_Transients_In_Scope; -- Local variables @@ -6901,10 +6879,10 @@ package body Exp_Ch7 is (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id)); end if; - -- Check for transient controlled objects associated with Target and - -- generate the appropriate finalization actions for them. + -- Check for transient objects associated with Target and generate the + -- appropriate finalization actions for them. - Process_Transient_Objects + Process_Transients_In_Scope (First_Object => First_Obj, Last_Object => Last_Obj, Related_Node => Target); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f3b63758e31..92a3aab53a5 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1653,6 +1653,133 @@ package body Exp_Util is return Build_Task_Image_Function (Loc, Decls, Stats, Res); end Build_Task_Record_Image; + --------------------------------------- + -- Build_Transient_Object_Statements -- + --------------------------------------- + + procedure Build_Transient_Object_Statements + (Obj_Decl : Node_Id; + Fin_Call : out Node_Id; + Hook_Assign : out Node_Id; + Hook_Clear : out Node_Id; + Hook_Decl : out Node_Id; + Ptr_Decl : out Node_Id; + Finalize_Obj : Boolean := True) + is + Loc : constant Source_Ptr := Sloc (Obj_Decl); + Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); + Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); + + Desig_Typ : Entity_Id; + Hook_Expr : Node_Id; + Hook_Id : Entity_Id; + Obj_Ref : Node_Id; + Ptr_Typ : Entity_Id; + + begin + -- Recover the type of the object + + Desig_Typ := Obj_Typ; + + if Is_Access_Type (Desig_Typ) then + Desig_Typ := Available_View (Designated_Type (Desig_Typ)); + end if; + + -- Create an access type which provides a reference to the transient + -- object. Generate: + + -- type Ptr_Typ is access all Desig_Typ; + + Ptr_Typ := Make_Temporary (Loc, 'A'); + Set_Ekind (Ptr_Typ, E_General_Access_Type); + Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ); + + Ptr_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))); + + -- Create a temporary check which acts as a hook to the transient + -- object. Generate: + + -- Hook : Ptr_Typ := null; + + Hook_Id := Make_Temporary (Loc, 'T'); + Set_Ekind (Hook_Id, E_Variable); + Set_Etype (Hook_Id, Ptr_Typ); + + Hook_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Hook_Id, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), + Expression => Make_Null (Loc)); + + -- Mark the temporary as a hook. This signals the machinery in + -- Build_Finalizer to recognize this special case. + + Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl); + + -- Hook the transient object to the temporary. Generate: + + -- Hook := Ptr_Typ (Obj_Id); + -- + -- Hool := Obj_Id'Unrestricted_Access; + + if Is_Access_Type (Obj_Typ) then + Hook_Expr := + Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc)); + else + Hook_Expr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; + + Hook_Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Hook_Expr); + + -- Crear the hook prior to finalizing the object. Generate: + + -- Hook := null; + + Hook_Clear := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Make_Null (Loc)); + + -- Finalize the object. Generate: + + -- [Deep_]Finalize (Obj_Ref[.all]); + + if Finalize_Obj then + Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); + + if Is_Access_Type (Obj_Typ) then + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); + Set_Etype (Obj_Ref, Desig_Typ); + end if; + + Fin_Call := Make_Final_Call (Obj_Ref, Desig_Typ); + + -- Otherwise finalize the hook. Generate: + + -- [Deep_]Finalize (Hook.all); + + else + Fin_Call := + Make_Final_Call ( + Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Hook_Id, Loc)), + Typ => Desig_Typ); + end if; + end Build_Transient_Object_Statements; + ----------------------------- -- Check_Float_Op_Overflow -- ----------------------------- @@ -5067,7 +5194,7 @@ package body Exp_Util is -- explicit aliases of it: -- do - -- Trans_Id : Ctrl_Typ ...; -- controlled transient object + -- Trans_Id : Ctrl_Typ ...; -- transient object -- Alias : ... := Trans_Id; -- object is aliased -- Val : constant Boolean := -- ... Alias ...; -- aliasing ends @@ -5236,6 +5363,10 @@ package body Exp_Util is and then Requires_Transient_Scope (Desig) and then Nkind (Rel_Node) /= N_Simple_Return_Statement + -- Do not consider a transient object that was already processed + + and then not Is_Finalized_Transient (Obj_Id) + -- Do not consider renamed or 'reference-d transient objects because -- the act of renaming extends the object's lifetime. @@ -8255,11 +8386,19 @@ package body Exp_Util is if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then null; - -- Transient variables are treated separately in order to minimize - -- the size of the generated code. See Exp_Ch7.Process_Transient_ - -- Objects. + -- Finalization of transient objects are treated separately in + -- order to handle sensitive cases. These include: - elsif Is_Processed_Transient (Obj_Id) then + -- * Aggregate expansion + -- * If, case, and expression with actions expansion + -- * Transient scopes + + -- If one of those contexts has marked the transient object as + -- ignored, do not generate finalization actions for it. + + elsif Is_Finalized_Transient (Obj_Id) + or else Is_Ignored_Transient (Obj_Id) + then null; -- Ignored Ghost objects do not need any cleanup actions because @@ -8315,8 +8454,8 @@ package body Exp_Util is then return True; - -- Processing for "hook" objects generated for controlled - -- transients declared inside an Expression_With_Actions. + -- Processing for "hook" objects generated for transient objects + -- declared inside an Expression_With_Actions. elsif Is_Access_Type (Obj_Typ) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) @@ -8464,7 +8603,7 @@ package body Exp_Util is elsif Nkind (Decl) = N_Block_Statement and then - -- Handle a rare case caused by a controlled transient variable + -- Handle a rare case caused by a controlled transient object -- created as part of a record init proc. The variable is wrapped -- in a block, but the block is not associated with a transient -- scope. diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 86136458667..e5b991690b4 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -280,6 +280,35 @@ package Exp_Util is -- is false, the call is for a stand-alone object, and the generated -- function itself must do its own cleanups. + procedure Build_Transient_Object_Statements + (Obj_Decl : Node_Id; + Fin_Call : out Node_Id; + Hook_Assign : out Node_Id; + Hook_Clear : out Node_Id; + Hook_Decl : out Node_Id; + Ptr_Decl : out Node_Id; + Finalize_Obj : Boolean := True); + -- Subsidiary to the processing of transient objects in transient scopes, + -- if expressions, case expressions, expression_with_action nodes, array + -- aggregates, and record aggregates. Obj_Decl denotes the declaration of + -- the transient object. Generate the following nodes: + -- + -- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient + -- object if flag Finalize_Obj is set to True, or finalizes the hook when + -- the flag is False. + -- + -- * Hook_Assign - the assignment statement which captures a reference to + -- the transient object in the hook. + -- + -- * Hook_Clear - the assignment statement which resets the hook to null + -- + -- * Hook_Decl - the declaration of the hook object + -- + -- * Ptr_Decl - the full type declaration of the hook type + -- + -- These nodes are inserted in specific places depending on the context by + -- the various Process_Transient_xxx routines. + procedure Check_Float_Op_Overflow (N : Node_Id); -- Called where we could have a floating-point binary operator where we -- must check for infinities if we are operating in Check_Float_Overflow diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 4f24ab29498..580d33ecce6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2930,7 +2930,7 @@ package body Sem_Aggr is end if; else - Error_Msg_N ("no unique type for this aggregate", A); + Error_Msg_N ("no unique type for this aggregate", A); end if; Check_Function_Writable_Actuals (N); @@ -2941,25 +2941,9 @@ package body Sem_Aggr is ------------------------------ procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is - Assoc : Node_Id; - -- N_Component_Association node belonging to the input aggregate N - - Expr : Node_Id; - Positional_Expr : Node_Id; - Component : Entity_Id; - Component_Elmt : Elmt_Id; - - Components : constant Elist_Id := New_Elmt_List; - -- Components is the list of the record components whose value must be - -- provided in the aggregate. This list does include discriminants. - New_Assoc_List : constant List_Id := New_List; - New_Assoc : Node_Id; -- New_Assoc_List is the newly built list of N_Component_Association - -- nodes. New_Assoc is one such N_Component_Association node in it. - -- Note that while Assoc and New_Assoc contain the same kind of nodes, - -- they are used to iterate over two different N_Component_Association - -- lists. + -- nodes. Others_Etype : Entity_Id := Empty; -- This variable is used to save the Etype of the last record component @@ -2975,7 +2959,6 @@ package body Sem_Aggr is Box_Node : Node_Id; Is_Box_Present : Boolean := False; Others_Box : Integer := 0; - -- Ada 2005 (AI-287): Variables used in case of default initialization -- to provide a functionality similar to Others_Etype. Box_Present -- indicates that the component takes its default initialization; @@ -2983,9 +2966,9 @@ package body Sem_Aggr is -- (which may be a sub-aggregate of a larger one) that are default- -- initialized. A value of One indicates that an others_box is present. -- Any larger value indicates that the others_box is not redundant. - -- These variables, similar to Others_Etype, are also updated as a - -- side effect of function Get_Value. - -- Box_Node is used to place a warning on a redundant others_box. + -- These variables, similar to Others_Etype, are also updated as a side + -- effect of function Get_Value. Box_Node is used to place a warning on + -- a redundant others_box. procedure Add_Association (Component : Entity_Id; @@ -2997,14 +2980,23 @@ package body Sem_Aggr is -- either New_Assoc_List, or the association being built for an inner -- aggregate. - function Discr_Present (Discr : Entity_Id) return Boolean; + procedure Add_Discriminant_Values + (New_Aggr : Node_Id; + Assoc_List : List_Id); + -- The constraint to a component may be given by a discriminant of the + -- enclosing type, in which case we have to retrieve its value, which is + -- part of the enclosing aggregate. Assoc_List provides the discriminant + -- associations of the current type or of some enclosing record. + + function Discriminant_Present (Input_Discr : Entity_Id) return Boolean; -- If aggregate N is a regular aggregate this routine will return True. - -- Otherwise, if N is an extension aggregate, Discr is a discriminant - -- whose value may already have been specified by N's ancestor part. - -- This routine checks whether this is indeed the case and if so returns - -- False, signaling that no value for Discr should appear in N's - -- aggregate part. Also, in this case, the routine appends to - -- New_Assoc_List the discriminant value specified in the ancestor part. + -- Otherwise, if N is an extension aggregate, then Input_Discr denotes + -- a discriminant whose value may already have been specified by N's + -- ancestor part. This routine checks whether this is indeed the case + -- and if so returns False, signaling that no value for Input_Discr + -- should appear in N's aggregate part. Also, in this case, the routine + -- appends to New_Assoc_List the discriminant value specified in the + -- ancestor part. -- -- If the aggregate is in a context with expansion delayed, it will be -- reanalyzed. The inherited discriminant values must not be reinserted @@ -3012,11 +3004,16 @@ package body Sem_Aggr is -- present on first analysis to build the proper subtype indications. -- The flag Inherited_Discriminant is used to prevent the re-insertion. + function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id; + -- AI05-0115: Find earlier ancestor in the derivation chain that is + -- derived from private view Typ. Whether the aggregate is legal depends + -- on the current visibility of the type as well as that of the parent + -- of the ancestor. + function Get_Value (Compon : Node_Id; From : List_Id; - Consider_Others_Choice : Boolean := False) - return Node_Id; + Consider_Others_Choice : Boolean := False) return Node_Id; -- Given a record component stored in parameter Compon, this function -- returns its value as it appears in the list From, which is a list -- of N_Component_Association nodes. @@ -3041,7 +3038,14 @@ package body Sem_Aggr is -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine -- also copies the dimensions of Source to the returned node. - procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id); + procedure Propagate_Discriminants + (Aggr : Node_Id; + Assoc_List : List_Id); + -- Nested components may themselves be discriminated types constrained + -- by outer discriminants, whose values must be captured before the + -- aggregate is expanded into assignments. + + procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id); -- Analyzes and resolves expression Expr against the Etype of the -- Component. This routine also applies all appropriate checks to Expr. -- It finally saves a Expr in the newly created association list that @@ -3059,13 +3063,12 @@ package body Sem_Aggr is Assoc_List : List_Id; Is_Box_Present : Boolean := False) is - Loc : Source_Ptr; Choice_List : constant List_Id := New_List; - New_Assoc : Node_Id; + Loc : Source_Ptr; begin - -- If this is a box association the expression is missing, so - -- use the Sloc of the aggregate itself for the new association. + -- If this is a box association the expression is missing, so use the + -- Sloc of the aggregate itself for the new association. if Present (Expr) then Loc := Sloc (Expr); @@ -3073,34 +3076,97 @@ package body Sem_Aggr is Loc := Sloc (N); end if; - Append (New_Occurrence_Of (Component, Loc), Choice_List); - New_Assoc := + Append_To (Choice_List, New_Occurrence_Of (Component, Loc)); + + Append_To (Assoc_List, Make_Component_Association (Loc, Choices => Choice_List, Expression => Expr, - Box_Present => Is_Box_Present); - Append (New_Assoc, Assoc_List); + Box_Present => Is_Box_Present)); end Add_Association; - ------------------- - -- Discr_Present -- - ------------------- + ----------------------------- + -- Add_Discriminant_Values -- + ----------------------------- + + 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. - function Discr_Present (Discr : Entity_Id) return Boolean is + if Is_Entity_Name (Discr_Val) + and then Ekind (Entity (Discr_Val)) = E_Discriminant + then + Val := Entity (Discr_Val); + + Assoc := First (Assoc_List); + while Present (Assoc) loop + if Present (Entity (First (Choices (Assoc)))) + and then Entity (First (Choices (Assoc))) = Val + then + Discr_Val := Expression (Assoc); + exit; + end if; + + Next (Assoc); + end loop; + end if; + + Add_Association + (Discr, New_Copy_Tree (Discr_Val), + Component_Associations (New_Aggr)); + + -- If the discriminant constraint is a current instance, mark the + -- current aggregate so that the self-reference can be expanded + -- later. The constraint may refer to the subtype of aggregate, so + -- use base type for comparison. + + if Nkind (Discr_Val) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Discr_Val)) + and then Is_Type (Entity (Prefix (Discr_Val))) + and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val)) + then + Set_Has_Self_Reference (N); + end if; + + Next_Elmt (Discr_Elmt); + Next_Discriminant (Discr); + end loop; + end Add_Discriminant_Values; + + -------------------------- + -- Discriminant_Present -- + -------------------------- + + function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate; + Ancestor_Is_Subtyp : Boolean; + Loc : Source_Ptr; Ancestor : Node_Id; + Ancestor_Typ : Entity_Id; Comp_Assoc : Node_Id; + Discr : Entity_Id; Discr_Expr : Node_Id; - - Ancestor_Typ : Entity_Id; + Discr_Val : Elmt_Id := No_Elmt; Orig_Discr : Entity_Id; - D : Entity_Id; - D_Val : Elmt_Id := No_Elmt; -- stop junk warning - - Ancestor_Is_Subtyp : Boolean; begin if Regular_Aggr then @@ -3157,41 +3223,66 @@ package body Sem_Aggr is -- Now look to see if Discr was specified in the ancestor part if Ancestor_Is_Subtyp then - D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor))); + Discr_Val := + First_Elmt (Discriminant_Constraint (Entity (Ancestor))); end if; - Orig_Discr := Original_Record_Component (Discr); + Orig_Discr := Original_Record_Component (Input_Discr); - D := First_Discriminant (Ancestor_Typ); - while Present (D) loop + Discr := First_Discriminant (Ancestor_Typ); + while Present (Discr) loop -- If Ancestor has already specified Disc value then insert its -- value in the final aggregate. - if Original_Record_Component (D) = Orig_Discr then + if Original_Record_Component (Discr) = Orig_Discr then if Ancestor_Is_Subtyp then - Discr_Expr := New_Copy_Tree (Node (D_Val)); + Discr_Expr := New_Copy_Tree (Node (Discr_Val)); else Discr_Expr := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Ancestor), - Selector_Name => New_Occurrence_Of (Discr, Loc)); + Selector_Name => New_Occurrence_Of (Input_Discr, Loc)); end if; - Resolve_Aggr_Expr (Discr_Expr, Discr); + Resolve_Aggr_Expr (Discr_Expr, Input_Discr); Set_Inherited_Discriminant (Last (New_Assoc_List)); return False; end if; - Next_Discriminant (D); + Next_Discriminant (Discr); if Ancestor_Is_Subtyp then - Next_Elmt (D_Val); + Next_Elmt (Discr_Val); end if; end loop; return True; - end Discr_Present; + end Discriminant_Present; + + --------------------------- + -- Find_Private_Ancestor -- + --------------------------- + + function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is + Par : Entity_Id; + + begin + Par := Typ; + loop + if Has_Private_Ancestor (Par) + and then not Has_Private_Ancestor (Etype (Base_Type (Par))) + then + return Par; + + elsif not Is_Derived_Type (Par) then + return Empty; + + else + Par := Etype (Base_Type (Par)); + end if; + end loop; + end Find_Private_Ancestor; --------------- -- Get_Value -- @@ -3200,8 +3291,7 @@ package body Sem_Aggr is function Get_Value (Compon : Node_Id; From : List_Id; - Consider_Others_Choice : Boolean := False) - return Node_Id + Consider_Others_Choice : Boolean := False) return Node_Id is Typ : constant Entity_Id := Etype (Compon); Assoc : Node_Id; @@ -3266,14 +3356,14 @@ package body Sem_Aggr is null; else Error_Msg_N - ("components in OTHERS choice must " - & "have same type", Selector_Name); + ("components in OTHERS choice must have same " + & "type", Selector_Name); end if; end if; Others_Etype := Typ; - -- Copy expression so that it is resolved + -- Copy the expression so that it is resolved -- independently for each component, This is needed -- for accessibility checks on compoents of anonymous -- access types, even in compile_only mode. @@ -3414,11 +3504,110 @@ package body Sem_Aggr is return New_Copy; end New_Copy_Tree_And_Copy_Dimensions; + ----------------------------- + -- Propagate_Discriminants -- + ----------------------------- + + procedure Propagate_Discriminants + (Aggr : Node_Id; + Assoc_List : List_Id) + is + Loc : constant Source_Ptr := Sloc (N); + + Needs_Box : Boolean := False; + + procedure Process_Component (Comp : Entity_Id); + -- Add one component with a box association to the inner aggregate, + -- and recurse if component is itself composite. + + ----------------------- + -- Process_Component -- + ----------------------- + + procedure Process_Component (Comp : Entity_Id) is + T : constant Entity_Id := Etype (Comp); + New_Aggr : Node_Id; + + begin + if Is_Record_Type (T) and then Has_Discriminants (T) then + New_Aggr := Make_Aggregate (Loc, New_List, New_List); + Set_Etype (New_Aggr, T); + + Add_Association + (Comp, New_Aggr, Component_Associations (Aggr)); + + -- Collect discriminant values and recurse + + Add_Discriminant_Values (New_Aggr, Assoc_List); + Propagate_Discriminants (New_Aggr, Assoc_List); + + else + Needs_Box := True; + end if; + end Process_Component; + + -- Local variables + + Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr)); + Components : constant Elist_Id := New_Elmt_List; + Def_Node : constant Node_Id := + Type_Definition (Declaration_Node (Aggr_Type)); + + Comp : Node_Id; + Comp_Elmt : Elmt_Id; + Errors : Boolean; + + -- Start of processing for Propagate_Discriminants + + begin + -- The component type may be a variant type. Collect the components + -- that are ruled by the known values of the discriminants. Their + -- values have already been inserted into the component list of the + -- current aggregate. + + if Nkind (Def_Node) = N_Record_Definition + and then Present (Component_List (Def_Node)) + and then Present (Variant_Part (Component_List (Def_Node))) + then + Gather_Components (Aggr_Type, + Component_List (Def_Node), + Governed_By => Component_Associations (Aggr), + Into => Components, + Report_Errors => Errors); + + Comp_Elmt := First_Elmt (Components); + while Present (Comp_Elmt) loop + if Ekind (Node (Comp_Elmt)) /= E_Discriminant then + Process_Component (Node (Comp_Elmt)); + end if; + + Next_Elmt (Comp_Elmt); + end loop; + + -- No variant part, iterate over all components + + else + Comp := First_Component (Etype (Aggr)); + while Present (Comp) loop + Process_Component (Comp); + Next_Component (Comp); + end loop; + end if; + + if Needs_Box then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True)); + end if; + end Propagate_Discriminants; + ----------------------- -- Resolve_Aggr_Expr -- ----------------------- - procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is + procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is function Has_Expansion_Delayed (Expr : Node_Id) return Boolean; -- If the expression is an aggregate (possibly qualified) then its -- expansion is delayed until the enclosing aggregate is expanded @@ -3433,14 +3622,15 @@ package body Sem_Aggr is --------------------------- function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is - Kind : constant Node_Kind := Nkind (Expr); begin - return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) - and then Present (Etype (Expr)) - and then Is_Record_Type (Etype (Expr)) - and then Expansion_Delayed (Expr)) - or else (Kind = N_Qualified_Expression - and then Has_Expansion_Delayed (Expression (Expr))); + return + (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + and then Present (Etype (Expr)) + and then Is_Record_Type (Etype (Expr)) + and then Expansion_Delayed (Expr)) + or else + (Nkind (Expr) = N_Qualified_Expression + and then Has_Expansion_Delayed (Expression (Expr))); end Has_Expansion_Delayed; -- Local variables @@ -3580,6 +3770,8 @@ package body Sem_Aggr is Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed); end if; + -- Add association Component => Expr if the caller requests it + if Relocate then New_Expr := Relocate_Node (Expr); @@ -3595,6 +3787,17 @@ package body Sem_Aggr is Add_Association (New_C, New_Expr, New_Assoc_List); end Resolve_Aggr_Expr; + -- Local variables + + Components : constant Elist_Id := New_Elmt_List; + -- Components is the list of the record components whose value must be + -- provided in the aggregate. This list does include discriminants. + + Expr : Node_Id; + Component : Entity_Id; + Component_Elmt : Elmt_Id; + Positional_Expr : Node_Id; + -- Start of processing for Resolve_Record_Aggregate begin @@ -3607,7 +3810,6 @@ package body Sem_Aggr is if Present (Component_Associations (N)) and then Present (First (Component_Associations (N))) then - if Present (Expressions (N)) then Check_SPARK_05_Restriction ("named association cannot follow positional one", @@ -3678,8 +3880,9 @@ package body Sem_Aggr is -- STEP 2: Verify aggregate structure Step_2 : declare - Selector_Name : Node_Id; + Assoc : Node_Id; Bad_Aggregate : Boolean := False; + Selector_Name : Node_Id; begin if Present (Component_Associations (N)) then @@ -3774,7 +3977,7 @@ package body Sem_Aggr is -- First find the discriminant values in the positional components while Present (Discrim) and then Present (Positional_Expr) loop - if Discr_Present (Discrim) then + if Discriminant_Present (Discrim) then Resolve_Aggr_Expr (Positional_Expr, Discrim); -- Ada 2005 (AI-231) @@ -3802,7 +4005,7 @@ package body Sem_Aggr is while Present (Discrim) loop Expr := Get_Value (Discrim, Component_Associations (N), True); - if not Discr_Present (Discrim) then + if not Discriminant_Present (Discrim) then if Present (Expr) then Error_Msg_NE ("more than one value supplied for discriminant &", @@ -3850,17 +4053,17 @@ package body Sem_Aggr is and then Present (Underlying_Record_View (Typ))) then Build_Constrained_Itype : declare + Constrs : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (N); + Def_Id : Entity_Id; Indic : Node_Id; + New_Assoc : Node_Id; Subtyp_Decl : Node_Id; - Def_Id : Entity_Id; - - C : constant List_Id := New_List; begin New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop - Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C); + Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); Next (New_Assoc); end loop; @@ -3872,14 +4075,16 @@ package body Sem_Aggr is Subtype_Mark => New_Occurrence_Of (Underlying_Record_View (Typ), Loc), Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, C)); + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constrs)); else Indic := Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc), Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, C)); + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constrs)); end if; Def_Id := Create_Itype (Ekind (Typ), N); @@ -3906,45 +4111,13 @@ package body Sem_Aggr is -- STEP 5: Get remaining components according to discriminant values Step_5 : declare + Dnode : Node_Id; + Errors_Found : Boolean := False; Record_Def : Node_Id; Parent_Typ : Entity_Id; - Root_Typ : Entity_Id; Parent_Typ_List : Elist_Id; Parent_Elmt : Elmt_Id; - Errors_Found : Boolean := False; - Dnode : Node_Id; - - function Find_Private_Ancestor return Entity_Id; - -- AI05-0115: Find earlier ancestor in the derivation chain that is - -- derived from a private view. Whether the aggregate is legal - -- depends on the current visibility of the type as well as that - -- of the parent of the ancestor. - - --------------------------- - -- Find_Private_Ancestor -- - --------------------------- - - function Find_Private_Ancestor return Entity_Id is - Par : Entity_Id; - - begin - Par := Typ; - loop - if Has_Private_Ancestor (Par) - and then not Has_Private_Ancestor (Etype (Base_Type (Par))) - then - return Par; - - elsif not Is_Derived_Type (Par) then - return Empty; - - else - Par := Etype (Base_Type (Par)); - end if; - end loop; - end Find_Private_Ancestor; - - -- Start of processing for Step_5 + Root_Typ : Entity_Id; begin if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then @@ -3959,19 +4132,20 @@ package body Sem_Aggr is Root_Typ := Base_Type (Etype (Ancestor_Part (N))); else - -- AI05-0115: check legality of aggregate for type with - -- aa private ancestor. + -- AI05-0115: check legality of aggregate for type with a + -- private ancestor. Root_Typ := Root_Type (Typ); if Has_Private_Ancestor (Typ) then declare Ancestor : constant Entity_Id := - Find_Private_Ancestor; + Find_Private_Ancestor (Typ); Ancestor_Unit : constant Entity_Id := - Cunit_Entity (Get_Source_Unit (Ancestor)); + Cunit_Entity + (Get_Source_Unit (Ancestor)); Parent_Unit : constant Entity_Id := - Cunit_Entity - (Get_Source_Unit (Base_Type (Etype (Ancestor)))); + Cunit_Entity (Get_Source_Unit + (Base_Type (Etype (Ancestor)))); begin -- Check whether we are in a scope that has full view -- over the private ancestor and its parent. This can @@ -4189,8 +4363,7 @@ package body Sem_Aggr is -- object of the aggregate. if Present (Parent (Component)) - and then - Nkind (Parent (Component)) = N_Component_Declaration + and then Nkind (Parent (Component)) = N_Component_Declaration and then Present (Expression (Parent (Component))) then Expr := @@ -4213,26 +4386,18 @@ package body Sem_Aggr is elsif Present (Underlying_Type (Ctyp)) and then Is_Access_Type (Underlying_Type (Ctyp)) then - if not Is_Private_Type (Ctyp) then - Expr := Make_Null (Sloc (N)); - Set_Etype (Expr, Ctyp); - Add_Association - (Component => Component, - Expr => Expr, - Assoc_List => New_Assoc_List); - -- If the component's type is private with an access type as -- its underlying type then we have to create an unchecked -- conversion to satisfy type checking. - else + if Is_Private_Type (Ctyp) then declare Qual_Null : constant Node_Id := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Underlying_Type (Ctyp), Sloc (N)), - Expression => Make_Null (Sloc (N))); + Expression => Make_Null (Sloc (N))); Convert_Null : constant Node_Id := Unchecked_Convert_To @@ -4245,6 +4410,17 @@ package body Sem_Aggr is Expr => Convert_Null, Assoc_List => New_Assoc_List); end; + + -- Otherwise the component type is non-private + + else + Expr := Make_Null (Sloc (N)); + Set_Etype (Expr, Ctyp); + + Add_Association + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); end if; -- Ada 2012: If component is scalar with default value, use it @@ -4254,8 +4430,9 @@ package body Sem_Aggr is then Add_Association (Component => Component, - Expr => Default_Aspect_Value - (First_Subtype (Underlying_Type (Ctyp))), + Expr => + Default_Aspect_Value + (First_Subtype (Underlying_Type (Ctyp))), Assoc_List => New_Assoc_List); elsif Has_Non_Null_Base_Init_Proc (Ctyp) @@ -4270,8 +4447,8 @@ package body Sem_Aggr is -- for the rest, if other components are present. -- The type of the aggregate is the known subtype of - -- the component. The capture of discriminants must - -- be recursive because subcomponents may be constrained + -- the component. The capture of discriminants must be + -- recursive because subcomponents may be constrained -- (transitively) by discriminants of enclosing types. -- For a private type with discriminants, a call to the -- initialization procedure will be generated, and no @@ -4281,206 +4458,6 @@ package body Sem_Aggr is Loc : constant Source_Ptr := Sloc (N); Expr : Node_Id; - procedure Add_Discriminant_Values - (New_Aggr : Node_Id; - Assoc_List : List_Id); - -- The constraint to a component may be given by a - -- discriminant of the enclosing type, in which case - -- we have to retrieve its value, which is part of the - -- enclosing aggregate. Assoc_List provides the - -- discriminant associations of the current type or - -- of some enclosing record. - - procedure Propagate_Discriminants - (Aggr : Node_Id; - Assoc_List : List_Id); - -- Nested components may themselves be discriminated - -- types constrained by outer discriminants, whose - -- values must be captured before the aggregate is - -- expanded into assignments. - - ----------------------------- - -- Add_Discriminant_Values -- - ----------------------------- - - procedure Add_Discriminant_Values - (New_Aggr : Node_Id; - Assoc_List : List_Id) - is - Assoc : Node_Id; - Discr : Entity_Id; - Discr_Elmt : Elmt_Id; - Discr_Val : Node_Id; - Val : Entity_Id; - - begin - Discr := First_Discriminant (Etype (New_Aggr)); - Discr_Elmt := - First_Elmt - (Discriminant_Constraint (Etype (New_Aggr))); - while Present (Discr_Elmt) loop - Discr_Val := Node (Discr_Elmt); - - -- If the constraint is given by a discriminant - -- it is a discriminant of an enclosing record, - -- and its value has already been placed in the - -- association list. - - if Is_Entity_Name (Discr_Val) - and then - Ekind (Entity (Discr_Val)) = E_Discriminant - then - Val := Entity (Discr_Val); - - Assoc := First (Assoc_List); - while Present (Assoc) loop - if Present - (Entity (First (Choices (Assoc)))) - and then - Entity (First (Choices (Assoc))) = Val - then - Discr_Val := Expression (Assoc); - exit; - end if; - - Next (Assoc); - end loop; - end if; - - Add_Association - (Discr, New_Copy_Tree (Discr_Val), - Component_Associations (New_Aggr)); - - -- If the discriminant constraint is a current - -- instance, mark the current aggregate so that - -- the self-reference can be expanded later. - -- The constraint may refer to the subtype of - -- aggregate, so use base type for comparison. - - if Nkind (Discr_Val) = N_Attribute_Reference - and then Is_Entity_Name (Prefix (Discr_Val)) - and then Is_Type (Entity (Prefix (Discr_Val))) - and then Base_Type (Etype (N)) = - Entity (Prefix (Discr_Val)) - then - Set_Has_Self_Reference (N); - end if; - - Next_Elmt (Discr_Elmt); - Next_Discriminant (Discr); - end loop; - end Add_Discriminant_Values; - - ----------------------------- - -- Propagate_Discriminants -- - ----------------------------- - - procedure Propagate_Discriminants - (Aggr : Node_Id; - Assoc_List : List_Id) - is - Aggr_Type : constant Entity_Id := - Base_Type (Etype (Aggr)); - Def_Node : constant Node_Id := - Type_Definition - (Declaration_Node (Aggr_Type)); - - Comp : Node_Id; - Comp_Elmt : Elmt_Id; - Components : constant Elist_Id := New_Elmt_List; - Needs_Box : Boolean := False; - Errors : Boolean; - - procedure Process_Component (Comp : Entity_Id); - -- Add one component with a box association to the - -- inner aggregate, and recurse if component is - -- itself composite. - - ----------------------- - -- Process_Component -- - ----------------------- - - procedure Process_Component (Comp : Entity_Id) is - T : constant Entity_Id := Etype (Comp); - New_Aggr : Node_Id; - - begin - if Is_Record_Type (T) - and then Has_Discriminants (T) - then - New_Aggr := - Make_Aggregate (Loc, New_List, New_List); - Set_Etype (New_Aggr, T); - Add_Association - (Comp, New_Aggr, - Component_Associations (Aggr)); - - -- Collect discriminant values and recurse - - Add_Discriminant_Values - (New_Aggr, Assoc_List); - Propagate_Discriminants - (New_Aggr, Assoc_List); - - else - Needs_Box := True; - end if; - end Process_Component; - - -- Start of processing for Propagate_Discriminants - - begin - -- The component type may be a variant type, so - -- collect the components that are ruled by the - -- known values of the discriminants. Their values - -- have already been inserted into the component - -- list of the current aggregate. - - if Nkind (Def_Node) = N_Record_Definition - and then Present (Component_List (Def_Node)) - and then - Present - (Variant_Part (Component_List (Def_Node))) - then - Gather_Components (Aggr_Type, - Component_List (Def_Node), - Governed_By => Component_Associations (Aggr), - Into => Components, - Report_Errors => Errors); - - Comp_Elmt := First_Elmt (Components); - while Present (Comp_Elmt) loop - if Ekind (Node (Comp_Elmt)) /= - E_Discriminant - then - Process_Component (Node (Comp_Elmt)); - end if; - - Next_Elmt (Comp_Elmt); - end loop; - - -- No variant part, iterate over all components - - else - Comp := First_Component (Etype (Aggr)); - while Present (Comp) loop - Process_Component (Comp); - Next_Component (Comp); - end loop; - end if; - - if Needs_Box then - Append_To (Component_Associations (Aggr), - Make_Component_Association (Loc, - Choices => - New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)); - end if; - end Propagate_Discriminants; - - -- Start of processing for Capture_Discriminants - begin Expr := Make_Aggregate (Loc, New_List, New_List); Set_Etype (Expr, Ctyp); @@ -4498,9 +4475,9 @@ package body Sem_Aggr is elsif Has_Discriminants (Ctyp) then Add_Discriminant_Values - (Expr, Component_Associations (Expr)); + (Expr, Component_Associations (Expr)); Propagate_Discriminants - (Expr, Component_Associations (Expr)); + (Expr, Component_Associations (Expr)); else declare @@ -4523,6 +4500,7 @@ package body Sem_Aggr is Expression => Empty, Box_Present => True)); end if; + exit; end if; @@ -4537,6 +4515,9 @@ package body Sem_Aggr is Assoc_List => New_Assoc_List); end Capture_Discriminants; + -- Otherwise the component type is not a record, or it has + -- not discriminants, or it is private. + else Add_Association (Component => Component, @@ -4576,6 +4557,9 @@ package body Sem_Aggr is -- STEP 7: check for invalid components + check type in choice list Step_7 : declare + Assoc : Node_Id; + New_Assoc : Node_Id; + Selectr : Node_Id; -- Selector name @@ -4651,7 +4635,7 @@ package body Sem_Aggr is if Nkind (N) /= N_Extension_Aggregate or else Scope (Original_Record_Component (C)) /= - Etype (Ancestor_Part (N)) + Etype (Ancestor_Part (N)) then exit; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f18551c46d3..07fa54da0db 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4802,6 +4802,24 @@ package body Sem_Ch3 is then Set_Has_Predicates (Id); Set_Has_Delayed_Freeze (Id); + + -- Generated subtypes inherit the predicate function from the parent + -- (no aspects to examine on the generated declaration). + + if not Comes_From_Source (N) then + Set_Ekind (Id, Ekind (T)); + + if Present (Predicate_Function (T)) then + Set_Predicate_Function (Id, Predicate_Function (T)); + + elsif Present (Ancestor_Subtype (T)) + and then Has_Predicates (Ancestor_Subtype (T)) + and then Present (Predicate_Function (Ancestor_Subtype (T))) + then + Set_Predicate_Function (Id, + Predicate_Function (Ancestor_Subtype (T))); + end if; + end if; end if; -- Subtype of Boolean cannot have a constraint in SPARK diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 06e9f06303d..f35c9e25145 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9951,10 +9951,10 @@ package body Sem_Res is begin -- Ensure all actions associated with the left operand (e.g. - -- finalization of transient controlled objects) are fully evaluated - -- locally within an expression with actions. This is particularly - -- helpful for coverage analysis. However this should not happen in - -- generics or if Minimize_Expression_With_Actions is set. + -- finalization of transient objects) are fully evaluated locally within + -- an expression with actions. This is particularly helpful for coverage + -- analysis. However this should not happen in generics or if option + -- Minimize_Expression_With_Actions is set. if Expander_Active and not Minimize_Expression_With_Actions then declare -- 2.30.2