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.
Tested on x86-64/Linux, applied on the mainline and 15 branch.
2026-01-28 Eric Botcazou <[email protected]>
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.
2026-01-28 Eric Botcazou <[email protected]>
* gnat.dg/put_image2.adb: New test.
--
Eric Botcazoudiff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 8dfb0a8321e..fd5ddcb4cb4 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 a13b17a616e..2853ffad38d 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 9d600426384..09a68b8426b 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
-- { 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;
