From 51bf9bdffff02529ce6331fda689e0d2fde3100f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 14 Jun 2010 15:46:36 +0200 Subject: [PATCH] [multiple changes] 2010-06-14 Robert Dewar * opt.ads (Check_Policy_List): Add some clarifying comments * sem_prag.adb (Analyze_Pragma, case Check): Set Pragma_Enabled flag on rewritten Assert pragma. 2010-06-14 Gary Dismukes * sem_ch6.adb (Check_Overriding_Indicator): Add a special check for controlled operations, so that they will be treated as overriding even if the overridden subprogram is marked Is_Hidden, as long as the overridden subprogram's parent subprogram is not hidden. 2010-06-14 Robert Dewar * debug.adb: Entry for gnatw.d no longer specific for while loops * einfo.adb (First_Exit_Statement): New attribute for E_Loop * einfo.ads (First_Exit_Statement): New attribute for E_Loop * sem_ch5.adb (Analyze_Loop_Statement): Check_Infinite_Loop_Warning has new calling sequence to include test for EXIT WHEN. (Analyze_Exit_Statement): Chain EXIT statement into exit statement chain * sem_warn.ads, sem_warn.adb (Check_Infinite_Loop_Warning): Now handles EXIT WHEN case. * sinfo.adb (Next_Exit_Statement): New attribute of N_Exit_Statement node. * sinfo.ads (N_Pragma): Correct comment on Sloc field (points to PRAGMA, not to pragma identifier). (Next_Exit_Statement): New attribute of N_Exit_Statement node 2010-06-14 Robert Dewar * sem_res.adb (Resolve_Short_Circuit): Fix sloc of "assertion/check would fail" msg. 2010-06-14 Robert Dewar * par-ch2.adb (Scan_Pragma_Argument_Association): Clarify message for missing pragma argument identifier. 2010-06-14 Robert Dewar * atree.ads, atree.adb (Ekind_In): New functions 2010-06-14 Robert Dewar * exp_ch4.adb (Expand_N_Op_Expon): Optimize 2**N in stand alone context 2010-06-14 Robert Dewar * usage.adb (Usage): Redo documentation of -gnatwa. From-SVN: r160743 --- gcc/ada/ChangeLog | 51 ++++++++++++++++++++++++++ gcc/ada/atree.adb | 98 +++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/atree.ads | 72 +++++++++++++++++++++++++++++++++++- gcc/ada/debug.adb | 4 +- gcc/ada/einfo.adb | 16 ++++++++ gcc/ada/einfo.ads | 12 ++++++ gcc/ada/exp_ch4.adb | 80 +++++++++++++++++++++++++++------------- gcc/ada/opt.ads | 5 ++- gcc/ada/par-ch2.adb | 4 +- gcc/ada/sem_ch5.adb | 13 ++++++- gcc/ada/sem_ch6.adb | 18 ++++++++- gcc/ada/sem_prag.adb | 5 +++ gcc/ada/sem_res.adb | 23 +++++++----- gcc/ada/sem_warn.adb | 101 ++++++++++++++++++++++++++++++++++++++++++--------- gcc/ada/sem_warn.ads | 3 +- gcc/ada/sinfo.adb | 16 ++++++++ gcc/ada/sinfo.ads | 26 ++++++++++++- gcc/ada/usage.adb | 52 +++++++++++++------------- 18 files changed, 507 insertions(+), 92 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 19b0aa2..78ebd92 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,54 @@ +2010-06-14 Robert Dewar + + * opt.ads (Check_Policy_List): Add some clarifying comments + * sem_prag.adb (Analyze_Pragma, case Check): Set Pragma_Enabled flag + on rewritten Assert pragma. + +2010-06-14 Gary Dismukes + + * sem_ch6.adb (Check_Overriding_Indicator): Add a special check for + controlled operations, so that they will be treated as overriding even + if the overridden subprogram is marked Is_Hidden, as long as the + overridden subprogram's parent subprogram is not hidden. + +2010-06-14 Robert Dewar + + * debug.adb: Entry for gnatw.d no longer specific for while loops + * einfo.adb (First_Exit_Statement): New attribute for E_Loop + * einfo.ads (First_Exit_Statement): New attribute for E_Loop + * sem_ch5.adb (Analyze_Loop_Statement): Check_Infinite_Loop_Warning has + new calling sequence to include test for EXIT WHEN. + (Analyze_Exit_Statement): Chain EXIT statement into exit statement chain + * sem_warn.ads, sem_warn.adb (Check_Infinite_Loop_Warning): Now handles + EXIT WHEN case. + * sinfo.adb (Next_Exit_Statement): New attribute of N_Exit_Statement + node. + * sinfo.ads (N_Pragma): Correct comment on Sloc field (points to + PRAGMA, not to pragma identifier). + (Next_Exit_Statement): New attribute of N_Exit_Statement node + +2010-06-14 Robert Dewar + + * sem_res.adb (Resolve_Short_Circuit): Fix sloc of "assertion/check + would fail" msg. + +2010-06-14 Robert Dewar + + * par-ch2.adb (Scan_Pragma_Argument_Association): Clarify message for + missing pragma argument identifier. + +2010-06-14 Robert Dewar + + * atree.ads, atree.adb (Ekind_In): New functions + +2010-06-14 Robert Dewar + + * exp_ch4.adb (Expand_N_Op_Expon): Optimize 2**N in stand alone context + +2010-06-14 Robert Dewar + + * usage.adb (Usage): Redo documentation of -gnatwa. + 2010-06-14 Ed Schonberg * sem_ch8.adb (Find_Type): The attribute 'class cannot be applied to diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index b227326..de7bd7e 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -766,6 +766,104 @@ package body Atree is return N_To_E (Nodes.Table (E + 1).Nkind); end Ekind; + -------------- + -- Ekind_In -- + -------------- + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4; + end Ekind_In; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5; + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4); + end Ekind_In; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5); + end Ekind_In; + ------------------ -- Error_Posted -- ------------------ diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index da0b288..2f61374 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -543,8 +543,12 @@ package Atree is -- Tests given Id for inequality with the Empty node. This allows notations -- like "if Present (Statement)" as opposed to "if Statement /= Empty". - -- Node_Kind tests, like the functions in Sinfo, but the first argument is - -- a Node_Id, and the tested field is Nkind (N). + --------------------- + -- Node_Kind Tests -- + --------------------- + + -- These are like the functions in Sinfo, but the first argument is a + -- Node_Id, and the tested field is Nkind (N). function Nkind_In (N : Node_Id; @@ -617,6 +621,70 @@ package Atree is pragma Inline (Nkind_In); -- Inline all above functions + ----------------------- + -- Entity_Kind_Tests -- + ----------------------- + + -- Utility functions to test whether an Entity_Kind value, either given + -- directly as the first argument, or the Ekind field of an Entity give + -- as the first argument, matches any of the given list of Entity_Kind + -- values. Return True if any match, False if no match. + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean; + + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind) return Boolean; + + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind) return Boolean; + + pragma Inline (Ekind_In); + -- Inline all above functions + ----------------------------- -- Entity Access Functions -- ----------------------------- diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index ca207b2..8f08dcc 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -113,7 +113,7 @@ package body Debug is -- d.t Disable static allocation of library level dispatch tables -- d.u -- d.v Enable OK_To_Reorder_Components in variant records - -- d.w Do not check for infinite while loops + -- d.w Do not check for infinite loops -- d.x No exception handlers -- d.y -- d.z @@ -548,7 +548,7 @@ package body Debug is -- d.v Forces the flag OK_To_Reorder_Components to be set in all record -- base types that have at least one discriminant (v = variant). - -- d.w This flag turns off the scanning of while loops to detect possible + -- d.w This flag turns off the scanning of loops to detect possible -- infinite loops. -- d.x No exception handlers in generated code. This causes exception diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index fdc9d27..1fd68b8 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -79,6 +79,7 @@ package body Einfo is -- Normalized_First_Bit Uint8 -- Postcondition_Proc Node8 -- Return_Applies_To Node8 + -- First_Exit_Statement Node8 -- Class_Wide_Type Node9 -- Current_Value Node9 @@ -1053,6 +1054,12 @@ package body Einfo is return Node17 (Id); end First_Entity; + function First_Exit_Statement (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Loop); + return Node8 (Id); + end First_Exit_Statement; + function First_Index (Id : E) return N is begin pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); @@ -3492,6 +3499,12 @@ package body Einfo is Set_Node17 (Id, V); end Set_First_Entity; + procedure Set_First_Exit_Statement (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Loop); + Set_Node8 (Id, V); + end Set_First_Exit_Statement; + procedure Set_First_Index (Id : E; V : N) is begin pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id)); @@ -7236,6 +7249,9 @@ package body Einfo is when Type_Kind => Write_Str ("Associated_Node_For_Itype"); + when E_Loop => + Write_Str ("First_Exit_Statement"); + when E_Package => Write_Str ("Dependent_Instances"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d429472..d9ff8c0 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1116,6 +1116,13 @@ package Einfo is -- Points to a list of associated entities using the Next_Entity field -- as a chain pointer with Empty marking the end of the list. +-- First_Exit_Statement (Node8) +-- Present in E_Loop entity. The exit statements for a loop are chained +-- (in reverse order of appearence) using this field to point to the +-- first entry in the chain (last exit statement in the loop). The +-- entries are chained through the Next_Exit_Statement field of the +-- N_Exit_Statement node with Empty marking the end of the list. + -- First_Formal (synthesized) -- Applies to subprograms and subprogram types, and also in entries -- and entry families. Returns first formal of the subprogram or entry. @@ -5063,6 +5070,7 @@ package Einfo is -- (plus type attributes) -- E_Loop + -- First_Exit_Statement (Node8) -- Has_Exit (Flag47) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) @@ -5743,6 +5751,7 @@ package Einfo is function Finalization_Chain_Entity (Id : E) return E; function Finalize_Storage_Only (Id : E) return B; function First_Entity (Id : E) return E; + function First_Exit_Statement (Id : E) return N; function First_Index (Id : E) return N; function First_Literal (Id : E) return E; function First_Optional_Parameter (Id : E) return E; @@ -6291,6 +6300,7 @@ package Einfo is procedure Set_Finalization_Chain_Entity (Id : E; V : E); procedure Set_Finalize_Storage_Only (Id : E; V : B := True); procedure Set_First_Entity (Id : E; V : E); + procedure Set_First_Exit_Statement (Id : E; V : N); procedure Set_First_Index (Id : E; V : N); procedure Set_First_Literal (Id : E; V : E); procedure Set_First_Optional_Parameter (Id : E; V : E); @@ -6945,6 +6955,7 @@ package Einfo is pragma Inline (Can_Use_Internal_Rep); pragma Inline (Finalization_Chain_Entity); pragma Inline (First_Entity); + pragma Inline (First_Exit_Statement); pragma Inline (First_Index); pragma Inline (First_Literal); pragma Inline (First_Optional_Parameter); @@ -7376,6 +7387,7 @@ package Einfo is pragma Inline (Set_Can_Use_Internal_Rep); pragma Inline (Set_Finalization_Chain_Entity); pragma Inline (Set_First_Entity); + pragma Inline (Set_First_Exit_Statement); pragma Inline (Set_First_Index); pragma Inline (Set_First_Literal); pragma Inline (Set_First_Optional_Parameter); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c080220..a8b7854 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -47,6 +47,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; @@ -5066,7 +5067,7 @@ package body Exp_Ch4 is and then Is_Power_Of_2_For_Shift (Ropnd) -- We cannot do this transformation in configurable run time mode if we - -- have 64-bit -- integers and long shifts are not available. + -- have 64-bit integers and long shifts are not available. and then (Esize (Ltyp) <= 32 @@ -5912,6 +5913,9 @@ package body Exp_Ch4 is -- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion -- of the higher level node converts it into a shift. + -- Another case is 2 ** N in any other context. We simply convert + -- this to 1 * 2 ** N, and then the above transformation applies. + -- Note: this transformation is not applicable for a modular type with -- a non-binary modulus in the multiplication case, since we get a wrong -- result if the shift causes an overflow before the modular reduction. @@ -5922,33 +5926,45 @@ package body Exp_Ch4 is and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) and then Is_Unsigned_Type (Exptyp) and then not Ovflo - and then Nkind (Parent (N)) in N_Binary_Op then - declare - P : constant Node_Id := Parent (N); - L : constant Node_Id := Left_Opnd (P); - R : constant Node_Id := Right_Opnd (P); + -- First the multiply and divide cases - begin - if (Nkind (P) = N_Op_Multiply - and then not Non_Binary_Modulus (Typ) - and then - ((Is_Integer_Type (Etype (L)) and then R = N) - or else - (Is_Integer_Type (Etype (R)) and then L = N)) - and then not Do_Overflow_Check (P)) - - or else - (Nkind (P) = N_Op_Divide - and then Is_Integer_Type (Etype (L)) - and then Is_Unsigned_Type (Etype (L)) - and then R = N - and then not Do_Overflow_Check (P)) - then - Set_Is_Power_Of_2_For_Shift (N); - return; - end if; - end; + if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then + declare + P : constant Node_Id := Parent (N); + L : constant Node_Id := Left_Opnd (P); + R : constant Node_Id := Right_Opnd (P); + + begin + if (Nkind (P) = N_Op_Multiply + and then not Non_Binary_Modulus (Typ) + and then + ((Is_Integer_Type (Etype (L)) and then R = N) + or else + (Is_Integer_Type (Etype (R)) and then L = N)) + and then not Do_Overflow_Check (P)) + or else + (Nkind (P) = N_Op_Divide + and then Is_Integer_Type (Etype (L)) + and then Is_Unsigned_Type (Etype (L)) + and then R = N + and then not Do_Overflow_Check (P)) + then + Set_Is_Power_Of_2_For_Shift (N); + return; + end if; + end; + + -- Now the other cases + + elsif not Non_Binary_Modulus (Typ) then + Rewrite (N, + Make_Op_Multiply (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 1), + Right_Opnd => Relocate_Node (N))); + Analyze_And_Resolve (N, Typ); + return; + end if; end if; -- Fall through if exponentiation must be done using a runtime routine @@ -8745,6 +8761,12 @@ package body Exp_Ch4 is if Compile_Time_Known_Value (Left) then + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Left) then + Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); + end if; + -- Rewrite True AND THEN Right / False OR ELSE Right to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. @@ -8830,6 +8852,12 @@ package body Exp_Ch4 is if Compile_Time_Known_Value (Right) then + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Right) then + Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); + end if; + -- Change (Left and then True), (Left or else False) to Left. -- Note that we know there are no actions associated with the right -- operand, since we just checked for this case above. diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 4581116..90b4459 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -224,7 +224,10 @@ package Opt is -- GNAT -- This points to the list of N_Pragma nodes for Check_Policy pragmas -- that are linked through the Next_Pragma fields, with the list being - -- terminated by Empty. The order is most recently processed first. + -- terminated by Empty. The order is most recently processed first. Note + -- that Push_Scope and Pop_Scope in Sem_Ch8 save and restore the value + -- of this variable, implementing the required scope control for pragmas + -- appearing a declarative part. Check_Readonly_Files : Boolean := False; -- GNATMAKE diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index e96c379..def8ef5 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -503,7 +503,9 @@ package body Ch2 is if Identifier_Seen and not Id_Present then Error_Msg_SC - ("|pragma argument identifier required here (RM 2.8(4))"); + ("|pragma argument identifier required here"); + Error_Msg_SC + ("\since previous argument had identifier (RM 2.8(4))"); end if; if Id_Present then diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 1f6806b..44909e2 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1209,6 +1209,11 @@ package body Sem_Ch5 is Check_Unset_Reference (Cond); end if; + -- Chain exit statement to associated loop entity + + Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); + Set_First_Exit_Statement (Scope_Id, N); + -- Since the exit may take us out of a loop, any previous assignment -- statement is not useless, so clear last assignment indications. It -- is OK to keep other current values, since if the exit statement @@ -2060,8 +2065,12 @@ package body Sem_Ch5 is End_Scope; Kill_Current_Values; - -- Check for infinite loop. We skip this check for generated code, since - -- it justs waste time and makes debugging the routine called harder. + -- Check for infinite loop. Skip check for generated code, since it + -- justs waste time and makes debugging the routine called harder. + + -- Note that we have to wait till the body of the loop is fully analyzed + -- before making this call, since Check_Infinite_Loop_Warning relies on + -- being able to use semantic visibility information to find references. if Comes_From_Source (N) then Check_Infinite_Loop_Warning (N); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a263d82..befa1d4 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4420,8 +4420,24 @@ package body Sem_Ch6 is end; end if; + -- If there is an overridden subprogram, then check that there is not + -- a "not overriding" indicator, and mark the subprogram as overriding. + -- This is not done if the overridden subprogram is marked as hidden, + -- which can occur for the case of inherited controlled operations + -- (see Derive_Subprogram), unless the inherited subprogram's parent + -- subprogram is not itself hidden. (Note: This condition could probably + -- be simplified, leaving out the testing for the specific controlled + -- cases, but it seems safer and clearer this way, and echoes similar + -- special-case tests of this kind in other places.) + if Present (Overridden_Subp) - and then not Is_Hidden (Overridden_Subp) + and then (not Is_Hidden (Overridden_Subp) + or else + ((Chars (Overridden_Subp) = Name_Initialize + or else Chars (Overridden_Subp) = Name_Adjust + or else Chars (Overridden_Subp) = Name_Finalize) + and then Present (Alias (Overridden_Subp)) + and then not Is_Hidden (Alias (Overridden_Subp)))) then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 065be11..0e8157a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5771,8 +5771,13 @@ package body Sem_Prag is end if; Check_Arg_Is_Identifier (Arg1); + + -- Indicate if pragma is enabled. The Original_Node reference here + -- is to deal with pragma Assert rewritten as a Check pragma. + Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); Set_Pragma_Enabled (N, Check_On); + Set_Pragma_Enabled (Original_Node (N), Check_On); -- If expansion is active and the check is not enabled then we -- rewrite the Check as: diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index feee853..0e23492 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7846,15 +7846,15 @@ package body Sem_Res is then null; else - -- Issue warning. Note that we don't want to make this - -- an unconditional warning, because if the assert is - -- within deleted code we do not want the warning. But - -- we do not want the deletion of the IF/AND-THEN to - -- take this message with it. We achieve this by making - -- sure that the expanded code points to the Sloc of - -- the expression, not the original pragma. - - Error_Msg_N ("?assertion would fail at run-time", Orig); + -- Issue warning. We do not want the deletion of the + -- IF/AND-THEN to take this message with it. We achieve + -- this by making sure that the expanded code points to + -- the Sloc of the expression, not the original pragma. + + Error_Msg_N + ("?assertion would fail at run-time!", + Expression + (First (Pragma_Argument_Associations (Orig)))); end if; end; @@ -7877,7 +7877,10 @@ package body Sem_Res is then null; else - Error_Msg_N ("?check would fail at run-time", Orig); + Error_Msg_N + ("?check would fail at run-time!", + Expression + (Last (Pragma_Argument_Associations (Orig)))); end if; end; end if; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 580ba9a..841f5dd 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -234,10 +234,11 @@ package body Sem_Warn is -- within the body of the loop. procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is - Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + Expression : Node_Id := Empty; + -- Set to WHILE or EXIT WHEN condition to be tested Ref : Node_Id := Empty; - -- Reference in iteration scheme to variable that might not be modified + -- Reference in Expression to variable that might not be modified -- in loop, indicating a possible infinite loop. Var : Entity_Id := Empty; @@ -267,9 +268,9 @@ package body Sem_Warn is function Test_Ref (N : Node_Id) return Traverse_Result; -- Test for reference to variable in question. Returns Abandon if - -- matching reference found. + -- matching reference found. Used in instantiation of No_Ref_Found. - function Find_Ref is new Traverse_Func (Test_Ref); + function No_Ref_Found is new Traverse_Func (Test_Ref); -- Function to traverse body of procedure. Returns Abandon if matching -- reference found. @@ -465,9 +466,9 @@ package body Sem_Warn is function Test_Ref (N : Node_Id) return Traverse_Result is begin - -- Waste of time to look at iteration scheme + -- Waste of time to look at the expression we are testing - if N = Iter then + if N = Expression then return Skip; -- Direct reference to variable in question @@ -547,20 +548,86 @@ package body Sem_Warn is -- Start of processing for Check_Infinite_Loop_Warning begin - -- We need a while iteration with no condition actions. Condition - -- actions just make things too complicated to get the warning right. + -- Skip processing if debug flag gnatd.w is set - if No (Iter) - or else No (Condition (Iter)) - or else Present (Condition_Actions (Iter)) - or else Debug_Flag_Dot_W - then + if Debug_Flag_Dot_W then + return; + end if; + + -- Case of WHILE loop + + declare + Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + + begin + if Present (Iter) and then Present (Condition (Iter)) then + + -- Skip processing for while iteration with conditions actions, + -- since they make it too complicated to get the warning right. + + if Present (Condition_Actions (Iter)) then + return; + end if; + + -- Capture WHILE condition + + Expression := Condition (Iter); + end if; + end; + + -- Check chain of EXIT statements, we only process loops that have a + -- single exit condition (either a single EXIT WHEN statement, or a + -- WHILE loop not containing any EXIT WHEN statements). + + declare + Ident : constant Node_Id := Identifier (Loop_Statement); + Exit_Stmt : Node_Id; + + begin + -- If we don't have a proper chain set, ignore call entirely. This + -- happens because of previous errors. + + if No (Entity (Ident)) + or else Ekind (Entity (Ident)) /= E_Loop + then + return; + end if; + + -- Otherwise prepare to scan list of EXIT statements + + Exit_Stmt := First_Exit_Statement (Entity (Ident)); + while Present (Exit_Stmt) loop + + -- Check for EXIT WHEN + + if Present (Condition (Exit_Stmt)) then + + -- Quit processing if EXIT WHEN in WHILE loop, or more than + -- one EXIT WHEN statement present in the loop. + + if Present (Expression) then + return; + + -- Otherwise capture condition from EXIT WHEN statement + + else + Expression := Condition (Exit_Stmt); + end if; + end if; + + Exit_Stmt := Next_Exit_Statement (Exit_Stmt); + end loop; + end; + + -- Return if no condition to test + + if No (Expression) then return; end if; -- Initial conditions met, see if condition is of right form - Find_Var (Condition (Iter)); + Find_Var (Expression); -- Nothing to do if local variable from source not found. If it's a -- renaming, it is probably renaming something too complicated to deal @@ -608,7 +675,7 @@ package body Sem_Warn is -- We have a variable reference of the right form, now we scan the loop -- body to see if it looks like it might not be modified - if Find_Ref (Loop_Statement) = OK then + if No_Ref_Found (Loop_Statement) = OK then Error_Msg_NE ("?variable& is not modified in loop body!", Ref, Var); Error_Msg_N @@ -3432,9 +3499,7 @@ package body Sem_Warn is Sloc_Range (Orig, Start, Dummy); Atrue := Test_Result; - if Present (Parent (C)) - and then Nkind (Parent (C)) = N_Op_Not - then + if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then Atrue := not Atrue; end if; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index 365ad39..e74e144 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -170,7 +170,8 @@ package Sem_Warn is procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id); -- N is the node for a loop statement. This procedure checks if a warning - -- should be given for a possible infinite loop, and if so issues it. + -- for a possible infinite loop should be given for a suspicious WHILE or + -- EXIT WHEN condition. procedure Check_Low_Bound_Tested (Expr : Node_Id); -- Expr is the node for a comparison operation. This procedure checks if diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 5a431cd..57f8f93 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2021,6 +2021,14 @@ package body Sinfo is return Node2 (N); end Next_Entity; + function Next_Exit_Statement + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + return Node3 (N); + end Next_Exit_Statement; + function Next_Implicit_With (N : Node_Id) return Node_Id is begin @@ -4907,6 +4915,14 @@ package body Sinfo is Set_Node2 (N, Val); -- semantic field, no parent set end Set_Next_Entity; + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Exit_Statement); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Next_Exit_Statement; + procedure Set_Next_Implicit_With (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index a5b5a3e..31f555b 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1395,6 +1395,12 @@ package Sinfo is -- scope are chained, and this field is used as the forward pointer for -- this list. See Einfo for further details. + -- Next_Exit_Statement (Node3-Sem) + -- Present in N_Exit_Statement nodes. The exit statements for a loop are + -- chained (in reverse order of appearence) from the First_Exit_Statement + -- field of the E_Loop entity for the loop. Next_Exit_Statement points to + -- the next entry on this chain (Empty = end of list). + -- Next_Implicit_With (Node3-Sem) -- Present in N_With_Clause. Part of a chain of with_clauses generated -- in rtsfind to indicate implicit dependencies on predefined units. Used @@ -1980,7 +1986,7 @@ package Sinfo is -- which are explicitly documented. -- N_Pragma - -- Sloc points to pragma identifier + -- Sloc points to PRAGMA -- Next_Pragma (Node1-Sem) -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3) (set to Empty if not Debug, Assert) @@ -4040,6 +4046,13 @@ package Sinfo is -- Is_Null_Loop (Flag16) -- Suppress_Loop_Warnings (Flag17) + -- Note: the parser fills in the Identifier field if there is an + -- explicit loop identifier. Otherwise the parser leaves this field + -- set to Empty, and then the semantic processing for a loop statement + -- creates an identifier, setting the Has_Created_Identifier flag to + -- True. So after semantic anlaysis, the Identifier is always set, + -- referencing an identifier whose entity has an Ekind of E_Loop. + -------------------------- -- 5.5 Iteration Scheme -- -------------------------- @@ -4128,7 +4141,8 @@ package Sinfo is -- N_Exit_Statement -- Sloc points to EXIT -- Name (Node2) (set to Empty if no loop name present) - -- Condition (Node1) (set to Empty if no when part present) + -- Condition (Node1) (set to Empty if no WHEN part present) + -- Next_Exit_Statement (Node3-Sem): Next exit on chain ------------------------- -- 5.9 Goto Statement -- @@ -8247,6 +8261,9 @@ package Sinfo is function Next_Entity (N : Node_Id) return Node_Id; -- Node2 + function Next_Exit_Statement + (N : Node_Id) return Node_Id; -- Node3 + function Next_Implicit_With (N : Node_Id) return Node_Id; -- Node3 @@ -9168,6 +9185,9 @@ package Sinfo is procedure Set_Next_Entity (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Next_Exit_Statement + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Next_Implicit_With (N : Node_Id; Val : Node_Id); -- Node3 @@ -11360,6 +11380,7 @@ package Sinfo is pragma Inline (Name); pragma Inline (Names); pragma Inline (Next_Entity); + pragma Inline (Next_Exit_Statement); pragma Inline (Next_Implicit_With); pragma Inline (Next_Named_Actual); pragma Inline (Next_Pragma); @@ -11664,6 +11685,7 @@ package Sinfo is pragma Inline (Set_Name); pragma Inline (Set_Names); pragma Inline (Set_Next_Entity); + pragma Inline (Set_Next_Exit_Statement); pragma Inline (Set_Next_Implicit_With); pragma Inline (Set_Next_Named_Actual); pragma Inline (Set_Next_Pragma); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 1840ade..9e2b3c4 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -397,47 +397,46 @@ begin Write_Switch_Char ("wxx"); Write_Line ("Enable selected warning modes, xx = list of parameters:"); - Write_Line (" a turn on all optional info/warnings " & - "(except dhl.ot.w)"); + Write_Line (" a turn on all info/warnings marked below with +"); Write_Line (" A turn off all optional info/warnings"); - Write_Line (" .a* turn on warnings for failing assertion"); + Write_Line (" .a*+ turn on warnings for failing assertion"); Write_Line (" .A turn off warnings for failing assertion"); - Write_Line (" b turn on warnings for bad fixed value " & + Write_Line (" b+ turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & "(not multiple of small)"); - Write_Line (" .b* turn on warnings for biased representation"); + Write_Line (" .b*+ turn on warnings for biased representation"); Write_Line (" .B turn off warnings for biased representation"); - Write_Line (" c turn on warnings for constant conditional"); + Write_Line (" c+ turn on warnings for constant conditional"); Write_Line (" C* turn off warnings for constant conditional"); - Write_Line (" .c turn on warnings for unrepped components"); + Write_Line (" .c+ turn on warnings for unrepped components"); Write_Line (" .C* turn off warnings for unrepped components"); Write_Line (" d turn on warnings for implicit dereference"); Write_Line (" D* turn off warnings for implicit dereference"); Write_Line (" e treat all warnings (but not info) as errors"); Write_Line (" .e turn on every optional info/warning " & "(no exceptions)"); - Write_Line (" f turn on warnings for unreferenced formal"); + Write_Line (" f+ turn on warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal"); - Write_Line (" g* turn on warnings for unrecognized pragma"); + Write_Line (" g*+ turn on warnings for unrecognized pragma"); Write_Line (" G turn off warnings for unrecognized pragma"); Write_Line (" h turn on warnings for hiding variable"); Write_Line (" H* turn off warnings for hiding variable"); - Write_Line (" i* turn on warnings for implementation unit"); + Write_Line (" i*+ turn on warnings for implementation unit"); Write_Line (" I turn off warnings for implementation unit"); Write_Line (" .i turn on warnings for overlapping actuals"); Write_Line (" .I* turn off warnings for overlapping actuals"); - Write_Line (" j turn on warnings for obsolescent " & + Write_Line (" j+ turn on warnings for obsolescent " & "(annex J) feature"); Write_Line (" J* turn off warnings for obsolescent " & "(annex J) feature"); - Write_Line (" k turn on warnings on constant variable"); + Write_Line (" k+ turn on warnings on constant variable"); Write_Line (" K* turn off warnings on constant variable"); Write_Line (" l turn on warnings for missing " & "elaboration pragma"); Write_Line (" L* turn off warnings for missing " & "elaboration pragma"); - Write_Line (" m turn on warnings for variable assigned " & + Write_Line (" m+ turn on warnings for variable assigned " & "but not read"); Write_Line (" M* turn off warnings for variable assigned " & "but not read"); @@ -450,47 +449,48 @@ begin "but not read"); Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); - Write_Line (" p turn on warnings for ineffective pragma " & + Write_Line (" p+ turn on warnings for ineffective pragma " & "Inline in frontend"); Write_Line (" P* turn off warnings for ineffective pragma " & "Inline in frontend"); - Write_Line (" .p turn on warnings for suspicious parameter " & + Write_Line (" .p+ turn on warnings for suspicious parameter " & "order"); Write_Line (" .P* turn off warnings for suspicious parameter " & "order"); - Write_Line (" q* turn on warnings for questionable " & + Write_Line (" q*+ turn on warnings for questionable " & "missing parenthesis"); Write_Line (" Q turn off warnings for questionable " & "missing parenthesis"); - Write_Line (" r turn on warnings for redundant construct"); + Write_Line (" r+ turn on warnings for redundant construct"); Write_Line (" R* turn off warnings for redundant construct"); - Write_Line (" .r turn on warnings for object renaming function"); + Write_Line (" .r+ turn on warnings for object renaming function"); Write_Line (" .R* turn off warnings for object renaming function"); Write_Line (" s suppress all info/warnings"); Write_Line (" t turn on warnings for tracking deleted code"); Write_Line (" T* turn off warnings for tracking deleted code"); - Write_Line (" u turn on warnings for unused entity"); + Write_Line (" u+ turn on warnings for unused entity"); Write_Line (" U* turn off warnings for unused entity"); - Write_Line (" v* turn on warnings for unassigned variable"); + Write_Line (" v*+ turn on warnings for unassigned variable"); Write_Line (" V turn off warnings for unassigned variable"); - Write_Line (" .v* turn on info messages for reverse bit order"); + Write_Line (" .v*+ turn on info messages for reverse bit order"); Write_Line (" .V turn off info messages for reverse bit order"); - Write_Line (" w* turn on warnings for wrong low bound assumption"); + Write_Line (" w*+ turn on warnings for wrong low bound assumption"); Write_Line (" W turn off warnings for wrong low bound " & "assumption"); Write_Line (" .w turn on warnings on pragma Warnings Off"); Write_Line (" .W* turn off warnings on pragma Warnings Off"); - Write_Line (" x* turn on warnings for export/import"); + Write_Line (" x*+ turn on warnings for export/import"); Write_Line (" X turn off warnings for export/import"); - Write_Line (" .x turn on warnings for non-local exception"); + Write_Line (" .x+ turn on warnings for non-local exception"); Write_Line (" .X* turn off warnings for non-local exception"); - Write_Line (" y* turn on warnings for Ada 2005 incompatibility"); + Write_Line (" y*+ turn on warnings for Ada 2005 incompatibility"); Write_Line (" Y turn off warnings for Ada 2005 incompatibility"); - Write_Line (" z* turn on warnings for suspicious " & + Write_Line (" z*+ turn on warnings for suspicious " & "unchecked conversion"); Write_Line (" Z turn off warnings for suspicious " & "unchecked conversion"); Write_Line (" * indicates default in above list"); + Write_Line (" + indicates warning flag included in -gnatwa"); -- Line for -gnatW switch -- 2.7.4