procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Restrict initialization of External_Tag and Expanded_Name

Browse source 
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
This commit is contained in:
Javier Miranda 2018-05-23 10:22:47 +00:00 • committed by Pierre-Marie de Rodat
parent 6734617ced
commit 51ab2a39e9
5 changed files with 69 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
gcc/ada/ChangeLog
View file

@ -1,3 +1,14 @@
2018-05-23 Javier Miranda <miranda@adacore.com>
* 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.
2018-05-23 Maroua Maalej <maalej@adacore.com>
* sem_spark.adb: Fix of some permission rules of pointers in SPARK.

5
gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
View file

@ -875,6 +875,11 @@ be suppressed. In the presence of this pragma, the Image attribute
provides the image of the Pos of the literal, and Value accepts
Pos values.
For tagged types, when pragmas ``Discard_Names`` and ``No_Tagged_Streams``
simultaneously apply, their Expanded_Name and External_Tag are initialized
with empty strings. This is useful to avoid exposing entity names at binary
level.
*
"The result of the ``Task_Identification.Image``
attribute. See C.7.1(7)."

5
gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
View file

@ -3892,6 +3892,11 @@ and derived types of this type inherit the pragma automatically, so the effect
applies to a complete hierarchy (this is necessary to deal with the class-wide
dispatching versions of the stream routines).
When pragmas ``Discard_Names`` and ``No_Tagged_Streams`` are simultaneously
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.
Pragma Normalize_Scalars
========================

141
gcc/ada/exp_disp.adb
View file

@ -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,

12
gcc/ada/gnat_rm.texi
View file

@ -21,7 +21,7 @@
@copying
@quotation
GNAT Reference Manual , Apr 20, 2018
GNAT Reference Manual , Apr 23, 2018
AdaCore
@ -5328,6 +5328,11 @@ and derived types of this type inherit the pragma automatically, so the effect
applies to a complete hierarchy (this is necessary to deal with the class-wide
dispatching versions of the stream routines).
When pragmas @code{Discard_Names} and @code{No_Tagged_Streams} are simultaneously
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.
@node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{a8}
@section Pragma Normalize_Scalars
@ -17143,6 +17148,11 @@ be suppressed. In the presence of this pragma, the Image attribute
provides the image of the Pos of the literal, and Value accepts
Pos values.
For tagged types, when pragmas @code{Discard_Names} and @code{No_Tagged_Streams}
simultaneously apply, their Expanded_Name and External_Tag are initialized
with empty strings. This is useful to avoid exposing entity names at binary
level.
@itemize *