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 --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 8dfb0a8321e37485726f9b29839609e89e570104..fd5ddcb4cb44a6d77dc449efb908146facabf369 100644 (file)
--- 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 a13b17a616e3fd06f1b06febefb9df29b9696c49..2853ffad38d60b6bc5245e2c4a1389a48ebb6522 100644 (file)
--- 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 9d6004263845356bad7e316c34544d2230e85668..09a68b8426bcbd64822e8b01f2292635fa38d654 100644 (file)
--- 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 (file)
index 0000000..438c653
--- /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;