diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4979727ae49..49eeadba196 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2017-04-25 Thomas Quinot + + * sem_prag.adb (Analyze_Pragma, case Pragma_Check): Remove + bogus circuitry for the case where Name is Predicate. + +2017-04-25 Thomas Quinot + + * par_sco.adb(Traverse_Declarations_Or_Statements.Traverse_Aspects): + Create SCOs for Predicate aspects in disabled + state initially, to be enabled later on by... + * sem_ch13.adb (Build_Predicate_Functions.Add_Predicates): Mark + SCO for predicate as enabled. + +2017-04-25 Hristian Kirtchev + + * comperr.adb (Compiler_Abort): Remove now obsolete pair of + pragmas Warnings Off / On. + * namet.adb (Finalize): Remove now obsolete pair of pragmas + Warnings Off / On. + * output.adb: Remove now obsolete pair of pragmas Warnings Off / On. + * sem_warn.adb (Warn_On_Constant_Valid_Condition): Do not + consider comparisons between static expressions because their + values cannot be invalidated. + * urealp.adb (Tree_Read): Remove now obsolete pair of pragmas + Warnings Off / On. + (Tree_Write): Remove now obsolete pair of pragmas Warnings Off / On. + * usage.adb Remove now obsolete pair of pragmas Warnings Off / On. + +2017-04-25 Bob Duff + + * sem_elab.adb (In_Task_Activation): Trace internal calls in + task bodies. + 2017-04-25 Gary Dismukes * sem_prag.adb, sem_warn.adb, sem_eval.adb: Minor reformatting and diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index b3e20a41f1a..04035241830 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -98,18 +98,9 @@ package body Comperr is Write_Eol; end End_Line; - -- Disable the warnings emitted by -gnatwc because the following two - -- constants are initialized by means of conditional compilation. - - pragma Warnings - (Off, "condition can only be * if invalid values present"); - Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL; Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF; - pragma Warnings - (On, "condition can only be * if invalid values present"); - -- Start of processing for Compiler_Abort begin diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index a1610468a74..6b9f61d8aa2 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -672,12 +672,6 @@ package body Namet is Max_Chain_Length := C; end if; - -- Disable the warnings emitted by -gnatwc because the tests - -- involving Verbosity involve conditional compilation. - - pragma Warnings - (Off, "condition can only be * if invalid values present"); - if Verbosity >= 2 then Write_Str ("Hash_Table ("); Write_Int (J); @@ -709,9 +703,6 @@ package body Namet is N := Name_Entries.Table (N).Hash_Link; end loop; end if; - - pragma Warnings - (On, "condition can only be * if invalid values present"); end; end if; end loop; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 34e54d838f6..33a08055db5 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -55,12 +55,7 @@ package body Output is Indentation_Limit : constant Positive := 40; -- Indentation beyond this number of spaces wraps around - -- Disable the warnings emitted by -gnatwc because the comparison within - -- the assertion depends on conditional compilation. - - pragma Warnings (Off, "condition can only be * if invalid values present"); pragma Assert (Indentation_Limit < Buffer_Max / 2); - pragma Warnings (On, "condition can only be * if invalid values present"); -- Make sure this is substantially shorter than the line length Cur_Indentation : Natural := 0; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index a3379dd0bc7..e5bb42a5c82 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2017, 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- -- @@ -1678,7 +1678,15 @@ package body Par_SCO is -- Aspects rewritten into pragmas controlled by a Check_Policy: -- Current_Pragma_Sloc must be set to the sloc of the aspect -- specification. The corresponding pragma will have the same - -- sloc. + -- sloc. Note that Invariant, Pre, and Post will be enabled if + -- the policy is Check; on the other hand, predicate aspects + -- will be enabled for Check and Ignore (when Add_Predicate + -- is called) because the actual checks occur in client units. + -- When the assertion policy for Predicate is Disable, the + -- SCO remains disabled, because Add_Predicate is never called. + + -- Pre/post can have checks in client units too because of + -- inheritance, so should they receive the same treatment??? when Aspect_Invariant | Aspect_Post @@ -1686,24 +1694,11 @@ package body Par_SCO is | Aspect_Pre | Aspect_Precondition | Aspect_Type_Invariant - => - C1 := 'a'; - - -- Aspects whose checks are generated in client units, - -- regardless of whether or not the check is activated in the - -- unit which contains the declaration: create decision as - -- unconditionally enabled aspect (but still make a pragma - -- entry since Set_SCO_Pragma_Enabled will be called when - -- analyzing actual checks, possibly in other units). - - -- Pre/post can have checks in client units too because of - -- inheritance, so should they be moved here??? - - when Aspect_Dynamic_Predicate + | Aspect_Dynamic_Predicate | Aspect_Predicate | Aspect_Static_Predicate => - C1 := 'A'; + C1 := 'a'; -- Other aspects: just process any decision nested in the -- aspect expression. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ca8a5cc9f5d..482eab4dffa 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -42,6 +42,7 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -8419,6 +8420,10 @@ package body Sem_Ch13 is -- Start of processing for Add_Predicate begin + -- Mark corresponding SCO as enabled + + Set_SCO_Pragma_Enabled (Sloc (Prag)); + -- Extract the arguments of the pragma. The expression itself -- is copied for use in the predicate function, to preserve the -- original version for ASIS use. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index b4102edd90e..45241c3e529 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -70,26 +70,26 @@ package body Sem_Elab is Ent : Entity_Id; end record; - package Elab_Call is new Table.Table ( - Table_Component_Type => Elab_Call_Entry, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "Elab_Call"); + package Elab_Call is new Table.Table + (Table_Component_Type => Elab_Call_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Elab_Call"); -- This table is initialized at the start of each outer level call. It -- holds the entities for all subprograms that have been examined for this -- particular outer level call, and is used to prevent both infinite -- recursion, and useless reanalysis of bodies already seen - package Elab_Visited is new Table.Table ( - Table_Component_Type => Entity_Id, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100, - Table_Name => "Elab_Visited"); + package Elab_Visited is new Table.Table + (Table_Component_Type => Entity_Id, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Elab_Visited"); -- This table stores calls to Check_Internal_Call that are delayed until -- all generics are instantiated and in particular until after all generic @@ -112,23 +112,29 @@ package body Sem_Elab is -- The current scope of the call. This is restored when we complete the -- delayed call, so that we do this in the right scope. - From_SPARK_Code : Boolean; - -- Save indication of whether this call is under SPARK_Mode => On + Outer_Scope : Entity_Id; + -- Save scope of outer level call From_Elab_Code : Boolean; -- Save indication of whether this call is from elaboration code - Outer_Scope : Entity_Id; - -- Save scope of outer level call + In_Task_Activation : Boolean; + -- Save indication of whether this call is from a task body. Tasks are + -- activated at the "begin", which is after all local procedure bodies, + -- so calls to those procedures can't fail, even if they occur after the + -- task body. + + From_SPARK_Code : Boolean; + -- Save indication of whether this call is under SPARK_Mode => On end record; - package Delay_Check is new Table.Table ( - Table_Component_Type => Delay_Element, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 1000, - Table_Increment => 100, - Table_Name => "Delay_Check"); + package Delay_Check is new Table.Table + (Table_Component_Type => Delay_Element, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 100, + Table_Name => "Delay_Check"); C_Scope : Entity_Id; -- Top-level scope of current scope. Compute this only once at the outer @@ -145,10 +151,12 @@ package body Sem_Elab is -- routines in other units if this flag is True. In_Task_Activation : Boolean := False; - -- This flag indicates whether we are performing elaboration checks on - -- task procedures, at the point of activation. If true, we do not trace - -- internal calls in these procedures, because all local bodies are known - -- to be elaborated. + -- This flag indicates whether we are performing elaboration checks on task + -- bodies, at the point of activation. If true, we do not raise + -- Program_Error for calls to local procedures, because all local bodies + -- are known to be elaborated. However, we still need to trace such calls, + -- because a local procedure could call a procedure in another package, + -- so we might need an implicit Elaborate_All. Delaying_Elab_Checks : Boolean := True; -- This is set True till the compilation is complete, including the @@ -242,7 +250,7 @@ package body Sem_Elab is Orig_Ent : Entity_Id); -- The processing for Check_Internal_Call is divided up into two phases, -- and this represents the second phase. The second phase is delayed if - -- Delaying_Elab_Calls is set to True. In this delayed case, the first + -- Delaying_Elab_Checks is set to True. In this delayed case, the first -- phase makes an entry in the Delay_Check table, which is processed when -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to -- Check_Internal_Call. Outer_Scope is the outer level scope for the @@ -1956,6 +1964,7 @@ package body Sem_Elab is for J in Delay_Check.First .. Delay_Check.Last loop Push_Scope (Delay_Check.Table (J).Curscop); From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; + In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; -- Set appropriate value of SPARK_Mode @@ -1965,11 +1974,11 @@ package body Sem_Elab is SPARK_Mode := On; end if; - Check_Internal_Call_Continue ( - N => Delay_Check.Table (J).N, - E => Delay_Check.Table (J).E, - Outer_Scope => Delay_Check.Table (J).Outer_Scope, - Orig_Ent => Delay_Check.Table (J).Orig_Ent); + Check_Internal_Call_Continue + (N => Delay_Check.Table (J).N, + E => Delay_Check.Table (J).E, + Outer_Scope => Delay_Check.Table (J).Outer_Scope, + Orig_Ent => Delay_Check.Table (J).Orig_Ent); SPARK_Mode := Save_SPARK_Mode; Pop_Scope; @@ -2201,12 +2210,6 @@ package body Sem_Elab is elsif Is_Intrinsic_Subprogram (E) then return; - -- No need to trace local calls if checking task activation, because - -- other local bodies are elaborated already. - - elsif In_Task_Activation then - return; - -- Nothing to do if call is within a generic unit elsif Inside_A_Generic then @@ -2224,14 +2227,15 @@ package body Sem_Elab is -- Delay this call if we are still delaying calls if Delaying_Elab_Checks then - Delay_Check.Append ( - (N => N, - E => E, - Orig_Ent => Orig_Ent, - Curscop => Current_Scope, - Outer_Scope => Outer_Scope, - From_Elab_Code => From_Elab_Code, - From_SPARK_Code => SPARK_Mode = On)); + Delay_Check.Append + ((N => N, + E => E, + Orig_Ent => Orig_Ent, + Curscop => Current_Scope, + Outer_Scope => Outer_Scope, + From_Elab_Code => From_Elab_Code, + In_Task_Activation => In_Task_Activation, + From_SPARK_Code => SPARK_Mode = On)); return; -- Otherwise, call phase 2 continuation right now @@ -2520,7 +2524,10 @@ package body Sem_Elab is -- inserted. begin - if Inst_Case then + if In_Task_Activation then + Insert_Check := False; + + elsif Inst_Case then Error_Msg_NE ("cannot instantiate& before body seen<<", N, Orig_Ent); diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index 7fbb2f6873b..3db19da6805 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2017, 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- -- @@ -132,7 +132,7 @@ package Sem_Elab is -- N_Function_Call or N_Procedure_Call_Statement node or an access -- attribute reference whose prefix is a subprogram. -- - -- If SPARK_Mode is On, then N can also be a variablr reference, since + -- If SPARK_Mode is On, then N can also be a variable reference, since -- SPARK requires the use of Elaborate_All for references to variables -- in other packages. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a3c5d14d666..133662503c6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -12756,22 +12756,9 @@ package body Sem_Prag is -- Deal with SCO generation - case Cname is - - -- Nothing to do for predicates as the checks occur in the - -- client units. The SCO for the aspect in the declaration - -- unit is conservatively always enabled. - - when Name_Predicate => - null; - - -- Otherwise mark aspect/pragma SCO as enabled - - when others => - if Is_Checked (N) and then not Split_PPC (N) then - Set_SCO_Pragma_Enabled (Loc); - end if; - end case; + if Is_Checked (N) and then not Split_PPC (N) then + Set_SCO_Pragma_Enabled (Loc); + end if; -- Deal with analyzing the string argument diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index d4f3e4f6ae9..52fc372b250 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3267,22 +3267,39 @@ package body Sem_Warn is -------------------------------------- procedure Warn_On_Constant_Valid_Condition (Op : Node_Id) is + Left : constant Node_Id := Left_Opnd (Op); + Right : constant Node_Id := Right_Opnd (Op); + True_Result : Boolean; False_Result : Boolean; begin -- Determine the potential outcome of the comparison assuming that the - -- operands are valid. Do not consider instances because the check was - -- already performed in the generic. Do not consider comparison between - -- an attribute reference and a compile-time known value since this is - -- most likely a conditional compilation. Do not consider internal files - -- in order to allow for various assertions and safeguards within our - -- runtime. + -- operands are valid. if Constant_Condition_Warnings and then Comes_From_Source (Original_Node (Op)) + + -- Do not consider instances because the check was already performed + -- in the generic. + and then not In_Instance + + -- Do not consider comparisons between two static expressions such as + -- constants or literals because those values cannot be invalidated. + + and then not (Is_Static_Expression (Left) + and then Is_Static_Expression (Right)) + + -- Do not consider comparison between an attribute reference and a + -- compile-time known value since this is most likely a conditional + -- compilation. + and then not Is_Attribute_And_Known_Value_Comparison (Op) + + -- Do not consider internal files to allow for various assertions and + -- safeguards within our runtime. + and then not Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (Op))) then diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index 5aaee7d13fe..b408d013bac 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -493,14 +493,7 @@ package body Urealp is procedure Tree_Read is begin - -- Disable the warnings emitted by -gnatwc because the following check - -- acts as a signal in case Num_Ureal_Constants is changed. - - pragma Warnings - (Off, "condition can only be * if invalid values present"); pragma Assert (Num_Ureal_Constants = 10); - pragma Warnings - (On, "condition can only be * if invalid values present"); Ureals.Tree_Read; Tree_Read_Int (Int (UR_0)); @@ -525,14 +518,7 @@ package body Urealp is procedure Tree_Write is begin - -- Disable the warnings emitted by -gnatwc because the following check - -- acts as a signal in case Num_Ureal_Constants is changed. - - pragma Warnings - (Off, "condition can only be * if invalid values present"); pragma Assert (Num_Ureal_Constants = 10); - pragma Warnings - (On, "condition can only be * if invalid values present"); Ureals.Tree_Write; Tree_Write_Int (Int (UR_0)); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 8a47fd642d0..8eb362f63b5 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -671,11 +671,6 @@ begin Write_Switch_Char ("zr"); Write_Line ("Distribution stub generation for receiver stubs"); - -- Disable the warnings emitted by -gnatwc because Ada_Version_Default may - -- be changed to denote a different default value. - - pragma Warnings (Off, "condition can only be * if invalid values present"); - if not Latest_Ada_Only then -- Line for -gnat83 switch @@ -714,8 +709,6 @@ begin Write_Line ("Ada 2012 mode"); end if; - pragma Warnings (On, "condition can only be * if invalid values present"); - -- Line for -gnat-p switch Write_Switch_Char ("-p");