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 <mira...@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.
Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 247163) +++ sem_ch3.adb (working copy) @@ -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); Index: usage.adb =================================================================== --- usage.adb (revision 247135) +++ usage.adb (working copy) @@ -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"); Index: einfo.adb =================================================================== --- einfo.adb (revision 247170) +++ einfo.adb (working copy) @@ -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)); Index: einfo.ads =================================================================== --- einfo.ads (revision 247170) +++ einfo.ads (working copy) @@ -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); Index: warnsw.adb =================================================================== --- warnsw.adb (revision 247135) +++ warnsw.adb (working copy) @@ -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 @@ 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 Index: warnsw.ads =================================================================== --- warnsw.ads (revision 247135) +++ warnsw.ads (working copy) @@ -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 @@ -- 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; Index: sem_disp.adb =================================================================== --- sem_disp.adb (revision 247140) +++ sem_disp.adb (working copy) @@ -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; ------------------------------------------