Patchwork [Ada] Fix missing warnings from Restriction_Warnings

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 9, 2010, 9:57 a.m.
Message ID <20100909095719.GA2122@adacore.com>
Download mbox | patch
Permalink /patch/64274/
State New
Headers show

Comments

Arnaud Charlet - Sept. 9, 2010, 9:57 a.m.
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  <dewar@adacore.com>

	* 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

Patch

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