===================================================================
@@ -4897,6 +4897,12 @@
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);
===================================================================
@@ -507,6 +507,10 @@
"(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");
===================================================================
@@ -619,7 +619,7 @@
-- 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 @@
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 @@
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 @@
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));
===================================================================
@@ -1972,6 +1972,11 @@
-- 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 @@
-- 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 @@
-- 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 @@
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 @@
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 @@
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 @@
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);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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 @@
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 @@
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 @@
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 @@
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 @@
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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 @@
-- 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 @@
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;
===================================================================
@@ -52,6 +52,7 @@
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 @@
---------------------------------
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 @@
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;
------------------------------------------
Ada allows adding visible operations to a tagged type after deriving a private extension from it, which leads to confusing specifications on which declarations of public primitives of different types are mixed. This patch adds a new warning (enabled by means of -gnatw.j or -gnatwa) that warns on public primitives of a tagged type defined after some private extension of it. For example: $ gcc -c -gnatwa pkg.ads -gnatl Compiling: pkg.ads Source file time stamp: 2016-11-25 12:11:17 Compiled at: 2016-11-25 07:12:20 1. package Pkg is 2. type T1 is tagged private; 3. type T2 is new T1 with private; 4. 5. function F (T : access T1) return Integer; | >>> warning: primitive of type "T1" defined after private extension "T2" at line 3 >>> warning: spec of "F" should appear before declaration of type "T2" 6. function G (T : access T2) return Integer; 7. 8. private 9. type T1 is tagged null record; 10. type T2 is new T1 with null record; 11. end Pkg; Tested on x86_64-pc-linux-gnu, committed on trunk 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.