Skip to content

R
riscv-gcc-1
Commit 48c8c473 by Arnaud Charlet
Options

[multiple changes] 

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Set_Convention_From_Pragma): Cleanup code for
	convention Stdcall, which has a number of exceptions. Convention
	is legal on a component declaration whose type is an anonymous
	access to subprogram.

2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch4.adb: sem_ch4.adb Various reformattings.
	(Try_One_Prefix_Interpretation): Use the base type when dealing
	with a subtype created for purposes of constraining a private
	type with discriminants.

2017-04-25  Javier Miranda  <miranda@adacore.com>

	* einfo.ads, einfo.adb (Has_Private_Extension): new attribute.
	* warnsw.ads, warnsw.adb (All_Warnings): Set warning on late
	dispatching primitives (Restore_Warnings): Restore warning on
	late dispatching primitives (Save_Warnings): Save warning on late
	dispatching primitives (Do_Warning_Switch): Use -gnatw.j/-gnatw.J
	to enable/disable this warning.
	(WA_Warnings): Set warning on late dispatching primitives.
	* sem_ch3.adb (Analyze_Private_Extension_Declaration): Remember
	that its parent type has a private extension.
	* sem_disp.adb (Warn_On_Late_Primitive_After_Private_Extension):
	New subprogram.
	* usage.adb: Document -gnatw.j and -gnatw.J.

From-SVN: r247176
parent 94295b25
Showing with 157 additions and 10 deletions
gcc/ada/ChangeLog
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Set_Convention_From_Pragma): Cleanup code for
convention Stdcall, which has a number of exceptions. Convention
is legal on a component declaration whose type is an anonymous
access to subprogram.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch4.adb: sem_ch4.adb Various reformattings.
(Try_One_Prefix_Interpretation): Use the base type when dealing
with a subtype created for purposes of constraining a private
type with discriminants.
2017-04-25 Javier Miranda <miranda@adacore.com>
* einfo.ads, einfo.adb (Has_Private_Extension): new attribute.
* warnsw.ads, warnsw.adb (All_Warnings): Set warning on late
dispatching primitives (Restore_Warnings): Restore warning on
late dispatching primitives (Save_Warnings): Save warning on late
dispatching primitives (Do_Warning_Switch): Use -gnatw.j/-gnatw.J
to enable/disable this warning.
(WA_Warnings): Set warning on late dispatching primitives.
* sem_ch3.adb (Analyze_Private_Extension_Declaration): Remember
that its parent type has a private extension.
* sem_disp.adb (Warn_On_Late_Primitive_After_Private_Extension):
New subprogram.
* usage.adb: Document -gnatw.j and -gnatw.J.
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor
......
gcc/ada/einfo.adb
......@@ -619,7 +619,7 @@ package body Einfo is
-- Is_Underlying_Full_View Flag298
-- Body_Needed_For_Inlining Flag299
-- (unused) Flag300
-- Has_Private_Extension Flag300
-- (unused) Flag301
-- (unused) Flag302
-- (unused) Flag303
......@@ -1818,6 +1818,12 @@ package body Einfo is
return Flag155 (Id);
end Has_Private_Declaration;
function Has_Private_Extension (Id : E) return B is
begin
pragma Assert (Is_Tagged_Type (Id));
return Flag300 (Id);
end Has_Private_Extension;
function Has_Protected (Id : E) return B is
begin
return Flag271 (Base_Type (Id));
......@@ -4891,6 +4897,12 @@ package body Einfo is
Set_Flag155 (Id, V);
end Set_Has_Private_Declaration;
procedure Set_Has_Private_Extension (Id : E; V : B := True) is
begin
pragma Assert (Is_Tagged_Type (Id));
Set_Flag300 (Id, V);
end Set_Has_Private_Extension;
procedure Set_Has_Protected (Id : E; V : B := True) is
begin
Set_Flag271 (Id, V);
......@@ -9363,6 +9375,7 @@ package body Einfo is
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Private_Extension", Flag300 (Id));
W ("Has_Protected", Flag271 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));
......
gcc/ada/einfo.ads
......@@ -1972,6 +1972,11 @@ package Einfo is
-- indicate if a full type declaration is a completion. Used for semantic
-- checks in E.4(18) and elsewhere.
-- Has_Private_Extension (Flag300)
-- Defined in tagged types. Set to indicate that the tagged type has some
-- private extension. Used to report a warning on public primitives added
-- after defining its private extensions.
-- Has_Protected (Flag271) [base type only]
-- Defined in all type entities. Set on protected types themselves, and
-- also (recursively) on any composite type which has a component for
......@@ -6455,6 +6460,7 @@ package Einfo is
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Has_Private_Ancestor (Flag151)
-- Has_Private_Extension (Flag300)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
......@@ -6485,6 +6491,7 @@ package Einfo is
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
-- Has_Private_Ancestor (Flag151)
-- Has_Private_Extension (Flag300)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
......@@ -7067,6 +7074,7 @@ package Einfo is
function Has_Primitive_Operations (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Has_Private_Extension (Id : E) return B;
function Has_Protected (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
......@@ -7751,6 +7759,7 @@ package Einfo is
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Private_Extension (Id : E; V : B := True);
procedure Set_Has_Protected (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
......@@ -8549,6 +8558,7 @@ package Einfo is
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Private_Extension);
pragma Inline (Has_Protected);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
......@@ -9070,6 +9080,7 @@ package Einfo is
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Private_Extension);
pragma Inline (Set_Has_Protected);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);
......
gcc/ada/sem_ch3.adb
......@@ -4897,6 +4897,12 @@ package body Sem_Ch3 is
end if;
end if;
-- Remember that its parent type has a private extension. Used to warn
-- on public primitives of the parent type defined after its private
-- extensions (see Check_Dispatching_Operation).
Set_Has_Private_Extension (Parent_Type);
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, T);
......
gcc/ada/sem_disp.adb
......@@ -52,6 +52,7 @@ with Snames; use Snames;
with Sinfo; use Sinfo;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Warnsw; use Warnsw;
package body Sem_Disp is
......@@ -932,6 +933,57 @@ package body Sem_Disp is
---------------------------------
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
procedure Warn_On_Late_Primitive_After_Private_Extension
(Typ : Entity_Id;
Prim : Entity_Id);
-- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim
-- if it is a public primitive defined after some private extension of
-- the tagged type.
----------------------------------------------------
-- Warn_On_Late_Primitive_After_Private_Extension --
----------------------------------------------------
procedure Warn_On_Late_Primitive_After_Private_Extension
(Typ : Entity_Id;
Prim : Entity_Id)
is
E : Entity_Id;
begin
if Warn_On_Late_Primitives
and then Comes_From_Source (Prim)
and then Has_Private_Extension (Typ)
and then Is_Package_Or_Generic_Package (Current_Scope)
and then not In_Private_Part (Current_Scope)
then
E := Next_Entity (Typ);
while E /= Prim loop
if Ekind (E) = E_Record_Type_With_Private
and then Etype (E) = Typ
then
Error_Msg_Name_1 := Chars (Typ);
Error_Msg_Name_2 := Chars (E);
Error_Msg_Sloc := Sloc (E);
Error_Msg_N
("?j?primitive of type % defined after private " &
"extension % #?", Prim);
Error_Msg_Name_1 := Chars (Prim);
Error_Msg_Name_2 := Chars (E);
Error_Msg_N
("\spec of % should appear before declaration of type %!",
Prim);
exit;
end if;
Next_Entity (E);
end loop;
end if;
end Warn_On_Late_Primitive_After_Private_Extension;
-- Local variables
Body_Is_Last_Primitive : Boolean := False;
Has_Dispatching_Parent : Boolean := False;
Ovr_Subp : Entity_Id := Empty;
......@@ -1591,6 +1643,13 @@ package body Sem_Disp is
end if;
end;
end if;
-- For similarity with record extensions, in Ada 9X the language should
-- have disallowed adding visible operations to a tagged type after
-- deriving a private extension from it. Report a warning if this
-- primitive is defined after a private extension of Tagged_Type.
Warn_On_Late_Primitive_After_Private_Extension (Tagged_Type, Subp);
end Check_Dispatching_Operation;
------------------------------------------
......
gcc/ada/sem_prag.adb
......@@ -7401,24 +7401,32 @@ package body Sem_Prag is
("dispatching subprogram# cannot use Stdcall convention!",
Arg1);
-- Subprograms are not allowed
-- Several allowed cases
elsif not Is_Subprogram_Or_Generic_Subprogram (E)
elsif Is_Subprogram_Or_Generic_Subprogram (E)
-- A variable is OK
and then Ekind (E) /= E_Variable
or else Ekind (E) = E_Variable
-- A component as well. The entity does not have its
-- Ekind set until the enclosing record declaration is
-- fully analyzed.
or else Nkind (Parent (E)) = N_Component_Declaration
-- An access to subprogram is also allowed
and then not
(Is_Access_Type (E)
and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
or else (Is_Access_Type (E)
and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-- Allow internal call to set convention of subprogram type
and then not (Ekind (E) = E_Subprogram_Type)
or else (Ekind (E) = E_Subprogram_Type)
then
null;
else
Error_Pragma_Arg
("second argument of pragma% must be subprogram (type)",
Arg2);
gcc/ada/usage.adb
......@@ -507,6 +507,10 @@ begin
"(annex J) feature");
Write_Line (" J* turn off warnings for obsolescent " &
"(annex J) feature");
Write_Line (" .j+ turn on warnings for late dispatching " &
"primitives");
Write_Line (" .J* turn off warnings for late dispatching " &
"primitives");
Write_Line (" k+ turn on warnings on constant variable");
Write_Line (" K* turn off warnings on constant variable");
Write_Line (" .k turn on warnings for standard redefinition");
......
gcc/ada/warnsw.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -66,6 +66,7 @@ package body Warnsw is
Warn_On_Dereference := Setting;
Warn_On_Export_Import := Setting;
Warn_On_Hiding := Setting;
Warn_On_Late_Primitives := Setting;
Warn_On_Modified_Unread := Setting;
Warn_On_No_Value_Assigned := Setting;
Warn_On_Non_Local_Exception := Setting;
......@@ -147,6 +148,8 @@ package body Warnsw is
W.Warn_On_Export_Import;
Warn_On_Hiding :=
W.Warn_On_Hiding;
Warn_On_Late_Primitives :=
W.Warn_On_Late_Primitives;
Warn_On_Modified_Unread :=
W.Warn_On_Modified_Unread;
Warn_On_No_Value_Assigned :=
......@@ -249,6 +252,8 @@ package body Warnsw is
Warn_On_Export_Import;
W.Warn_On_Hiding :=
Warn_On_Hiding;
W.Warn_On_Late_Primitives :=
Warn_On_Late_Primitives;
W.Warn_On_Modified_Unread :=
Warn_On_Modified_Unread;
W.Warn_On_No_Value_Assigned :=
......@@ -347,6 +352,12 @@ package body Warnsw is
when 'I' =>
Warn_On_Overlap := False;
when 'j' =>
Warn_On_Late_Primitives := True;
when 'J' =>
Warn_On_Late_Primitives := False;
when 'k' =>
Warn_On_Standard_Redefinition := True;
......@@ -667,6 +678,7 @@ package body Warnsw is
Warn_On_Biased_Representation := True; -- -gnatw.b
Warn_On_Constant := True; -- -gnatwk
Warn_On_Export_Import := True; -- -gnatwx
Warn_On_Late_Primitives := True; -- -gnatw.j
Warn_On_Modified_Unread := True; -- -gnatwm
Warn_On_No_Value_Assigned := True; -- -gnatwv
Warn_On_Non_Local_Exception := True; -- -gnatw.x
......
gcc/ada/warnsw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- 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- --
......@@ -38,6 +38,10 @@ package Warnsw is
-- here as time goes by. And in fact a really nice idea would be to put
-- them all in a Warn_Record so that they would be easy to save/restore.
Warn_On_Late_Primitives : Boolean := False;
-- Warn when tagged type public primitives are defined after its private
-- extensions.
Warn_On_Record_Holes : Boolean := False;
-- Warn when explicit record component clauses leave uncovered holes (gaps)
-- in a record layout. Off by default, set by -gnatw.h (but not -gnatwa).
......@@ -91,6 +95,7 @@ package Warnsw is
Warn_On_Dereference : Boolean;
Warn_On_Export_Import : Boolean;
Warn_On_Hiding : Boolean;
Warn_On_Late_Primitives : Boolean;
Warn_On_Modified_Unread : Boolean;
Warn_On_No_Value_Assigned : Boolean;
Warn_On_Non_Local_Exception : Boolean;
......
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