git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2015-03-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Ensure_Aggregate_Form):
	Ensure that the name denoted by the Chars of a pragma argument
	association has the proper Sloc when converted into an aggregate.

2015-03-02  Bob Duff  <duff@adacore.com>

	* sem_ch6.adb (Check_Private_Overriding): Capture
	Incomplete_Or_Partial_View in a constant. This is cleaner and
	more efficient.

2015-03-02  Gary Dismukes  <dismukes@adacore.com>

	* einfo.ads, exp_unst.ads: Minor reformatting.

2015-03-02  Ed Schonberg  <schonberg@adacore.com>

	* a-strsea.adb (Find_Token): Ensure that the range of iteration
	does not perform any improper character access. This prevents
	erroneous access in the unusual case of an empty string target
	and a From parameter less than Source'First.

2015-03-02  Robert Dewar  <dewar@adacore.com>

	* elists.adb (List_Length): Fix incorrect result.

From-SVN: r221111
This commit is contained in:
Arnaud Charlet 2015-03-02 12:07:34 +01:00
parent acf624f280
commit aaeb3b3a86
7 changed files with 112 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/ada/ChangeLog
View File

@ -1,3 +1,30 @@
2015-03-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Ensure_Aggregate_Form):
Ensure that the name denoted by the Chars of a pragma argument
association has the proper Sloc when converted into an aggregate.
2015-03-02 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Check_Private_Overriding): Capture
Incomplete_Or_Partial_View in a constant. This is cleaner and
more efficient.
2015-03-02 Gary Dismukes <dismukes@adacore.com>
* einfo.ads, exp_unst.ads: Minor reformatting.
2015-03-02 Ed Schonberg <schonberg@adacore.com>
* a-strsea.adb (Find_Token): Ensure that the range of iteration
does not perform any improper character access. This prevents
erroneous access in the unusual case of an empty string target
and a From parameter less than Source'First.
2015-03-02 Robert Dewar <dewar@adacore.com>
* elists.adb (List_Length): Fix incorrect result.
2015-03-02 Bob Duff <duff@adacore.com> 2015-03-02 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Check_Private_Overriding): Refine the legality * sem_ch6.adb (Check_Private_Overriding): Refine the legality

6
gcc/ada/a-strsea.adb
View File

@ -209,7 +209,11 @@ package body Ada.Strings.Search is
raise Index_Error; raise Index_Error;
end if; end if;
for J in From .. Source'Last loop -- If Source is the empty string, From may still be out of its
-- range. The following ensures that in all cases there is no
-- possible erroneous access to a non-existing character.
for J in Integer'Max (From, Source'First) .. Source'Last loop
if Belongs (Source (J), Set, Test) then if Belongs (Source (J), Set, Test) then
First := J; First := J;

4
gcc/ada/einfo.ads
View File

@ -1999,7 +1999,7 @@ package Einfo is
-- the case where we are unnesting nested subprograms (in which case it -- the case where we are unnesting nested subprograms (in which case it
-- is also set for types and subtypes which are not static types, and -- is also set for types and subtypes which are not static types, and
-- that are referenced uplevel, as well as for subprograms that contain -- that are referenced uplevel, as well as for subprograms that contain
-- uplevel references or call other subprogram, see Exp_unst for details. -- uplevel references or call other subprograms (Exp_Unst has details).
-- Has_Visible_Refinement (Flag263) -- Has_Visible_Refinement (Flag263)
-- Defined in E_Abstract_State entities. Set when a state has at least -- Defined in E_Abstract_State entities. Set when a state has at least
@ -2978,7 +2978,7 @@ package Einfo is
-- type is known to be a static type (defined as a discrete type with -- type is known to be a static type (defined as a discrete type with
-- static bounds, a record all of whose component types are static types, -- static bounds, a record all of whose component types are static types,
-- or an array, all of whose bounds are of a static type, and also have -- or an array, all of whose bounds are of a static type, and also have
-- a component type that is a static type. See Set_Uplevel_Type for more -- a component type that is a static type). See Set_Uplevel_Type for more
-- information on how this flag is used. Note that if Is_Static_Type is -- information on how this flag is used. Note that if Is_Static_Type is
-- True, then it is never the case that the Has_Uplevel_Reference flag is -- True, then it is never the case that the Has_Uplevel_Reference flag is
-- set for the same type. -- set for the same type.

1
gcc/ada/elists.adb
View File

@ -302,6 +302,7 @@ package body Elists is
if No (Elmt) then if No (Elmt) then
return N; return N;
else else
N := N + 1;
Next_Elmt (Elmt); Next_Elmt (Elmt);
end if; end if;
end loop; end loop;

2
gcc/ada/exp_unst.ads
View File

@ -195,7 +195,7 @@ package Exp_Unst is
-- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call -- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call
-- to unchecked conversion to convert the address to the access type -- to unchecked conversion to convert the address to the access type
-- and Tnn is a locally declared type that is "access all t", where t -- and Tnn is a locally declared type that is "access all t", where t
-- is the type of the reference. -- is the type of the reference).
-- Note: the reason that we use Address as the component type in the -- Note: the reason that we use Address as the component type in the
-- declaration of AREC1T is that we may create this type before we see -- declaration of AREC1T is that we may create this type before we see

89
gcc/ada/sem_ch6.adb
View File

@ -8906,24 +8906,27 @@ package body Sem_Ch6 is
procedure Check_Private_Overriding (T : Entity_Id) is procedure Check_Private_Overriding (T : Entity_Id) is
function Overrides_Visible_Function return Boolean; function Overrides_Visible_Function
(Partial_View : Entity_Id) return Boolean;
-- True if S overrides a function in the visible part. The -- True if S overrides a function in the visible part. The
-- overridden function could be explicitly or implicitly declared. -- overridden function could be explicitly or implicitly declared.
function Overrides_Visible_Function return Boolean is function Overrides_Visible_Function
(Partial_View : Entity_Id) return Boolean
is
begin begin
if not Is_Overriding or else not Has_Homonym (S) then if not Is_Overriding or else not Has_Homonym (S) then
return False; return False;
end if; end if;
if not Present (Incomplete_Or_Partial_View (T)) then if not Present (Partial_View) then
return True; return True;
end if; end if;
-- Search through all the homonyms H of S in the current -- Search through all the homonyms H of S in the current
-- package spec, and return True if we find one that matches. -- package spec, and return True if we find one that matches.
-- Note that Parent (H) will be the declaration of the -- Note that Parent (H) will be the declaration of the
-- Incomplete_Or_Partial_View of T for a match. -- partial view of T for a match.
declare declare
H : Entity_Id := S; H : Entity_Id := S;
@ -8936,8 +8939,7 @@ package body Sem_Ch6 is
(Parent (H), (Parent (H),
N_Private_Extension_Declaration, N_Private_Extension_Declaration,
N_Private_Type_Declaration) N_Private_Type_Declaration)
and then Defining_Identifier (Parent (H)) = and then Defining_Identifier (Parent (H)) = Partial_View
Incomplete_Or_Partial_View (T)
then then
return True; return True;
end if; end if;
@ -8963,41 +8965,52 @@ package body Sem_Ch6 is
Error_Msg_N ("abstract subprograms must be visible " Error_Msg_N ("abstract subprograms must be visible "
& "(RM 3.9.3(10))!", S); & "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function elsif Ekind (S) = E_Function then
and then not Overrides_Visible_Function declare
then Partial_View : constant Entity_Id :=
-- Here, S is "function ... return T;" declared in the Incomplete_Or_Partial_View (T);
-- private part, not overriding some visible operation.
-- That's illegal in the tagged case (but not if the
-- private type is untagged).
if ((Present (Incomplete_Or_Partial_View (T)) begin
and then Is_Tagged_Type (Incomplete_Or_Partial_View (T))) if not Overrides_Visible_Function (Partial_View) then
or else (not Present (Incomplete_Or_Partial_View (T))
and then Is_Tagged_Type (T)))
and then T = Base_Type (Etype (S))
then
Error_Msg_N ("private function with tagged result must"
& " override visible-part function", S);
Error_Msg_N ("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
-- AI05-0073: extend this test to the case of a function -- Here, S is "function ... return T;" declared in
-- with a controlling access result. -- the private part, not overriding some visible
-- operation. That's illegal in the tagged case
-- (but not if the private type is untagged).
elsif Ekind (Etype (S)) = E_Anonymous_Access_Type if ((Present (Partial_View)
and then Is_Tagged_Type (Designated_Type (Etype (S))) and then Is_Tagged_Type (Partial_View))
and then or else (not Present (Partial_View)
not Is_Class_Wide_Type (Designated_Type (Etype (S))) and then Is_Tagged_Type (T)))
and then Ada_Version >= Ada_2012 and then T = Base_Type (Etype (S))
then then
Error_Msg_N Error_Msg_N
("private function with controlling access result " ("private function with tagged result must"
& "must override visible-part function", S); & " override visible-part function", S);
Error_Msg_N Error_Msg_N
("\move subprogram to the visible part" ("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S); & " (RM 3.9.3(10))", S);
end if;
-- AI05-0073: extend this test to the case of a
-- function with a controlling access result.
elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
and then Is_Tagged_Type (Designated_Type (Etype (S)))
and then
not Is_Class_Wide_Type
(Designated_Type (Etype (S)))
and then Ada_Version >= Ada_2012
then
Error_Msg_N
("private function with controlling access "
& "result must override visible-part function",
S);
Error_Msg_N
("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
end if;
end if;
end;
end if; end if;
end if; end if;
end Check_Private_Overriding; end Check_Private_Overriding;

46
gcc/ada/sem_prag.adb
View File

@ -5222,21 +5222,32 @@ package body Sem_Prag is
--------------------------- ---------------------------
procedure Ensure_Aggregate_Form (Arg : Node_Id) is procedure Ensure_Aggregate_Form (Arg : Node_Id) is
Expr : constant Node_Id := Expression (Arg); CFSD : constant Boolean := Get_Comes_From_Source_Default;
Loc : constant Source_Ptr := Sloc (Expr); Expr : constant Node_Id := Expression (Arg);
Comps : List_Id := No_List; Loc : constant Source_Ptr := Sloc (Expr);
Exprs : List_Id := No_List; Comps : List_Id := No_List;
Nam : Name_Id; Exprs : List_Id := No_List;
Nam : Name_Id := No_Name;
CFSD : constant Boolean := Get_Comes_From_Source_Default; Nam_Loc : Source_Ptr;
-- Used to restore Comes_From_Source_Default
begin begin
if Nkind (Arg) = N_Aspect_Specification then -- The pragma argument is in positional form:
Nam := No_Name;
else -- pragma Depends (Nam => ...)
pragma Assert (Nkind (Arg) = N_Pragma_Argument_Association); -- ^
Nam := Chars (Arg); -- Chars field
-- Note that the Sloc of the Chars field is the Sloc of the pragma
-- argument association.
if Nkind (Arg) = N_Pragma_Argument_Association then
Nam := Chars (Arg);
Nam_Loc := Sloc (Arg);
-- Remove the pragma argument name as this will be captured in the
-- aggregate.
Set_Chars (Arg, No_Name);
end if; end if;
-- The argument is already in aggregate form, but the presence of a -- The argument is already in aggregate form, but the presence of a
@ -5279,17 +5290,10 @@ package body Sem_Prag is
else else
Comps := New_List ( Comps := New_List (
Make_Component_Association (Loc, Make_Component_Association (Loc,
Choices => New_List (Make_Identifier (Loc, Chars (Arg))), Choices => New_List (Make_Identifier (Nam_Loc, Nam)),
Expression => Relocate_Node (Expr))); Expression => Relocate_Node (Expr)));
end if; end if;
-- Remove the pragma argument name as this information has been
-- captured in the aggregate.
if Nkind (Arg) = N_Pragma_Argument_Association then
Set_Chars (Arg, No_Name);
end if;
Set_Expression (Arg, Set_Expression (Arg,
Make_Aggregate (Loc, Make_Aggregate (Loc,
Component_Associations => Comps, Component_Associations => Comps,