Skip to content

R
riscv-gcc-1
Commit 6a237c45 by Arnaud Charlet
Options

[multiple changes] 

2017-09-08  Bob Duff  <duff@adacore.com>

	* s-ststop.ads, s-ststop.adb, rtsfind.ads (String_Input_Tag):
	New routine to read the Tag robustly.
	* exp_attr.adb (Input): Change the expansion of 'Input,
	in the class-wide case, to call String_Input_Tag instead of
	String_Input_Blk_IO.

2017-09-08  Arnaud Charlet  <charlet@adacore.com>

	* s-rident.ads (Restriction_Id): reorder enum
	literals, so that Pure_Barriers is no longer in range of the
	Cunit_Boolean_Restrictions subtype.

2017-09-08  Nicolas Roche  <roche@adacore.com>

	* a-taster.ads, a-taster.adb: Move to libgnarl
	* gcc-interface/Makefile.in: Remove obsolete targets. Code cleanups.
	Add support for files in libgnarl.

2017-09-08  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_N_Type_Conversion): Do not apply
	accessibility check to an interface conversion, whose purpose
	is to perform a pointer adjustment in a dispatching call.
	* exp_ch6.adb (Expand_Call_JHelper): Add accessibility checks
	when the actual is a construct that involves a dereference of an
	expression that includes a formal of the enclosing subprogram,
	In such cases, the accessibility level of the actual is that of
	the corresponding formal, which is passed in as an additional
	actual in the outer call.

From-SVN: r251886
parent 17d7aa85
Showing with 151 additions and 24 deletions
gcc/ada/ChangeLog
2017-09-08 Bob Duff <duff@adacore.com> 2017-09-08 Bob Duff <duff@adacore.com>
* s-ststop.ads, s-ststop.adb, rtsfind.ads (String_Input_Tag):
New routine to read the Tag robustly.
* exp_attr.adb (Input): Change the expansion of 'Input,
in the class-wide case, to call String_Input_Tag instead of
String_Input_Blk_IO.
2017-09-08 Arnaud Charlet <charlet@adacore.com>
* s-rident.ads (Restriction_Id): reorder enum
literals, so that Pure_Barriers is no longer in range of the
Cunit_Boolean_Restrictions subtype.
2017-09-08 Nicolas Roche <roche@adacore.com>
* a-taster.ads, a-taster.adb: Move to libgnarl
* gcc-interface/Makefile.in: Remove obsolete targets. Code cleanups.
Add support for files in libgnarl.
2017-09-08 Ed Schonberg <schonberg@adacore.com>
* exp_ch4.adb (Expand_N_Type_Conversion): Do not apply
accessibility check to an interface conversion, whose purpose
is to perform a pointer adjustment in a dispatching call.
* exp_ch6.adb (Expand_Call_JHelper): Add accessibility checks
when the actual is a construct that involves a dereference of an
expression that includes a formal of the enclosing subprogram,
In such cases, the accessibility level of the actual is that of
the corresponding formal, which is passed in as an additional
actual in the outer call.
2017-09-08 Bob Duff <duff@adacore.com>
* exp_intr.adb (Add_Source_Info): Do not decode * exp_intr.adb (Add_Source_Info): Do not decode
file names; they were not encoded in the first place. file names; they were not encoded in the first place.
......
gcc/ada/exp_attr.adb
...@@ -3837,10 +3837,17 @@ package body Exp_Attr is ...@@ -3837,10 +3837,17 @@ package body Exp_Attr is
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: -- initialize a dummy tag value. We used to generate:
--
-- Descendant_Tag (String'Input (Strm), P_Type); -- Descendant_Tag (String'Input (Strm), P_Type);
--
-- which turns into a call to String_Input_Blk_IO. However,
-- if the input is malformed, that could try to read an
-- enormous String, causing chaos. So instead we call
-- String_Input_Tag, which does the same thing as
-- String_Input_Blk_IO, except that if the String is
-- absurdly long, it raises an exception.
--
-- 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
...@@ -3860,11 +3867,11 @@ package body Exp_Attr is ...@@ -3860,11 +3867,11 @@ package body Exp_Attr is
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_Attribute_Reference (Loc, Make_Function_Call (Loc,
Prefix => Name =>
New_Occurrence_Of (Standard_String, Loc), New_Occurrence_Of
Attribute_Name => Name_Input, (RTE (RE_String_Input_Tag), Loc),
Expressions => New_List ( Parameter_Associations => New_List (
Relocate_Node (Duplicate_Subexpr (Strm)))), 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),
......
gcc/ada/exp_ch4.adb
...@@ -11230,7 +11230,8 @@ package body Exp_Ch4 is ...@@ -11230,7 +11230,8 @@ package body Exp_Ch4 is
-- Apply an accessibility check when the conversion operand is an -- Apply an accessibility check when the conversion operand is an
-- access parameter (or a renaming thereof), unless conversion was -- access parameter (or a renaming thereof), unless conversion was
-- expanded from an Unchecked_ or Unrestricted_Access attribute. -- expanded from an Unchecked_ or Unrestricted_Access attribute,
-- or for the actual of a class-wide interface parameter.
-- Note that other checks may still need to be applied below (such -- Note that other checks may still need to be applied below (such
-- as tagged type checks). -- as tagged type checks).
...@@ -11240,8 +11241,19 @@ package body Exp_Ch4 is ...@@ -11240,8 +11241,19 @@ package body Exp_Ch4 is
and then (Nkind (Original_Node (N)) /= N_Attribute_Reference and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
or else Attribute_Name (Original_Node (N)) = Name_Access) or else Attribute_Name (Original_Node (N)) = Name_Access)
then then
Apply_Accessibility_Check if not Comes_From_Source (N)
(Operand, Target_Type, Insert_Node => Operand); and then Nkind_In (Parent (N),
N_Function_Call,
N_Procedure_Call_Statement)
and then Is_Interface (Designated_Type (Target_Type))
and then Is_Class_Wide_Type (Designated_Type (Target_Type))
then
null;
else
Apply_Accessibility_Check
(Operand, Target_Type, Insert_Node => Operand);
end if;
-- If the level of the operand type is statically deeper than the -- If the level of the operand type is statically deeper than the
-- level of the target type, then force Program_Error. Note that this -- level of the target type, then force Program_Error. Note that this
......
gcc/ada/exp_ch6.adb
...@@ -2623,6 +2623,7 @@ package body Exp_Ch6 is ...@@ -2623,6 +2623,7 @@ package body Exp_Ch6 is
Param_Count : Natural := 0; Param_Count : Natural := 0;
Parent_Formal : Entity_Id; Parent_Formal : Entity_Id;
Parent_Subp : Entity_Id; Parent_Subp : Entity_Id;
Pref_Entity : Entity_Id;
Scop : Entity_Id; Scop : Entity_Id;
Subp : Entity_Id; Subp : Entity_Id;
...@@ -3010,6 +3011,9 @@ package body Exp_Ch6 is ...@@ -3010,6 +3011,9 @@ package body Exp_Ch6 is
and then In_Open_Scopes (Scope (Entity (Actual))) and then In_Open_Scopes (Scope (Entity (Actual)))
then then
Prev_Orig := Prev; Prev_Orig := Prev;
elsif Nkind (Prev_Orig) = N_Type_Conversion then
Prev_Orig := Expression (Prev_Orig);
end if; end if;
-- Ada 2005 (AI-251): Thunks must propagate the extra actuals of -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of
...@@ -3125,6 +3129,24 @@ package body Exp_Ch6 is ...@@ -3125,6 +3129,24 @@ package body Exp_Ch6 is
when Attribute_Access => when Attribute_Access =>
-- Accessibility level of S'Access is that of A.
Prev_Orig := Prefix (Prev_Orig);
-- If the expression is a view conversion,
-- the accessibility level is that of the
-- expression.
if Nkind (Original_Node (Prev_Orig))
= N_Type_Conversion
and then
Nkind (Expression (Original_Node (Prev_Orig)))
= N_Explicit_Dereference
then
Prev_Orig :=
Expression (Original_Node (Prev_Orig));
end if;
-- If this is an Access attribute applied to the -- If this is an Access attribute applied to the
-- the current instance object passed to a type -- the current instance object passed to a type
-- initialization procedure, then use the level -- initialization procedure, then use the level
...@@ -3140,14 +3162,41 @@ package body Exp_Ch6 is ...@@ -3140,14 +3162,41 @@ package body Exp_Ch6 is
-- which can be one level too deep in some cases. -- which can be one level too deep in some cases.
-- ??? -- ???
if Is_Entity_Name (Prefix (Prev_Orig)) -- A further case that requires special handling
and then Is_Type (Entity (Prefix (Prev_Orig))) -- is the common idiom E.all'access. If E is a
-- formal of the enclosing subprogram, the
-- accessibility of the expression is that of E.
if Is_Entity_Name (Prev_Orig) then
Pref_Entity := Entity (Prev_Orig);
elsif Nkind (Prev_Orig) = N_Explicit_Dereference
and then
Is_Entity_Name (Prefix (Prev_Orig))
then
Pref_Entity := Entity (Prefix ((Prev_Orig)));
else
Pref_Entity := Empty;
end if;
if Is_Entity_Name (Prev_Orig)
and then Is_Type (Entity (Prev_Orig))
then then
Add_Extra_Actual Add_Extra_Actual
(Make_Integer_Literal (Loc, (Make_Integer_Literal (Loc,
Intval => Intval => Type_Access_Level (Pref_Entity)),
Type_Access_Level Extra_Accessibility (Formal));
(Entity (Prefix (Prev_Orig)))),
elsif Nkind (Prev_Orig) = N_Explicit_Dereference
and then Present (Pref_Entity)
and then Is_Formal (Pref_Entity)
and then Present
(Extra_Accessibility (Pref_Entity))
then
Add_Extra_Actual (
New_Occurrence_Of
(Extra_Accessibility (Pref_Entity), Loc),
Extra_Accessibility (Formal)); Extra_Accessibility (Formal));
else else
...@@ -3155,7 +3204,7 @@ package body Exp_Ch6 is ...@@ -3155,7 +3204,7 @@ package body Exp_Ch6 is
(Make_Integer_Literal (Loc, (Make_Integer_Literal (Loc,
Intval => Intval =>
Object_Access_Level Object_Access_Level
(Prefix (Prev_Orig))), (Prev_Orig)),
Extra_Accessibility (Formal)); Extra_Accessibility (Formal));
end if; end if;
......
gcc/ada/rtsfind.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1519,6 +1519,7 @@ package Rtsfind is ...@@ -1519,6 +1519,7 @@ package Rtsfind is
RE_String_Input, -- System.Strings.Stream_Ops RE_String_Input, -- System.Strings.Stream_Ops
RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops
RE_String_Input_Tag, -- System.Strings.Stream_Ops
RE_String_Output, -- System.Strings.Stream_Ops RE_String_Output, -- System.Strings.Stream_Ops
RE_String_Output_Blk_IO, -- System.Strings.Stream_Ops RE_String_Output_Blk_IO, -- System.Strings.Stream_Ops
RE_String_Read, -- System.Strings.Stream_Ops RE_String_Read, -- System.Strings.Stream_Ops
...@@ -2756,6 +2757,7 @@ package Rtsfind is ...@@ -2756,6 +2757,7 @@ package Rtsfind is
RE_String_Input => System_Strings_Stream_Ops, RE_String_Input => System_Strings_Stream_Ops,
RE_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_String_Input_Blk_IO => System_Strings_Stream_Ops,
RE_String_Input_Tag => System_Strings_Stream_Ops,
RE_String_Output => System_Strings_Stream_Ops, RE_String_Output => System_Strings_Stream_Ops,
RE_String_Output_Blk_IO => System_Strings_Stream_Ops, RE_String_Output_Blk_IO => System_Strings_Stream_Ops,
RE_String_Read => System_Strings_Stream_Ops, RE_String_Read => System_Strings_Stream_Ops,
......
gcc/ada/s-rident.ads
...@@ -89,6 +89,7 @@ package System.Rident is ...@@ -89,6 +89,7 @@ package System.Rident is
-- does not violate the restriction. -- does not violate the restriction.
(Simple_Barriers, -- Ada 2012 (D.7 (10.9/3)) (Simple_Barriers, -- Ada 2012 (D.7 (10.9/3))
Pure_Barriers, -- GNAT
No_Abort_Statements, -- (RM D.7(5), H.4(3)) No_Abort_Statements, -- (RM D.7(5), H.4(3))
No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3)) No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3))
No_Access_Subprograms, -- (RM H.4(17)) No_Access_Subprograms, -- (RM H.4(17))
...@@ -182,7 +183,6 @@ package System.Rident is ...@@ -182,7 +183,6 @@ package System.Rident is
No_Elaboration_Code, -- GNAT No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368 No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT No_Wide_Characters, -- GNAT
Pure_Barriers, -- GNAT
SPARK_05, -- GNAT SPARK_05, -- GNAT
-- The following cases require a parameter value -- The following cases require a parameter value
......
gcc/ada/s-ststop.adb
...@@ -58,8 +58,11 @@ package body System.Strings.Stream_Ops is ...@@ -58,8 +58,11 @@ package body System.Strings.Stream_Ops is
package Stream_Ops_Internal is package Stream_Ops_Internal is
function Input function Input
(Strm : access Root_Stream_Type'Class; (Strm : access Root_Stream_Type'Class;
IO : IO_Kind) return Array_Type; IO : IO_Kind;
Max_Length : Long_Integer := Long_Integer'Last) return Array_Type;
-- Raises an exception if you try to read a String that is longer than
-- Max_Length. See expansion of Attribute_Input in Exp_Attr for details.
procedure Output procedure Output
(Strm : access Root_Stream_Type'Class; (Strm : access Root_Stream_Type'Class;
...@@ -125,8 +128,9 @@ package body System.Strings.Stream_Ops is ...@@ -125,8 +128,9 @@ package body System.Strings.Stream_Ops is
----------- -----------
function Input function Input
(Strm : access Root_Stream_Type'Class; (Strm : access Root_Stream_Type'Class;
IO : IO_Kind) return Array_Type IO : IO_Kind;
Max_Length : Long_Integer := Long_Integer'Last) return Array_Type
is is
pragma Unsuppress (All_Checks); pragma Unsuppress (All_Checks);
-- To make T'Class'Input robust in the case of bad data. The -- To make T'Class'Input robust in the case of bad data. The
...@@ -146,6 +150,10 @@ package body System.Strings.Stream_Ops is ...@@ -146,6 +150,10 @@ package body System.Strings.Stream_Ops is
Index_Type'Read (Strm, Low); Index_Type'Read (Strm, Low);
Index_Type'Read (Strm, High); Index_Type'Read (Strm, High);
if Long_Integer (High) - Long_Integer (Low) > Max_Length then
raise Constraint_Error;
end if;
-- Read the character content of the string -- Read the character content of the string
declare declare
...@@ -632,6 +640,17 @@ package body System.Strings.Stream_Ops is ...@@ -632,6 +640,17 @@ package body System.Strings.Stream_Ops is
return String_Ops.Input (Strm, Block_IO); return String_Ops.Input (Strm, Block_IO);
end String_Input_Blk_IO; end String_Input_Blk_IO;
-------------------------
-- String_Input_Tag --
-------------------------
function String_Input_Tag
(Strm : access Ada.Streams.Root_Stream_Type'Class) return String
is
begin
return String_Ops.Input (Strm, Block_IO, Max_Length => 10_000);
end String_Input_Tag;
------------------- -------------------
-- String_Output -- -- String_Output --
------------------- -------------------
......
gcc/ada/s-ststop.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2009-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -155,6 +155,12 @@ package System.Strings.Stream_Ops is ...@@ -155,6 +155,12 @@ package System.Strings.Stream_Ops is
(Strm : access Ada.Streams.Root_Stream_Type'Class) (Strm : access Ada.Streams.Root_Stream_Type'Class)
return String; return String;
function String_Input_Tag
(Strm : access Ada.Streams.Root_Stream_Type'Class)
return String;
-- Same as String_Input_Blk_IO, except raises an exception for overly long
-- Strings. See expansion of Attribute_Input in Exp_Attr for details.
procedure String_Output procedure String_Output
(Strm : access Ada.Streams.Root_Stream_Type'Class; (Strm : access Ada.Streams.Root_Stream_Type'Class;
Item : String); Item : String);
......
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