diff options
author | Javier Miranda <miranda@adacore.com> | 2018-05-23 10:22:47 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2018-05-23 10:22:47 +0000 |
commit | 51ab2a39e9baae7fe1552daca02337050b11cfb6 (patch) | |
tree | c0156481dff84dfa33dbdcd1b561a7c3de7a4f19 /gcc/ada/exp_disp.adb | |
parent | 6734617cedcadfddfc33378ce824b4620381d91c (diff) | |
download | gcc-51ab2a39e9baae7fe1552daca02337050b11cfb6.zip gcc-51ab2a39e9baae7fe1552daca02337050b11cfb6.tar.gz gcc-51ab2a39e9baae7fe1552daca02337050b11cfb6.tar.bz2 |
[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
Diffstat (limited to 'gcc/ada/exp_disp.adb')
-rw-r--r-- | gcc/ada/exp_disp.adb | 141 |
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, |