[Ada] Restrict initialization of External_Tag and Expanded_Name

2018-05-23  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_disp.adb (Make_DT): Restrict the initialization of
	External_Tag and Expanded_Name to an empty string to the case where
	both pragmas apply (i.e. No_Tagged_Streams and Discard_Names), since
	restricted runtimes are compiled with pragma Discard_Names.
	* doc/gnat_rm/implementation_defined_pragmas.rst,
	doc/gnat_rm/implementation_defined_characteristics.rst: Add
	documentation.
	* gnat_rm.texi: Regenerate.

From-SVN: r260584

1 files changed, 37 insertions, 104 deletions

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 84add60..bded4c1 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -4480,6 +4480,21 @@ package body Exp_Disp is
       Result    : constant List_Id := New_List;
       Tname     : constant Name_Id := Chars (Typ);
 
+      --  When pragmas Discard_Names and No_Tagged_Streams simultaneously apply
+      --  we initialize the Expanded_Name and the External_Tag of this tagged
+      --  type with an empty string. This is useful to avoid exposing entity
+      --  names at binary level. It can be done when both pragmas apply because
+      --    (1) Discard_Names allows initializing Expanded_Name with an
+      --        implementation defined value (Ada RM Section C.5 (7/2)).
+      --    (2) External_Tag (combined with Internal_Tag) is used for object
+      --        streaming and No_Tagged_Streams inhibits the generation of
+      --        streams.
+
+      Discard_Names : constant Boolean :=
+                        Present (No_Tagged_Streams_Pragma (Typ))
+                          and then (Global_Discard_Names
+                                      or else Einfo.Discard_Names (Typ));
+
       --  The following name entries are used by Make_DT to generate a number
       --  of entities related to a tagged type. These entities may be generated
       --  in a scope other than that of the tagged type declaration, and if
@@ -4511,8 +4526,7 @@ package body Exp_Disp is
       DT_Aggr_List       : List_Id;
       DT_Constr_List     : List_Id;
       DT_Ptr             : Entity_Id;
-      Expanded_Name      : Entity_Id;
-      External_Tag_Name  : Entity_Id;
+      Exname             : Entity_Id;
       HT_Link            : Entity_Id;
       ITable             : Node_Id;
       I_Depth            : Nat := 0;
@@ -4591,44 +4605,12 @@ package body Exp_Disp is
          end if;
       end if;
 
-      DT            := Make_Defining_Identifier (Loc, Name_DT);
-      Expanded_Name := Make_Defining_Identifier (Loc, Name_Exname);
-      HT_Link       := Make_Defining_Identifier (Loc, Name_HT_Link);
-      Predef_Prims  := Make_Defining_Identifier (Loc, Name_Predef_Prims);
-      SSD           := Make_Defining_Identifier (Loc, Name_SSD);
-      TSD           := Make_Defining_Identifier (Loc, Name_TSD);
-
-      --  Expanded_Name
-      --  -------------
-
-      --  We generally initialize the Expanded_Name and the External_Tag of
-      --  tagged types with the same name, unless pragmas Discard_Names or
-      --  No_Tagged_Streams apply: Discard_Names allows us to initialize its
-      --  Expanded_Name with an empty string because in such a case it's
-      --  value is implementation defined (Ada RM Section C.5(7/2)); pragma
-      --  No_Tagged_Streams inhibits the generation of stream routines and
-      --  we initialize its External_Tag with an empty string since Ada.Tags
-      --  services Internal_Tag and External_Tag are mainly used with streams.
-
-      --  Small optimization: when both pragmas apply then there is no need to
-      --  declare two objects initialized with empty strings (since the two
-      --  aggregate components can be initialized with the same object).
-
-      if (Global_Discard_Names or else Discard_Names (Typ))
-        and then Present (No_Tagged_Streams_Pragma (Typ))
-      then
-         External_Tag_Name := Expanded_Name;
-
-      elsif Global_Discard_Names
-        or else Discard_Names (Typ)
-        or else Present (No_Tagged_Streams_Pragma (Typ))
-      then
-         External_Tag_Name :=
-           Make_Defining_Identifier (Loc,
-             New_External_Name (Tname, 'N', Suffix_Index => -1));
-      else
-         External_Tag_Name := Expanded_Name;
-      end if;
+      DT           := Make_Defining_Identifier (Loc, Name_DT);
+      Exname       := Make_Defining_Identifier (Loc, Name_Exname);
+      HT_Link      := Make_Defining_Identifier (Loc, Name_HT_Link);
+      Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
+      SSD          := Make_Defining_Identifier (Loc, Name_SSD);
+      TSD          := Make_Defining_Identifier (Loc, Name_TSD);
 
       --  Initialize Parent_Typ handling private types
 
@@ -5033,27 +5015,25 @@ package body Exp_Disp is
          end if;
       end if;
 
-      --  Generate:
-      --    Expanded_Name : constant String := "";
+      --  Generate: Expanded_Name : constant String := "";
 
-      if Global_Discard_Names or else Discard_Names (Typ) then
+      if Discard_Names then
          Append_To (Result,
            Make_Object_Declaration (Loc,
-             Defining_Identifier => Expanded_Name,
+             Defining_Identifier => Exname,
              Constant_Present    => True,
              Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
              Expression =>
                Make_String_Literal (Loc, "")));
 
-      --  Generate:
-      --    Expanded_Name : constant String := full_qualified_name (typ);
+      --  Generate: Exname : constant String := full_qualified_name (typ);
       --  The type itself may be an anonymous parent type, so use the first
       --  subtype to have a user-recognizable name.
 
       else
          Append_To (Result,
            Make_Object_Declaration (Loc,
-             Defining_Identifier => Expanded_Name,
+             Defining_Identifier => Exname,
              Constant_Present    => True,
              Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
              Expression =>
@@ -5061,46 +5041,8 @@ package body Exp_Disp is
                  Fully_Qualified_Name_String (First_Subtype (Typ)))));
       end if;
 
-      Set_Is_Statically_Allocated (Expanded_Name);
-      Set_Is_True_Constant (Expanded_Name);
-
-      --  Generate the External_Tag name only when it is required (since in
-      --  most cases we can initialize Expanded_Name and External_Tag using
-      --  the same object).
-
-      if Expanded_Name /= External_Tag_Name then
-
-         --  Generate:
-         --    External_Tag_Name : constant String := "";
-
-         if Present (No_Tagged_Streams_Pragma (Typ)) then
-            Append_To (Result,
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => External_Tag_Name,
-                Constant_Present    => True,
-                Object_Definition   =>
-                  New_Occurrence_Of (Standard_String, Loc),
-                Expression          => Make_String_Literal (Loc, "")));
-
-         --  Generate:
-         --    External_Tag_Name : constant String :=
-         --                          full_qualified_name (typ);
-
-         else
-            Append_To (Result,
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => External_Tag_Name,
-                Constant_Present    => True,
-                Object_Definition   =>
-                  New_Occurrence_Of (Standard_String, Loc),
-                Expression          =>
-                  Make_String_Literal (Loc,
-                    Fully_Qualified_Name_String (First_Subtype (Typ)))));
-         end if;
-
-         Set_Is_Statically_Allocated (External_Tag_Name);
-         Set_Is_True_Constant (External_Tag_Name);
-      end if;
+      Set_Is_Statically_Allocated (Exname);
+      Set_Is_True_Constant (Exname);
 
       --  Declare the object used by Ada.Tags.Register_Tag
 
@@ -5120,8 +5062,8 @@ package body Exp_Disp is
       --           (Idepth             => I_Depth,
       --            Access_Level       => Type_Access_Level (Typ),
       --            Alignment          => Typ'Alignment,
-      --            Expanded_Name      => Cstring_Ptr!(ExpandedName'Address))
-      --            External_Tag       => Cstring_Ptr!(ExternalName'Address))
+      --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
+      --            External_Tag       => Cstring_Ptr!(Exname'Address))
       --            HT_Link            => HT_Link'Address,
       --            Transportable      => <<boolean-value>>,
       --            Is_Abstract        => <<boolean-value>>,
@@ -5191,18 +5133,9 @@ package body Exp_Disp is
       Append_To (TSD_Aggr_List,
         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
           Make_Attribute_Reference (Loc,
-            Prefix         => New_Occurrence_Of (Expanded_Name, Loc),
+            Prefix         => New_Occurrence_Of (Exname, Loc),
             Attribute_Name => Name_Address)));
 
-      --  External_Tag when pragma No_Tagged_Streams applies
-
-      if Present (No_Tagged_Streams_Pragma (Typ)) then
-         New_Node :=
-           Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
-             Make_Attribute_Reference (Loc,
-               Prefix         => New_Occurrence_Of (External_Tag_Name, Loc),
-               Attribute_Name => Name_Address));
-
       --  External_Tag of a local tagged type
 
       --     <typ>A : constant String :=
@@ -5230,7 +5163,8 @@ package body Exp_Disp is
       --  specified. That's an odd case for which we have already issued a
       --  warning, where we will not be able to compute the internal tag.
 
-      elsif not Is_Library_Level_Entity (Typ)
+      if not Discard_Names
+        and then not Is_Library_Level_Entity (Typ)
         and then not Has_External_Tag_Rep_Clause (Typ)
       then
          declare
@@ -5333,8 +5267,7 @@ package body Exp_Disp is
                New_Node :=
                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
                    Make_Attribute_Reference (Loc,
-                     Prefix         =>
-                       New_Occurrence_Of (External_Tag_Name, Loc),
+                     Prefix         => New_Occurrence_Of (Exname, Loc),
                      Attribute_Name => Name_Address));
             else
                Old_Val := Strval (Expr_Value_S (Expression (Def)));
@@ -6501,7 +6434,7 @@ package body Exp_Disp is
       --  applies to Ada 2005 (and Ada 2012). It might be argued that it is
       --  a desirable check to add in Ada 95 mode, but we hesitate to make
       --  this change, as it would be incompatible, and could conceivably
-      --  cause a problem in existing Aa 95 code.
+      --  cause a problem in existing Ada 95 code.
 
       --  We check for No_Run_Time_Mode here, because we do not want to pick
       --  up the RE_Check_TSD entity and call it in No_Run_Time mode.
@@ -6510,10 +6443,10 @@ package body Exp_Disp is
       --  was discarded.
 
       if not No_Run_Time_Mode
+        and then not Discard_Names
         and then Ada_Version >= Ada_2005
         and then RTE_Available (RE_Check_TSD)
         and then not Duplicated_Tag_Checks_Suppressed (Typ)
-        and then not (Global_Discard_Names or else Discard_Names (Typ))
       then
          Append_To (Elab_Code,
            Make_Procedure_Call_Statement (Loc,