[Ada] Disable name generation for External_Tag and Expanded_Name

In order to avoid exposing internal names of tagged types in the
binary code generated by the compiler this enhancement facilitates
initializes the External_Tag of a tagged type with an empty string
when pragma No_Tagged_Streams is applicable to the tagged type, and
facilitates initializes its Expanded_Name with an empty string when
pragma Discard_Names is applicable to the tagged type.

This enhancement can be verified by means of the following small
test:

package Library_Level_Test is
   type Typ_01 is tagged null record;    --  Case 1: No pragmas

   type Typ_02 is tagged null record;    --  Case 2: Discard_Names
   pragma Discard_Names (Typ_02);

   pragma No_Tagged_Streams;
   type Typ_03 is tagged null record;    --  Case 3: No_Tagged_Streams

   type Typ_04 is tagged null record;    --  Case 4: Both pragmas
   pragma Discard_Names (Typ_04);
end;

Commands:
  gcc -c -gnatD library_level_test.ads
  grep "\.TYP_" library_level_test.ads.dg

Output:
     "LIBRARY_LEVEL_TEST.TYP_01["00"]";
     "LIBRARY_LEVEL_TEST.TYP_02["00"]";
     "LIBRARY_LEVEL_TEST.TYP_03["00"]";

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

gcc/ada/

	* exp_disp.adb (Make_DT): Initialize the External_Tag with an empty
	string when pragma No_Tagged_Streams is applicable to the tagged type,
	and initialize the Expanded_Name with an empty string when pragma
	Discard_Names is applicable to the tagged type.

From-SVN: r260528

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7578da1c2feccd89373b70880bb95f399acc38a6..ebfe6d4417c43834c42df92723ec0439afabdeac 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-05-22  Javier Miranda  <miranda@adacore.com>
+
+       * exp_disp.adb (Make_DT): Initialize the External_Tag with an empty
+       string when pragma No_Tagged_Streams is applicable to the tagged type,
+       and initialize the Expanded_Name with an empty string when pragma
+       Discard_Names is applicable to the tagged type.
+
 2018-05-22  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_ch6.adb (Check_Conformance): Add RM reference for rule that a

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index c9181e592334c5c95f4b40c4615976290d4ea8b3..2840c8ef91fdfd1d0480ff0eeaf98c976593079f 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -4511,7 +4511,8 @@ package body Exp_Disp is
       DT_Aggr_List       : List_Id;
       DT_Constr_List     : List_Id;
       DT_Ptr             : Entity_Id;
-      Exname             : Entity_Id;
+      Expanded_Name      : Entity_Id;
+      External_Tag_Name  : Entity_Id;
       HT_Link            : Entity_Id;
       ITable             : Node_Id;
       I_Depth            : Nat := 0;
@@ -4590,12 +4591,44 @@ package body Exp_Disp is
          end if;
       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);
+      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;
 
       --  Initialize Parent_Typ handling private types
 
@@ -5000,20 +5033,72 @@ package body Exp_Disp is
          end if;
       end if;
 
-      --  Generate: Exname : constant String := full_qualified_name (typ);
+      --  Generate: Expanded_Name : constant String := "";
+
+      if Global_Discard_Names or else Discard_Names (Typ) then
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Expanded_Name,
+             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);
       --  The type itself may be an anonymous parent type, so use the first
       --  subtype to have a user-recognizable name.
 
-      Append_To (Result,
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Exname,
-          Constant_Present    => True,
-          Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
-          Expression =>
-            Make_String_Literal (Loc,
-              Strval => Fully_Qualified_Name_String (First_Subtype (Typ)))));
-      Set_Is_Statically_Allocated (Exname);
-      Set_Is_True_Constant (Exname);
+      else
+         Append_To (Result,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Expanded_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 (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;
 
       --  Declare the object used by Ada.Tags.Register_Tag
 
@@ -5033,8 +5118,8 @@ package body Exp_Disp is
       --           (Idepth             => I_Depth,
       --            Access_Level       => Type_Access_Level (Typ),
       --            Alignment          => Typ'Alignment,
-      --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
-      --            External_Tag       => Cstring_Ptr!(Exname'Address))
+      --            Expanded_Name      => Cstring_Ptr!(ExpandedName'Address))
+      --            External_Tag       => Cstring_Ptr!(ExternalName'Address))
       --            HT_Link            => HT_Link'Address,
       --            Transportable      => <<boolean-value>>,
       --            Is_Abstract        => <<boolean-value>>,
@@ -5104,9 +5189,19 @@ 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 (Exname, Loc),
+            Prefix         => New_Occurrence_Of (Expanded_Name, 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 :=
@@ -5134,7 +5229,7 @@ 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.
 
-      if not Is_Library_Level_Entity (Typ)
+      elsif not Is_Library_Level_Entity (Typ)
         and then not Has_External_Tag_Rep_Clause (Typ)
       then
          declare
@@ -5189,6 +5284,9 @@ package body Exp_Disp is
                            Right_Opnd =>
                              Make_String_Literal (Loc, Str2_Id)))));
 
+            --  Generate:
+            --    Exname : constant String := Str1 & Str2;
+
             else
                Append_To (Result,
                  Make_Object_Declaration (Loc,
@@ -5234,7 +5332,8 @@ package body Exp_Disp is
                New_Node :=
                  Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
                    Make_Attribute_Reference (Loc,
-                     Prefix         => New_Occurrence_Of (Exname, Loc),
+                     Prefix         => New_Occurrence_Of
+                                         (External_Tag_Name, Loc),
                      Attribute_Name => Name_Address));
             else
                Old_Val := Strval (Expr_Value_S (Expression (Def)));
@@ -6406,10 +6505,14 @@ package body Exp_Disp is
       --  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.
 
+      --  We cannot perform this check if the generation of its expanded name
+      --  was discarded.
+
       if not No_Run_Time_Mode
         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,