From patchwork Thu Sep 9 09:57:19 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 64274 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 26D89B70A2 for ; Thu, 9 Sep 2010 19:57:35 +1000 (EST) Received: (qmail 18330 invoked by alias); 9 Sep 2010 09:57:33 -0000 Received: (qmail 18312 invoked by uid 22791); 9 Sep 2010 09:57:29 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 09 Sep 2010 09:57:22 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id CC2A5CB021E; Thu, 9 Sep 2010 11:57:19 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id JhWiu4Qok8SM; Thu, 9 Sep 2010 11:57:19 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id B7714CB01D8; Thu, 9 Sep 2010 11:57:19 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 996EAD9BA8; Thu, 9 Sep 2010 11:57:19 +0200 (CEST) Date: Thu, 9 Sep 2010 11:57:19 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Fix missing warnings from Restriction_Warnings Message-ID: <20100909095719.GA2122@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch fixes several cases in which pragma Restriction_Warnings was not generating warnings when a restriction was violated. The problem was calling Restriction_Active, when instead the required action was simply to test Restrictions.Set. A new function provides a convenient abstraction for this test Restriction_Check_Required. The following, compiled with -gnatld7 -gnatj60 -gnatf shows all the cases being caught (prior to this patch, most were missed) 1. --pragma Restrictions (No_Wide_Characters); 2. pragma Restriction_Warnings (No_Wide_Characters); 3. procedure No_Wide_Characters is 4. W_Char_1 : Wide_Character := 'a'; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 5. W_String_1 : Wide_String := "a"; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 6. 7. subtype My_Wide_Character is Wide_Character; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 8. subtype My_Wide_String is Wide_String (1 .. 5); -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 9. 10. W_Char_2 : My_Wide_Character := 'a'; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 11. W_String_2 : My_Wide_String := "12345"; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 12. 13. type My_Array_1 14. is array (Wide_Character'First .. -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 15. Wide_Character'Last) of Integer; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 16. 17. procedure Proc 18. (W_Ch : Standard.Wide_Character; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 19. W_Str : Wide_String) -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 20. is 21. begin 22. null; 23. end; 24. 25. function Fun_W_Ch 26. (Ch : Character) 27. return Standard.Wide_Character -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 28. is 29. begin 30. return '["1234"]'; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 31. end; 32. 33. function Fun_W_Str 34. (Str : String) 35. return Wide_String -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 36. is 37. begin 38. return "["1234"]"; -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 39. end; 40. 41. type R is ('a', '["1234"]'); -- FLAG | >>> warning: violation of restriction "No_Wide_Characters" at line 2 42. 43. begin 44. null; 45. end No_Wide_Characters; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-09-09 Robert Dewar * exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb, sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed where appropriate. * restrict.ads, restrict.adb: Ditto. (Restriction_Check_Needed): New function Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 164059) +++ sem_ch3.adb (working copy) @@ -2779,7 +2779,7 @@ package body Sem_Ch3 is -- Has_Stream just for efficiency reasons. There is no point in -- spending time on a Has_Stream check if the restriction is not set. - if Restrictions.Set (No_Streams) then + if Restriction_Check_Required (No_Streams) then if Has_Stream (T) then Check_Restriction (No_Streams, N); end if; @@ -13659,7 +13659,7 @@ package body Sem_Ch3 is -- Check violation of No_Wide_Characters - if Restriction_Active (No_Wide_Characters) then + if Restriction_Check_Required (No_Wide_Characters) then Get_Name_String (Chars (L)); if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then Index: frontend.adb =================================================================== --- frontend.adb (revision 164000) +++ frontend.adb (working copy) @@ -290,7 +290,7 @@ begin -- explicit switch turning off Warn_On_Non_Local_Exception, then turn on -- this warning by default if we have encountered an exception handler. - if Restriction_Active (No_Exception_Propagation) + if Restriction_Check_Required (No_Exception_Propagation) and then not No_Warn_On_Non_Local_Exception and then Exception_Handler_Encountered then Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 164000) +++ sem_ch9.adb (working copy) @@ -1182,9 +1182,9 @@ package body Sem_Ch9 is -- and the No_Local_Protected_Objects restriction applies, issue a -- warning that objects of the type will violate the restriction. - if not Is_Library_Level_Entity (T) + if Restriction_Check_Required (No_Local_Protected_Objects) + and then not Is_Library_Level_Entity (T) and then Comes_From_Source (T) - and then Restrictions.Set (No_Local_Protected_Objects) then Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); @@ -1995,9 +1995,9 @@ package body Sem_Ch9 is -- No_Task_Hierarchy restriction applies, issue a warning that objects -- of the type will violate the restriction. - if not Is_Library_Level_Entity (T) + if Restriction_Check_Required (No_Task_Hierarchy) + and then not Is_Library_Level_Entity (T) and then Comes_From_Source (T) - and then Restrictions.Set (No_Task_Hierarchy) then Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); @@ -2193,18 +2193,10 @@ package body Sem_Ch9 is -- Entry family with non-static bounds else - -- If restriction is set, then this is an error + -- Record an unknown count restriction, and if the + -- restriction is active, post a message or warning. - if Restrictions.Set (R) then - Error_Msg_N - ("static subtype required by Restriction pragma", - DSD); - - -- Otherwise we record an unknown count restriction - - else - Check_Restriction (R, D); - end if; + Check_Restriction (R, D); end if; end; end if; Index: sem_ch10.adb =================================================================== --- sem_ch10.adb (revision 164000) +++ sem_ch10.adb (working copy) @@ -2325,7 +2325,7 @@ package body Sem_Ch10 is -- Note: this is not quite right if the user defines one of these units -- himself, but that's a marginal case, and fixing it is hard ??? - if Restriction_Active (No_Obsolescent_Features) then + if Restriction_Check_Required (No_Obsolescent_Features) then declare F : constant File_Name_Type := Unit_File_Name (Get_Source_Unit (U)); Index: sem_res.adb =================================================================== --- sem_res.adb (revision 164058) +++ sem_res.adb (working copy) @@ -4759,7 +4759,7 @@ package body Sem_Res is -- violated if either operand can be negative for mod, or for rem -- if both operands can be negative. - if Restrictions.Set (No_Implicit_Conditionals) + if Restriction_Check_Required (No_Implicit_Conditionals) and then Nkind_In (N, N_Op_Rem, N_Op_Mod) then declare Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 164000) +++ sem_attr.adb (working copy) @@ -2549,7 +2549,7 @@ package body Sem_Attr is -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since -- this flag gets set by Find_Type in this situation. - if Restriction_Active (No_Obsolescent_Features) + if Restriction_Check_Required (No_Obsolescent_Features) and then Ada_Version >= Ada_2005 and then Ekind (P_Type) = E_Incomplete_Type then Index: exp_ch11.adb =================================================================== --- exp_ch11.adb (revision 164000) +++ exp_ch11.adb (working copy) @@ -2006,7 +2006,7 @@ package body Exp_Ch11 is procedure Warn_If_No_Propagation (N : Node_Id) is begin - if Restriction_Active (No_Exception_Propagation) + if Restriction_Check_Required (No_Exception_Propagation) and then Warn_On_Non_Local_Exception then Warn_No_Exception_Propagation_Active (N); Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 164000) +++ sem_ch4.adb (working copy) @@ -617,7 +617,7 @@ package body Sem_Ch4 is -- Has_Stream just for efficiency reasons. There is no point in -- spending time on a Has_Stream check if the restriction is not set. - if Restrictions.Set (No_Streams) then + if Restriction_Check_Required (No_Streams) then if Has_Stream (Designated_Type (Acc_Type)) then Check_Restriction (No_Streams, N); end if; Index: restrict.adb =================================================================== --- restrict.adb (revision 164056) +++ restrict.adb (working copy) @@ -144,8 +144,8 @@ package body Restrict is -- Start of processing for Check_Obsolescent_2005_Entity begin - if Ada_Version >= Ada_2005 - and then Restriction_Active (No_Obsolescent_Features) + if Restriction_Check_Required (No_Obsolescent_Features) + and then Ada_Version >= Ada_2005 and then Chars_Is (Scope (E), "handling") and then Chars_Is (Scope (Scope (E)), "characters") and then Chars_Is (Scope (Scope (Scope (E))), "ada") @@ -298,8 +298,8 @@ package body Restrict is -- Start of processing for Check_Restriction begin - -- In CodePeer mode, we do not want to check for any restriction, or - -- set additional restrictions than those already set in gnat1drv.adb + -- In CodePeer mode, we do not want to check for any restriction, or set + -- additional restrictions other than those already set in gnat1drv.adb -- so that we have consistency between each compilation. if CodePeer_Mode then @@ -403,7 +403,7 @@ package body Restrict is procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is begin - if Restriction_Active (No_Wide_Characters) + if Restriction_Check_Required (No_Wide_Characters) and then Comes_From_Source (N) then declare @@ -586,6 +586,15 @@ package body Restrict is return Restrictions.Set (R) and then not Restriction_Warnings (R); end Restriction_Active; + -------------------------------- + -- Restriction_Check_Required -- + -------------------------------- + + function Restriction_Check_Required (R : All_Restrictions) return Boolean is + begin + return Restrictions.Set (R); + end Restriction_Check_Required; + --------------------- -- Restriction_Msg -- --------------------- Index: restrict.ads =================================================================== --- restrict.ads (revision 164056) +++ restrict.ads (working copy) @@ -292,7 +292,19 @@ package Restrict is -- used where the compiled code depends on whether the restriction is -- active. Always use Check_Restriction to record a violation. Note that -- this returns False if we only have a Restriction_Warnings set, since - -- restriction warnings should never affect generated code. + -- restriction warnings should never affect generated code. If you want + -- to know if a call to Check_Restriction is needed then use the function + -- Restriction_Check_Required instead. + + function Restriction_Check_Required (R : All_Restrictions) return Boolean; + pragma Inline (Restriction_Check_Required); + -- Determines if either a Restriction_Warnings or Restrictions pragma has + -- been given for the specified restriction. If true, then a subsequent + -- call to Check_Restriction is required if the restriction is violated. + -- This must not be used to guard code generation that depends on whether + -- a restriction is active (see Restriction_Active above). Typically it + -- is used to avoid complex code to determine if a restriction is violated, + -- executing this code only if needed. function Restricted_Profile return Boolean; -- Tests if set of restrictions corresponding to Profile (Restricted) is