https://gcc.gnu.org/g:19b33d2388a7a3df194297e7941f02baafcc6777
commit r15-10745-g19b33d2388a7a3df194297e7941f02baafcc6777 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 | 96 ++++++++++++------------------------ gcc/ada/exp_put_image.ads | 4 +- gcc/testsuite/gnat.dg/put_image2.adb | 18 +++++++ 4 files changed, 57 insertions(+), 65 deletions(-) diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index c7cf06ba444f..6bb8d876ac2e 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -30,6 +30,7 @@ with Einfo; use Einfo; 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; @@ -1047,6 +1048,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 3859aebb0264..93d04c9c174a 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -1236,27 +1236,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 := @@ -1264,44 +1260,20 @@ 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; function Put_String_Exp (String_Exp : Node_Id; @@ -1348,7 +1320,7 @@ package body Exp_Put_Image is -- Start of processing for Build_Image_Call begin - if Is_Class_Wide_Type (U_Type) then + if Is_Class_Wide_Type (U_Typ) then -- For interface types we must generate code to displace the pointer -- to the object to reference the base of the underlying object. @@ -1359,7 +1331,7 @@ package body Exp_Put_Image is -- Note that Image_Prefix'Address is recursively expanded into a -- call to Ada.Tags.Base_Address (Image_Prefix'Address). - if Is_Interface (U_Type) then + if Is_Interface (U_Typ) then Tag_Node := Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), @@ -1400,24 +1372,20 @@ package body Exp_Put_Image is (Sink_Decl, Specific_Type_Name, Qualification, - Put_Im, - Result_Decl); + Put_Im); end; + 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 31e71fef4f9f..a86d8c5e2588 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;
