From: Arnaud Charlet Date: Thu, 10 Dec 2020 13:19:55 +0000 (-0500) Subject: [Ada] Bad handling of array sliding in aggregate X-Git-Tag: basepoints/gcc-13~8046 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=fff7a6d923e6189bfce730883c2f81d65432d678;p=thirdparty%2Fgcc.git [Ada] Bad handling of array sliding in aggregate gcc/ada/ * exp_aggr.adb (Collect_Initialization_Statements): Removed. (Convert_Aggr_In_Object_Decl, Expand_Array_Aggregate): Fix creation and insertion of Initialization_Statements. Do not set Initialization_Statements when a transient scope is involved. Move processing of Array_Slice here. Ensure that an object with an Array_Slice call gets its array component initialized. Add comments. * exp_ch7.adb: Update comments. (Store_Actions_In_Scope): Deal properly with an empty list which might now be generated by Convert_Aggr_In_Object_Decl. * exp_ch3.adb: Update comments. (Expand_N_Object_Declaration): Remove processing of Array_Slice. --- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d7e5470b717a..c719b0240844 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -78,15 +78,6 @@ package body Exp_Aggr is type Case_Table_Type is array (Nat range <>) of Case_Bounds; -- Table type used by Check_Case_Choices procedure - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id); - -- If Obj is not frozen, collect actions inserted after N until, but not - -- including, Node_After, for initialization of Obj, and move them to an - -- expression with actions, which becomes the Initialization_Statements for - -- Obj. - procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Container_Aggregate (N : Node_Id); @@ -4210,40 +4201,6 @@ package body Exp_Aggr is return L; end Build_Record_Aggr_Code; - --------------------------------------- - -- Collect_Initialization_Statements -- - --------------------------------------- - - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Init_Actions : constant List_Id := New_List; - Init_Node : Node_Id; - Comp_Stmt : Node_Id; - - begin - -- Nothing to do if Obj is already frozen, as in this case we known we - -- won't need to move the initialization statements about later on. - - if Is_Frozen (Obj) then - return; - end if; - - Init_Node := N; - while Next (Init_Node) /= Node_After loop - Append_To (Init_Actions, Remove_Next (Init_Node)); - end loop; - - if not Is_Empty_List (Init_Actions) then - Comp_Stmt := Make_Compound_Statement (Loc, Actions => Init_Actions); - Insert_Action_After (Init_Node, Comp_Stmt); - Set_Initialization_Statements (Obj, Comp_Stmt); - end if; - end Collect_Initialization_Statements; - ------------------------------- -- Convert_Aggr_In_Allocator -- ------------------------------- @@ -4314,6 +4271,8 @@ package body Exp_Aggr is Typ : constant Entity_Id := Etype (Aggr); Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); + Has_Transient_Scope : Boolean := False; + function Discriminants_Ok return Boolean; -- If the object type is constrained, the discriminants in the -- aggregate must be checked against the discriminants of the subtype. @@ -4405,7 +4364,7 @@ package body Exp_Aggr is -- the finalization list of the return must be moved to the caller's -- finalization list to complete the return. - -- However, if the aggregate is limited, it is built in place, and the + -- Similarly if the aggregate is limited, it is built in place, and the -- controlled components are not assigned to intermediate temporaries -- so there is no need for a transient scope in this case either. @@ -4414,13 +4373,60 @@ package body Exp_Aggr is and then not Is_Limited_Type (Typ) then Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False); + Has_Transient_Scope := True; end if; declare - Node_After : constant Node_Id := Next (N); + Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ); + Stmt : Node_Id; + Param : Node_Id; + begin - Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); - Collect_Initialization_Statements (Obj, N, Node_After); + -- If Obj is already frozen or if N is wrapped in a transient scope, + -- Stmts do not need to be saved in Initialization_Statements since + -- there is no freezing issue. + + if Is_Frozen (Obj) or else Has_Transient_Scope then + Insert_Actions_After (N, Stmts); + else + Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts); + Insert_Action_After (N, Stmt); + + -- Insert_Action_After may freeze Obj in which case we should + -- remove the compound statement just created and simply insert + -- Stmts after N. + + if Is_Frozen (Obj) then + Remove (Stmt); + Insert_Actions_After (N, Stmts); + else + Set_Initialization_Statements (Obj, Stmt); + end if; + end if; + + -- If Typ has controlled components and a call to a Slice_Assign + -- procedure is part of the initialization statements, then we + -- need to initialize the array component since Slice_Assign will + -- need to adjust it. + + if Has_Controlled_Component (Typ) then + Stmt := First (Stmts); + + while Present (Stmt) loop + if Nkind (Stmt) = N_Procedure_Call_Statement + and then Get_TSS_Name (Entity (Name (Stmt))) + = TSS_Slice_Assign + then + Param := First (Parameter_Associations (Stmt)); + Insert_Actions + (Stmt, + Build_Initialization_Call + (Sloc (N), New_Copy_Tree (Param), Etype (Param))); + end if; + + Next (Stmt); + end loop; + end if; end; Set_No_Initialization (N); @@ -6793,6 +6799,7 @@ package body Exp_Aggr is -- code must be inserted after it. The defining entity might not come -- from source if this is part of an inlined body, but the declaration -- itself will. + -- The test below looks very specialized and kludgy??? if Comes_From_Source (Tmp) or else @@ -6800,18 +6807,18 @@ package body Exp_Aggr is and then Comes_From_Source (Parent (N)) and then Tmp = Defining_Entity (Parent (N))) then - declare - Node_After : constant Node_Id := Next (Parent_Node); - - begin + if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then Insert_Actions_After (Parent_Node, Aggr_Code); - - if Parent_Kind = N_Object_Declaration then - Collect_Initialization_Statements - (Obj => Tmp, N => Parent_Node, Node_After => Node_After); - end if; - end; - + else + declare + Comp_Stmt : constant Node_Id := + Make_Compound_Statement + (Sloc (Parent_Node), Actions => Aggr_Code); + begin + Insert_Action_After (Parent_Node, Comp_Stmt); + Set_Initialization_Statements (Tmp, Comp_Stmt); + end; + end if; else Insert_Actions (N, Aggr_Code); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 56924a0460c2..f3729852c4e1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -124,7 +124,7 @@ package body Exp_Ch3 is -- Build assignment procedure for one-dimensional arrays of controlled -- types. Other array and slice assignments are expanded in-line, but -- the code expansion for controlled components (when control actions - -- are active) can lead to very large blocks that GCC3 handles poorly. + -- are active) can lead to very large blocks that GCC handles poorly. procedure Build_Untagged_Equality (Typ : Entity_Id); -- AI05-0123: Equality on untagged records composes. This procedure @@ -4168,7 +4168,7 @@ package body Exp_Ch3 is -- Generates the following subprogram: - -- procedure Assign + -- procedure array_typeSA -- (Source, Target : Array_Type, -- Left_Lo, Left_Hi : Index; -- Right_Lo, Right_Hi : Index; @@ -4178,7 +4178,6 @@ package body Exp_Ch3 is -- Ri1 : Index; -- begin - -- if Left_Hi < Left_Lo then -- return; -- end if; @@ -4204,7 +4203,7 @@ package body Exp_Ch3 is -- Ri1 := Index'succ (Ri1); -- end if; -- end loop; - -- end Assign; + -- end array_typeSA; procedure Build_Slice_Assignment (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); @@ -6561,7 +6560,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not No_Initialization (N) then Obj_Init := Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + (Obj_Ref => New_Object_Reference, Typ => Typ); end if; @@ -6977,11 +6976,7 @@ package body Exp_Ch3 is else -- Obtain actual expression from qualified expression - if Nkind (Expr) = N_Qualified_Expression then - Expr_Q := Expression (Expr); - else - Expr_Q := Expr; - end if; + Expr_Q := Unqualify (Expr); -- When we have the appropriate type of aggregate in the expression -- (it has been determined during analysis of the aggregate by diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 5d8ad7d505d6..0315458da0a0 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -153,9 +153,6 @@ package body Exp_Ch7 is procedure Set_Node_To_Be_Wrapped (N : Node_Id); -- Set the field Node_To_Be_Wrapped of the current scope - -- ??? The entire comment needs to be rewritten - -- ??? which entire comment? - procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); -- Shared processing for Store_xxx_Actions_In_Scope @@ -9841,7 +9838,7 @@ package body Exp_Ch7 is Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); begin - if No (Actions) then + if Is_Empty_List (Actions) then Actions := L; if Is_List_Member (SE.Node_To_Be_Wrapped) then