https://gcc.gnu.org/g:ea0f31d040c10e4f9b42f1cf818970bcaf5277a8
commit r16-7126-gea0f31d040c10e4f9b42f1cf818970bcaf5277a8 Author: Eric Botcazou <[email protected]> Date: Wed Jan 28 23:31:49 2026 +0100 Ada: Fix stack corruption with concatenation and 'Image of composite type The issue is that the expansion of 'Image for composite types is heavyweight and involves a mix of Expression_With_Actions and controlled object that does not work properly when it is the argument of a call to a subprogram, so this replaces it by the canonical scheme used for controlled temporaries. gcc/ada/ PR ada/123832 * exp_imgv.adb: Add with and use clauses for Exp_Ch7. (Expand_Image_Attribute): Establish a transient scope before rewriting the attribute as a call to Put_Image. (Expand_Wide_Image_Attribute): Likewise. (Expand_Wide_Wide_Image_Attribute): Likewise. * exp_put_image.ads (Build_Image_Call): Add note about the need for a transient scope when the function is invoked. * exp_put_image.adb (Build_Image_Call): Call Insert_Actions to immediately insert the actions instead of wrapping them in an Expression_With_Actions node. gcc/testsuite/ * gnat.dg/put_image2.adb: New test. Diff: --- gcc/ada/exp_imgv.adb | 4 ++ gcc/ada/exp_put_image.adb | 94 ++++++++++++------------------------ gcc/ada/exp_put_image.ads | 4 +- gcc/testsuite/gnat.dg/put_image2.adb | 18 +++++++ 4 files changed, 56 insertions(+), 64 deletions(-) diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 8dfb0a8321e3..fd5ddcb4cb44 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -29,6 +29,7 @@ with Checks; use Checks; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Debug; use Debug; +with Exp_Ch7; use Exp_Ch7; with Exp_Put_Image; with Exp_Util; use Exp_Util; with Lib; use Lib; @@ -1050,6 +1051,7 @@ package body Exp_Imgv is -- Exp_Put_Image for details. if Exp_Put_Image.Image_Should_Call_Put_Image (N) then + Establish_Transient_Scope (N, Manage_Sec_Stack => True); Rewrite (N, Exp_Put_Image.Build_Image_Call (N)); Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks); return; @@ -1863,6 +1865,7 @@ package body Exp_Imgv is -- Exp_Put_Image for details. if Exp_Put_Image.Image_Should_Call_Put_Image (N) then + Establish_Transient_Scope (N, Manage_Sec_Stack => True); Rewrite (N, Exp_Put_Image.Build_Image_Call (N)); Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks); return; @@ -1972,6 +1975,7 @@ package body Exp_Imgv is -- Exp_Put_Image for details. if Exp_Put_Image.Image_Should_Call_Put_Image (N) then + Establish_Transient_Scope (N, Manage_Sec_Stack => True); Rewrite (N, Exp_Put_Image.Build_Image_Call (N)); Analyze_And_Resolve (N, Standard_Wide_Wide_String, Suppress => All_Checks); diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index a13b17a616e3..2853ffad38d6 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -1289,27 +1289,23 @@ package body Exp_Put_Image is ---------------------- function Build_Image_Call (N : Node_Id) return Node_Id is - -- For T'[[Wide_]Wide_]Image (X) Generate an Expression_With_Actions - -- node: + -- For Typ'[[Wide_]Wide_]Image (X) generate: -- - -- do - -- S : Buffer; - -- U_Type'Put_Image (S, X); - -- Result : constant [[Wide_]Wide_]String := - -- [[Wide_[Wide_]]Get (S); - -- Destroy (S); - -- in Result end + -- S : Buffer_Type; + -- U_Typ'Put_Image (S, X); + -- [[Wide_[Wide_]]Get (S) -- - -- where U_Type is the underlying type, as needed to bypass privacy. + -- where U_Typ is the underlying type, as needed to bypass privacy. + + Loc : constant Source_Ptr := Sloc (N); + U_Typ : constant Entity_Id := Underlying_Type (Entity (Prefix (N))); + + Sink_Entity : constant Entity_Id := Make_Temporary (Loc, 'S'); - Loc : constant Source_Ptr := Sloc (N); - U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N))); - Sink_Entity : constant Entity_Id := - Make_Temporary (Loc, 'S'); Sink_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Sink_Entity, - Object_Definition => + Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Type), Loc)); Image_Prefix : constant Node_Id := @@ -1317,75 +1313,47 @@ package body Exp_Put_Image is Put_Im : constant Node_Id := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (U_Type, Loc), + Prefix => New_Occurrence_Of (U_Typ, Loc), Attribute_Name => Name_Put_Image, Expressions => New_List ( New_Occurrence_Of (Sink_Entity, Loc), Image_Prefix)); - Result_Entity : constant Entity_Id := - Make_Temporary (Loc, 'R'); - - subtype Image_Name_Id is Name_Id with Static_Predicate => - Image_Name_Id in Name_Image | Name_Wide_Image | Name_Wide_Wide_Image; - -- Attribute names that will be mapped to the corresponding result types - -- and functions. - - Attribute_Name_Id : constant Name_Id := - (if Attribute_Name (N) = Name_Img then Name_Image - else Attribute_Name (N)); - - Result_Typ : constant Entity_Id := - (case Image_Name_Id'(Attribute_Name_Id) is - when Name_Image => Stand.Standard_String, - when Name_Wide_Image => Stand.Standard_Wide_String, - when Name_Wide_Wide_Image => Stand.Standard_Wide_Wide_String); - Get_Func_Id : constant RE_Id := - (case Image_Name_Id'(Attribute_Name_Id) is - when Name_Image => RE_Get, - when Name_Wide_Image => RE_Wide_Get, - when Name_Wide_Wide_Image => RE_Wide_Wide_Get); - - Result_Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Result_Entity, - Object_Definition => - New_Occurrence_Of (Result_Typ, Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (Get_Func_Id), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Sink_Entity, Loc)))); + + Get_Func_Id : constant RE_Id := + (case Get_Attribute_Id (Attribute_Name (N)) is + when Attribute_Img => RE_Get, + when Attribute_Image => RE_Get, + when Attribute_Wide_Image => RE_Wide_Get, + when Attribute_Wide_Wide_Image => RE_Wide_Wide_Get, + when others => raise Program_Error); + Actions : List_Id; -- Start of processing for Build_Image_Call begin - if Is_Class_Wide_Type (U_Type) then + if Is_Class_Wide_Type (U_Typ) then Actions := New_List (Sink_Decl); Put_Specific_Type_Name_Qualifier (Loc, Stms => Actions, Tagged_Obj => Image_Prefix, Buffer_Name => New_Occurrence_Of (Sink_Entity, Loc), - Is_Interface_Type => Is_Interface (U_Type)); + Is_Interface_Type => Is_Interface (U_Typ)); Append_To (Actions, Put_Im); - Append_To (Actions, Result_Decl); + else - Actions := New_List (Sink_Decl, Put_Im, Result_Decl); + Actions := New_List (Sink_Decl, Put_Im); end if; - -- To avoid leaks, we need to manage the secondary stack, because Get is - -- returning a String allocated thereon. It might be cleaner to let the - -- normal mechanisms for functions returning on the secondary stack call - -- Set_Uses_Sec_Stack, but this expansion of 'Image is happening too - -- late for that. + Insert_Actions (N, Actions); - Set_Uses_Sec_Stack (Current_Scope); - - return Make_Expression_With_Actions (Loc, - Actions => Actions, - Expression => New_Occurrence_Of (Result_Entity, Loc)); + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Get_Func_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Sink_Entity, Loc))); end Build_Image_Call; ------------------------------ diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads index 9d6004263845..09a68b8426bc 100644 --- a/gcc/ada/exp_put_image.ads +++ b/gcc/ada/exp_put_image.ads @@ -89,7 +89,9 @@ package Exp_Put_Image is function Build_Image_Call (N : Node_Id) return Node_Id; -- N is a call to T'[[Wide_]Wide_]Image, and this translates it into the -- appropriate code to call T'Put_Image into a buffer and then extract the - -- [[wide] wide] string from the buffer. + -- [[wide] wide] string from the buffer. N must be wrapped in a transient + -- scope before invoking the function because the buffer is controlled and + -- the extraction is done on the secondary stack. procedure Preload_Root_Buffer_Type (Compilation_Unit : Node_Id); -- Call RTE (RE_Root_Buffer_Type) if necessary, to load the packages diff --git a/gcc/testsuite/gnat.dg/put_image2.adb b/gcc/testsuite/gnat.dg/put_image2.adb new file mode 100644 index 000000000000..438c6533bf0c --- /dev/null +++ b/gcc/testsuite/gnat.dg/put_image2.adb @@ -0,0 +1,18 @@ +-- { dg-do run } +-- { dg-options "-gnat2022" } + +procedure Put_Image2 is + + type T is array (1 .. 13) of Integer; + + function "&" (Left : T; Right : T) return T is (others => 2); + + function To_Virtual_String (Item : String) return T is (others => 0); + + procedure F (S : T) is null; + + X : array (1 .. 1) of Integer := [others => 0]; + +begin + F ((others => 0) & To_Virtual_String (X'Image)); +end;
