Commit 8e28429a by Bob Duff Committed by Pierre-Marie de Rodat

[Ada] No_Stream_Optimizations ignored for 'Class'Input

This patch fixes a bug in which if pragma Restrictions
(No_Stream_Optimizations) is in effect, it is ignored for T'Class'Input.
Revision 251886  was causing the compiler to bypass
No_Stream_Optimizations.

2019-07-05  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_attr.adb (Input): Take the No_Stream_Optimizations
	restriction into account.

From-SVN: r273103
parent 584b5290
2019-07-05 Bob Duff <duff@adacore.com>
* exp_attr.adb (Input): Take the No_Stream_Optimizations
restriction into account.
2019-07-05 Claire Dross <dross@adacore.com> 2019-07-05 Claire Dross <dross@adacore.com>
* libgnat/a-cofove.ads, libgnat/a-cofove.adb: Definite formal * libgnat/a-cofove.ads, libgnat/a-cofove.adb: Definite formal
......
...@@ -3997,11 +3997,13 @@ package body Exp_Attr is ...@@ -3997,11 +3997,13 @@ package body Exp_Attr is
declare declare
Rtyp : constant Entity_Id := Root_Type (P_Type); Rtyp : constant Entity_Id := Root_Type (P_Type);
Expr : Node_Id; Get_Tag : Node_Id; -- expression to read the 'Tag
Expr : Node_Id; -- call to Descendant_Tag
begin begin
-- Read the internal tag (RM 13.13.2(34)) and use it to -- Read the internal tag (RM 13.13.2(34)) and use it to
-- initialize a dummy tag value. We used to generate: -- initialize a dummy tag value. We used to unconditionally
-- generate:
-- --
-- Descendant_Tag (String'Input (Strm), P_Type); -- Descendant_Tag (String'Input (Strm), P_Type);
-- --
...@@ -4012,6 +4014,11 @@ package body Exp_Attr is ...@@ -4012,6 +4014,11 @@ package body Exp_Attr is
-- String_Input_Blk_IO, except that if the String is -- String_Input_Blk_IO, except that if the String is
-- absurdly long, it raises an exception. -- absurdly long, it raises an exception.
-- --
-- However, if the No_Stream_Optimizations restriction
-- is active, we disable this unnecessary attempt at
-- robustness; we really need to read the string
-- character-by-character.
--
-- This value is used only to provide a controlling -- This value is used only to provide a controlling
-- argument for the eventual _Input call. Descendant_Tag is -- argument for the eventual _Input call. Descendant_Tag is
-- called rather than Internal_Tag to ensure that we have a -- called rather than Internal_Tag to ensure that we have a
...@@ -4026,18 +4033,30 @@ package body Exp_Attr is ...@@ -4026,18 +4033,30 @@ package body Exp_Attr is
-- this constant in Cntrl, but this caused a secondary stack -- this constant in Cntrl, but this caused a secondary stack
-- leak. -- leak.
if Restriction_Active (No_Stream_Optimizations) then
Get_Tag :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_String, Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Relocate_Node (Duplicate_Subexpr (Strm))));
else
Get_Tag :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_String_Input_Tag), Loc),
Parameter_Associations => New_List (
Relocate_Node (Duplicate_Subexpr (Strm))));
end if;
Expr := Expr :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Function_Call (Loc, Get_Tag,
Name =>
New_Occurrence_Of
(RTE (RE_String_Input_Tag), Loc),
Parameter_Associations => New_List (
Relocate_Node (Duplicate_Subexpr (Strm)))),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (P_Type, Loc), Prefix => New_Occurrence_Of (P_Type, Loc),
Attribute_Name => Name_Tag))); Attribute_Name => Name_Tag)));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment