[COMMITTED 05/31] ada: Do not leak tagged type names when Discard_Names is enabled

["Marc Poulhiès" <poulhies@adacore.com>]

From: Piotr Trojanek <trojanek@adacore.com>

When both pragmas Discard_Names and No_Tagged_Streams apply to a tagged
type, the intended behavior is to prevent type names from leaking into
object code, as documented in GNAT RM.

However, while Discard_Names can be used as a configuration pragma,
No_Tagged_Streams must be applied to each type separately. This patch
enables the use of restriction No_Streams, which can be activated
globally, instead of No_Tagged_Streams on individual types.

When no tagged stream object can be created and allocated, then routines
that make use of the External_Tag won't be used.

gcc/ada/

	* doc/gnat_rm/implementation_defined_pragmas.rst
	(No_Tagged_Streams): Document how to avoid exposing entity names
	for the entire partition.
	* exp_disp.adb (Make_DT): Make use of restriction No_Streams.
	* exp_put_image.adb (Build_Record_Put_Image_Procedure): Respect
	Discard_Names in the generated Put_Image procedure.
	* gnat_rm.texi: Regenerate.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 .../implementation_defined_pragmas.rst        |  6 ++++
 gcc/ada/exp_disp.adb                          |  5 +--
 gcc/ada/exp_put_image.adb                     | 34 ++++++++++++++-----
 gcc/ada/gnat_rm.texi                          |  6 ++++
 4 files changed, 41 insertions(+), 10 deletions(-)

diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 0661670e047..7e4dd935342 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -4000,6 +4000,12 @@ applied to a tagged type its Expanded_Name and External_Tag are initialized
 with empty strings. This is useful to avoid exposing entity names at binary
 level but has a negative impact on the debuggability of tagged types.
 
+Alternatively, when pragmas ``Discard_Names`` and ``Restrictions (No_Streams)``
+simultanously apply to a tagged type, its Expanded_Name and External_Tag are
+also initialized with empty strings. In particular, both these pragmas can be
+applied as configuration pragmas to avoid exposing entity names at binary
+level for the entire parition.
+
 Pragma Normalize_Scalars
 ========================
 
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 601d463a8b0..66be77c9ffc 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -4600,8 +4600,9 @@ package body Exp_Disp is
       --        streams.
 
       Discard_Names : constant Boolean :=
-                        Present (No_Tagged_Streams_Pragma (Typ))
-                          and then
+        (Present (No_Tagged_Streams_Pragma (Typ))
+           or else Restriction_Active (No_Streams))
+          and then
         (Global_Discard_Names or else Einfo.Entities.Discard_Names (Typ));
 
       --  The following name entries are used by Make_DT to generate a number
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 09fbfa75eeb..94299e39661 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -44,6 +44,7 @@ with Sinfo.Nodes;    use Sinfo.Nodes;
 with Sinfo.Utils;    use Sinfo.Utils;
 with Snames;         use Snames;
 with Stand;
+with Stringt;        use Stringt;
 with Tbuild;         use Tbuild;
 with Ttypes;         use Ttypes;
 with Uintp;          use Uintp;
@@ -825,14 +826,31 @@ package body Exp_Put_Image is
               Make_Raise_Program_Error (Loc,
               Reason => PE_Explicit_Raise));
          else
-            Append_To (Stms,
-              Make_Procedure_Call_Statement (Loc,
-                Name => New_Occurrence_Of (RTE (RE_Put_Image_Unknown), Loc),
-                Parameter_Associations => New_List
-                  (Make_Identifier (Loc, Name_S),
-                   Make_String_Literal (Loc,
-                     Fully_Qualified_Name_String
-                       (Btyp, Append_NUL => False)))));
+            declare
+               Type_Name : String_Id;
+            begin
+               --  If aspect Discard_Names is enabled the intention is to
+               --  prevent type names from leaking into object file. Instead,
+               --  we emit string that is different from the ones from the
+               --  default implementations of the Put_Image attribute.
+
+               if Global_Discard_Names or else Discard_Names (Typ) then
+                  Start_String;
+                  Store_String_Chars ("(DISCARDED TYPE NAME)");
+                  Type_Name := End_String;
+               else
+                  Type_Name :=
+                    Fully_Qualified_Name_String (Btyp, Append_NUL => False);
+               end if;
+
+               Append_To (Stms,
+                 Make_Procedure_Call_Statement (Loc,
+                   Name => New_Occurrence_Of (RTE (RE_Put_Image_Unknown), Loc),
+                   Parameter_Associations => New_List
+                     (Make_Identifier (Loc, Name_S),
+                        Make_String_Literal (Loc,
+                          Type_Name))));
+            end;
          end if;
       elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 4dbbb036a25..4ff1de42db2 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -5535,6 +5535,12 @@ applied to a tagged type its Expanded_Name and External_Tag are initialized
 with empty strings. This is useful to avoid exposing entity names at binary
 level but has a negative impact on the debuggability of tagged types.
 
+Alternatively, when pragmas @code{Discard_Names} and @code{Restrictions (No_Streams)}
+simultanously apply to a tagged type, its Expanded_Name and External_Tag are
+also initialized with empty strings. In particular, both these pragmas can be
+applied as configuration pragmas to avoid exposing entity names at binary
+level for the entire parition.
+
 @node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas
 @anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{b0}
 @section Pragma Normalize_Scalars
-- 
2.43.2