From: Steve Baird <baird@adacore.com>
Date: Wed, 19 May 2021 01:26:24 +0000 (-0700)
Subject: [Ada] Improve interactions between DSA and Put_Image routines for tagged types
X-Git-Tag: basepoints/gcc-13~6197
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=2d71668e64c4b20aec823dbe5a1feb6338d527a2;p=thirdparty%2Fgcc.git

[Ada] Improve interactions between DSA and Put_Image routines for tagged types

gcc/ada/

	* exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Add
	TSS_Put_Image to list of predefined primitives that need special
	treatment.
	(Build_General_Calling_Stubs, Build_Subprogram_Receiving_Stubs):
	Remove previous hack for dealing with TSS_Put_Image procedures.
---

diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 35ccf9d3731a..5cb8fb54993e 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -1424,6 +1424,7 @@ package body Exp_Dist is
               and then Chars (Current_Primitive) /= Name_uAlignment
               and then not
                 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
+                 Is_TSS (Current_Primitive, TSS_Put_Image)     or else
                  Is_TSS (Current_Primitive, TSS_Stream_Input)  or else
                  Is_TSS (Current_Primitive, TSS_Stream_Output) or else
                  Is_TSS (Current_Primitive, TSS_Stream_Read)   or else
@@ -4211,14 +4212,6 @@ package body Exp_Dist is
          --  Used only for the PolyORB case
 
       begin
-         --  workaround for later failures in Exp_Util.Find_Prim_Op
-         if Is_TSS (Defining_Unit_Name (Spec), TSS_Put_Image) then
-            Append_To (Statements,
-                       Make_Raise_Program_Error (Loc,
-                         Reason => PE_Stream_Operation_Not_Allowed));
-            return;
-         end if;
-
          --  The general form of a calling stub for a given subprogram is:
 
          --    procedure X (...) is P : constant Partition_ID :=
@@ -4734,11 +4727,11 @@ package body Exp_Dist is
          --  Formal parameter for receiving stubs: a descriptor for an incoming
          --  request.
 
-         Decls : List_Id := New_List;
+         Decls : constant List_Id := New_List;
          --  All the parameters will get declared before calling the real
          --  subprograms. Also the out parameters will be declared.
 
-         Statements : List_Id := New_List;
+         Statements : constant List_Id := New_List;
 
          Extra_Formal_Statements : constant List_Id := New_List;
          --  Statements concerning extra formal parameters
@@ -5173,19 +5166,6 @@ package body Exp_Dist is
                  Parameter_Type      =>
                    New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
 
-         --  workaround for later failures in Exp_Util.Find_Prim_Op
-         if Is_TSS (Defining_Unit_Name (Specification (Vis_Decl)),
-                    TSS_Put_Image)
-         then
-            --  drop everything on the floor
-            Decls := New_List;
-            Statements := New_List;
-            Excep_Handlers := New_List;
-            Append_To (Statements,
-                       Make_Raise_Program_Error (Loc,
-                         Reason => PE_Stream_Operation_Not_Allowed));
-         end if;
-
          return
            Make_Subprogram_Body (Loc,
              Specification              => Subp_Spec,