From 48c8c473932813f5d55f5ee3194ea18cf741aacc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 12:30:55 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Ed Schonberg * 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 * 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 * 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 --- gcc/ada/ChangeLog | 29 ++++++ gcc/ada/einfo.adb | 15 ++- gcc/ada/einfo.ads | 11 +++ gcc/ada/sem_ch3.adb | 6 ++ gcc/ada/sem_ch4.adb | 226 +++++++++++++++++++++---------------------- gcc/ada/sem_disp.adb | 59 +++++++++++ gcc/ada/sem_prag.adb | 22 +++-- gcc/ada/usage.adb | 4 + gcc/ada/warnsw.adb | 14 ++- gcc/ada/warnsw.ads | 7 +- 10 files changed, 269 insertions(+), 124 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d33d7b6ed00..3d5423ca866 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2017-04-25 Ed Schonberg + + * 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 + + * 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 + + * 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 * exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 26e42243215..118e09fde5c 100644 --- a/gcc/ada/einfo.adb +++ b/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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 095ec60edeb..dc63408bd49 100644 --- a/gcc/ada/einfo.ads +++ b/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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 26e531dd7f8..a40f64ec0f3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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); + <> if Has_Aspects (N) then Analyze_Aspect_Specifications (N, T); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5e6642988a4..7787d11afd0 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -8297,7 +8297,7 @@ package body Sem_Ch4 is Loc : constant Source_Ptr := Sloc (N); Obj : constant Node_Id := Prefix (N); - Subprog : constant Node_Id := + Subprog : constant Node_Id := Make_Identifier (Sloc (Selector_Name (N)), Chars => Chars (Selector_Name (N))); -- Identifier on which possible interpretations will be collected @@ -8308,17 +8308,10 @@ package body Sem_Ch4 is Actual : Node_Id; Candidate : Entity_Id := Empty; - New_Call_Node : Node_Id := Empty; + New_Call_Node : Node_Id := Empty; Node_To_Replace : Node_Id; Obj_Type : Entity_Id := Etype (Obj); - Success : Boolean := False; - - function Valid_Candidate - (Success : Boolean; - Call : Node_Id; - Subp : Entity_Id) return Entity_Id; - -- If the subprogram is a valid interpretation, record it, and add - -- to the list of interpretations of Subprog. Otherwise return Empty. + Success : Boolean := False; procedure Complete_Object_Operation (Call_Node : Node_Id; @@ -8328,8 +8321,8 @@ package body Sem_Ch4 is -- in the call, and complete the analysis of the call. procedure Report_Ambiguity (Op : Entity_Id); - -- If a prefixed procedure call is ambiguous, indicate whether the - -- call includes an implicit dereference or an implicit 'Access. + -- If a prefixed procedure call is ambiguous, indicate whether the call + -- includes an implicit dereference or an implicit 'Access. procedure Transform_Object_Operation (Call_Node : out Node_Id; @@ -8342,106 +8335,27 @@ package body Sem_Ch4 is function Try_Class_Wide_Operation (Call_Node : Node_Id; Node_To_Replace : Node_Id) return Boolean; - -- Traverse all ancestor types looking for a class-wide subprogram - -- for which the current operation is a valid non-dispatching call. + -- Traverse all ancestor types looking for a class-wide subprogram for + -- which the current operation is a valid non-dispatching call. procedure Try_One_Prefix_Interpretation (T : Entity_Id); -- If prefix is overloaded, its interpretation may include different - -- tagged types, and we must examine the primitive operations and - -- the class-wide operations of each in order to find candidate + -- tagged types, and we must examine the primitive operations and the + -- class-wide operations of each in order to find candidate -- interpretations for the call as a whole. function Try_Primitive_Operation (Call_Node : Node_Id; Node_To_Replace : Node_Id) return Boolean; -- Traverse the list of primitive subprograms looking for a dispatching - -- operation for which the current node is a valid call . - - --------------------- - -- Valid_Candidate -- - --------------------- + -- operation for which the current node is a valid call. function Valid_Candidate (Success : Boolean; Call : Node_Id; - Subp : Entity_Id) return Entity_Id - is - Arr_Type : Entity_Id; - Comp_Type : Entity_Id; - - begin - -- If the subprogram is a valid interpretation, record it in global - -- variable Subprog, to collect all possible overloadings. - - if Success then - if Subp /= Entity (Subprog) then - Add_One_Interp (Subprog, Subp, Etype (Subp)); - end if; - end if; - - -- If the call may be an indexed call, retrieve component type of - -- resulting expression, and add possible interpretation. - - Arr_Type := Empty; - Comp_Type := Empty; - - if Nkind (Call) = N_Function_Call - and then Nkind (Parent (N)) = N_Indexed_Component - and then Needs_One_Actual (Subp) - then - if Is_Array_Type (Etype (Subp)) then - Arr_Type := Etype (Subp); - - elsif Is_Access_Type (Etype (Subp)) - and then Is_Array_Type (Designated_Type (Etype (Subp))) - then - Arr_Type := Designated_Type (Etype (Subp)); - end if; - end if; - - if Present (Arr_Type) then - - -- Verify that the actuals (excluding the object) match the types - -- of the indexes. - - declare - Actual : Node_Id; - Index : Node_Id; - - begin - Actual := Next (First_Actual (Call)); - Index := First_Index (Arr_Type); - while Present (Actual) and then Present (Index) loop - if not Has_Compatible_Type (Actual, Etype (Index)) then - Arr_Type := Empty; - exit; - end if; - - Next_Actual (Actual); - Next_Index (Index); - end loop; - - if No (Actual) - and then No (Index) - and then Present (Arr_Type) - then - Comp_Type := Component_Type (Arr_Type); - end if; - end; - - if Present (Comp_Type) - and then Etype (Subprog) /= Comp_Type - then - Add_One_Interp (Subprog, Subp, Comp_Type); - end if; - end if; - - if Etype (Call) /= Any_Type then - return Subp; - else - return Empty; - end if; - end Valid_Candidate; + Subp : Entity_Id) return Entity_Id; + -- If the subprogram is a valid interpretation, record it, and add to + -- the list of interpretations of Subprog. Otherwise return Empty. ------------------------------- -- Complete_Object_Operation -- @@ -8689,7 +8603,7 @@ package body Sem_Ch4 is if Nkind (Parent_Node) = N_Procedure_Call_Statement then Call_Node := Make_Procedure_Call_Statement (Loc, - Name => New_Copy (Subprog), + Name => New_Copy (Subprog), Parameter_Associations => Actuals); else @@ -8959,12 +8873,10 @@ package body Sem_Ch4 is ----------------------------------- procedure Try_One_Prefix_Interpretation (T : Entity_Id) is - + Prev_Obj_Type : constant Entity_Id := Obj_Type; -- If the interpretation does not have a valid candidate type, -- preserve current value of Obj_Type for subsequent errors. - Prev_Obj_Type : constant Entity_Id := Obj_Type; - begin Obj_Type := T; @@ -8972,7 +8884,9 @@ package body Sem_Ch4 is Obj_Type := Designated_Type (Obj_Type); end if; - if Ekind (Obj_Type) = E_Private_Subtype then + if Ekind_In (Obj_Type, E_Private_Subtype, + E_Record_Subtype_With_Private) + then Obj_Type := Base_Type (Obj_Type); end if; @@ -8992,14 +8906,12 @@ package body Sem_Ch4 is end if; -- If the object is not tagged, or the type is still an incomplete - -- type, this is not a prefixed call. + -- type, this is not a prefixed call. Restore the previous type as + -- the current one is not a legal candidate. if not Is_Tagged_Type (Obj_Type) or else Is_Incomplete_Type (Obj_Type) then - - -- Restore previous type if current one is not legal candidate - Obj_Type := Prev_Obj_Type; return; end if; @@ -9022,7 +8934,7 @@ package body Sem_Ch4 is -- primitive. This check must be done even if a candidate -- was found in order to report ambiguous calls. - if not (Prim_Result) then + if not Prim_Result then CW_Result := Try_Class_Wide_Operation (Call_Node => New_Call_Node, @@ -9360,19 +9272,19 @@ package body Sem_Ch4 is if Is_Concurrent_Type (Obj_Type) then if Present (Corresponding_Record_Type (Obj_Type)) then Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); - Elmt := First_Elmt (Primitive_Operations (Corr_Type)); + Elmt := First_Elmt (Primitive_Operations (Corr_Type)); else Corr_Type := Obj_Type; - Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; - Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type)); + Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type)); else Corr_Type := Obj_Type; - Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; while Present (Elmt) loop @@ -9383,7 +9295,7 @@ package body Sem_Ch4 is and then Valid_First_Argument_Of (Prim_Op) and then (Nkind (Call_Node) = N_Function_Call) - = + = (Ekind (Prim_Op) = E_Function) then -- Ada 2005 (AI-251): If this primitive operation corresponds @@ -9464,6 +9376,92 @@ package body Sem_Ch4 is return Present (Matching_Op); end Try_Primitive_Operation; + --------------------- + -- Valid_Candidate -- + --------------------- + + function Valid_Candidate + (Success : Boolean; + Call : Node_Id; + Subp : Entity_Id) return Entity_Id + is + Arr_Type : Entity_Id; + Comp_Type : Entity_Id; + + begin + -- If the subprogram is a valid interpretation, record it in global + -- variable Subprog, to collect all possible overloadings. + + if Success then + if Subp /= Entity (Subprog) then + Add_One_Interp (Subprog, Subp, Etype (Subp)); + end if; + end if; + + -- If the call may be an indexed call, retrieve component type of + -- resulting expression, and add possible interpretation. + + Arr_Type := Empty; + Comp_Type := Empty; + + if Nkind (Call) = N_Function_Call + and then Nkind (Parent (N)) = N_Indexed_Component + and then Needs_One_Actual (Subp) + then + if Is_Array_Type (Etype (Subp)) then + Arr_Type := Etype (Subp); + + elsif Is_Access_Type (Etype (Subp)) + and then Is_Array_Type (Designated_Type (Etype (Subp))) + then + Arr_Type := Designated_Type (Etype (Subp)); + end if; + end if; + + if Present (Arr_Type) then + + -- Verify that the actuals (excluding the object) match the types + -- of the indexes. + + declare + Actual : Node_Id; + Index : Node_Id; + + begin + Actual := Next (First_Actual (Call)); + Index := First_Index (Arr_Type); + while Present (Actual) and then Present (Index) loop + if not Has_Compatible_Type (Actual, Etype (Index)) then + Arr_Type := Empty; + exit; + end if; + + Next_Actual (Actual); + Next_Index (Index); + end loop; + + if No (Actual) + and then No (Index) + and then Present (Arr_Type) + then + Comp_Type := Component_Type (Arr_Type); + end if; + end; + + if Present (Comp_Type) + and then Etype (Subprog) /= Comp_Type + then + Add_One_Interp (Subprog, Subp, Comp_Type); + end if; + end if; + + if Etype (Call) /= Any_Type then + return Subp; + else + return Empty; + end if; + end Valid_Candidate; + -- Start of processing for Try_Object_Operation begin diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 73bc8b6ceae..7e6907a2953 100644 --- a/gcc/ada/sem_disp.adb +++ b/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; ------------------------------------------ diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f727c7a232b..70e20ab875d 100644 --- a/gcc/ada/sem_prag.adb +++ b/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); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 6421a08fbfa..b0f7de19250 100644 --- a/gcc/ada/usage.adb +++ b/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"); diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 38f7d39b1e4..1c0995c7057 100644 --- a/gcc/ada/warnsw.adb +++ b/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 diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 3e1d5c5078f..9b6313ac4ca 100644 --- a/gcc/ada/warnsw.ads +++ b/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; -- 2.30.2