Patchwork [Ada] Allow ! and !! insertions anywhere in compiler message

login
register
mail settings
Submitter Arnaud Charlet
Date July 8, 2013, 8:06 a.m.
Message ID <20130708080613.GA813@adacore.com>
Download mbox | patch
Permalink /patch/257491/
State New
Headers show

Comments

Arnaud Charlet - July 8, 2013, 8:06 a.m.
This patch relaxes the restriction that ! and !! must appear at the end
of a compiler message. They can now appear anywhere. This is only an
internal implementation change with no functional effect, so no test.

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-07-08  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Set_Msg_Txt): No longer sets Is_Style_Msg,
	Is_Warning_Msg, or Is_Unconditional_Msg (all are set elsewhere
	now).
	* errout.ads: Insertions ! and !! no longer have to be at the
	end of the message, they can be anywhere in the message.
	* erroutc.adb (Test_Style_Warning_Serious_Unconditional_Msg):
	Replaces Test_Style_Warning_Serious_Msg
	* erroutc.ads (Has_Double_Exclam): New flag New comments for
	existing flags (Test_Style_Warning_Serious_Unconditional_Msg):
	Replaces Test_Style_Warning_Serious_Msg
	* errutil.adb (Test_Style_Warning_Serious_Unconditional_Msg):
	Replaces Test_Style_Warning_Serious_Msg

Patch

Index: errout.adb
===================================================================
--- errout.adb	(revision 200688)
+++ errout.adb	(working copy)
@@ -153,8 +153,7 @@ 
    --  be one of the special insertion characters (see documentation in spec).
    --  Flag is the location at which the error is to be posted, which is used
    --  to determine whether or not the # insertion needs a file name. The
-   --  variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
-   --  Is_Unconditional_Msg are set on return.
+   --  variables Msg_Buffer are set on return Msglen.
 
    procedure Set_Posted (N : Node_Id);
    --  Sets the Error_Posted flag on the given node, and all its parents
@@ -283,7 +282,7 @@ 
       --  Start of processing for new message
 
       Sindex := Get_Source_File_Index (Flag_Location);
-      Test_Style_Warning_Serious_Msg (Msg);
+      Test_Style_Warning_Serious_Unconditional_Msg (Msg);
       Orig_Loc := Original_Location (Flag_Location);
 
       --  If the current location is in an instantiation, the issue arises of
@@ -726,7 +725,7 @@ 
       if Suppress_Message
         and then not All_Errors_Mode
         and then not Is_Warning_Msg
-        and then Msg (Msg'Last) /= '!'
+        and then not Is_Unconditional_Msg
       then
          if not Continuation then
             Last_Killed := True;
@@ -787,9 +786,9 @@ 
          elsif Debug_Flag_GG then
             null;
 
-         --  Keep warning if message text ends in !!
+         --  Keep warning if message text contains !!
 
-         elsif Msg (Msg'Last) = '!' and then Msg (Msg'Last - 1) = '!' then
+         elsif Has_Double_Exclam then
             null;
 
          --  Here is where we delete a warning from a with'ed unit
@@ -1123,7 +1122,7 @@ 
          return;
       end if;
 
-      Test_Style_Warning_Serious_Msg (Msg);
+      Test_Style_Warning_Serious_Unconditional_Msg (Msg);
 
       --  Special handling for warning messages
 
@@ -1163,7 +1162,7 @@ 
       --  Test for message to be output
 
       if All_Errors_Mode
-        or else Msg (Msg'Last) = '!'
+        or else Is_Unconditional_Msg
         or else Is_Warning_Msg
         or else OK_Node (N)
         or else (Msg (Msg'First) = '\' and then not Last_Killed)
@@ -2711,7 +2710,6 @@ 
 
    begin
       Manual_Quote_Mode := False;
-      Is_Unconditional_Msg := False;
       Msglen := 0;
       Flag_Source := Get_Source_File_Index (Flag);
 
@@ -2776,7 +2774,7 @@ 
                Set_Msg_Char ('"');
 
             when '!' =>
-               Is_Unconditional_Msg := True;
+               null; -- already dealt with
 
             when '?' =>
                Set_Msg_Insertion_Warning;
Index: errout.ads
===================================================================
--- errout.ads	(revision 200688)
+++ errout.ads	(working copy)
@@ -101,10 +101,9 @@ 
    --        messages. Warning messages are only suppressed for case 1, and
    --        when they come from other than the main extended unit.
 
-   --  This normal suppression action may be overridden in cases 2-5 (but not
-   --  in case 1) by setting All_Errors mode, or by setting the special
-   --  unconditional message insertion character (!) at the end of the message
-   --  text as described below.
+   --  This normal suppression action may be overridden in cases 2-5 (but
+   --  not in case 1) by setting All_Errors mode, or by setting the special
+   --  unconditional message insertion character (!) as described below.
 
    ---------------------------------------------------------
    -- Error Message Text and Message Insertion Characters --
@@ -230,7 +229,7 @@ 
    --      name is defined, this insertion character has no effect.
 
    --    Insertion character ! (Exclamation: unconditional message)
-   --      The character ! appearing as the last character of a message makes
+   --      The character ! appearing anywhere in the text of a message makes
    --      the message unconditional which means that it is output even if it
    --      would normally be suppressed. See section above for a description
    --      of the cases in which messages are normally suppressed. Note that
@@ -249,7 +248,7 @@ 
 
    --    Insertion character !! (Double exclamation: unconditional warning)
    --      Normally warning messages issued in other than the main unit are
-   --      suppressed. If the message ends with !! then this suppression is
+   --      suppressed. If the message contains !! then this suppression is
    --      avoided. This is currently used by the Compile_Time_Warning pragma
    --      to ensure the message for a with'ed unit is output, and for warnings
    --      on ineffective back-end inlining, which is detected in units that
Index: errutil.adb
===================================================================
--- errutil.adb	(revision 200688)
+++ errutil.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1991-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1991-2013, 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- --
@@ -163,9 +163,9 @@ 
       --  Corresponds to the Sptr value in the error message object
 
       Optr : Source_Ptr renames Flag_Location;
-      --  Corresponds to the Optr value in the error message object. Note
-      --  that for this usage, Sptr and Optr always have the same value,
-      --  since we do not have to worry about generic instantiations.
+      --  Corresponds to the Optr value in the error message object. Note that
+      --  for this usage, Sptr and Optr always have the same value, since we do
+      --  not have to worry about generic instantiations.
 
    begin
       if Errors_Must_Be_Ignored then
@@ -176,7 +176,7 @@ 
          raise Error_Msg_Exception;
       end if;
 
-      Test_Style_Warning_Serious_Msg (Msg);
+      Test_Style_Warning_Serious_Unconditional_Msg (Msg);
       Set_Msg_Text (Msg, Sptr);
 
       --  Kill continuation if parent message killed
@@ -680,8 +680,8 @@ 
    ------------------
 
    procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
-      C : Character;         -- Current character
-      P : Natural;           -- Current index;
+      C : Character; -- Current character
+      P : Natural;   -- Current index;
 
    begin
       Manual_Quote_Mode := False;
@@ -744,7 +744,7 @@ 
             Set_Msg_Char ('"');
 
          elsif C = '!' then
-            Is_Unconditional_Msg := True;
+            null;
 
          elsif C = '?' then
             null;
Index: erroutc.adb
===================================================================
--- erroutc.adb	(revision 200688)
+++ erroutc.adb	(working copy)
@@ -1226,22 +1226,24 @@ 
    -- Test_Style_Warning_Serious_Msg --
    ------------------------------------
 
-   procedure Test_Style_Warning_Serious_Msg (Msg : String) is
+   procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
    begin
+      --  Nothing to do for continuation line
+
       if Msg (Msg'First) = '\' then
          return;
       end if;
 
-      Is_Serious_Error := True;
-      Is_Warning_Msg   := False;
+      --  Set initial values of globals (may be changed during scan)
 
+      Is_Serious_Error     := True;
+      Is_Unconditional_Msg := False;
+      Is_Warning_Msg       := False;
+      Has_Double_Exclam    := False;
+
       Is_Style_Msg :=
         (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
 
-      if Is_Style_Msg then
-         Is_Serious_Error := False;
-      end if;
-
       for J in Msg'Range loop
          if Msg (J) = '?'
            and then (J = Msg'First or else Msg (J - 1) /= ''')
@@ -1249,6 +1251,16 @@ 
             Is_Warning_Msg := True;
             Warning_Msg_Char := ' ';
 
+         elsif Msg (J) = '!'
+           and then (J = Msg'First or else Msg (J - 1) /= ''')
+         then
+            Is_Unconditional_Msg := True;
+            Warning_Msg_Char := ' ';
+
+            if J < Msg'Last and then Msg (J + 1) = '!' then
+               Has_Double_Exclam := True;
+            end if;
+
          elsif Msg (J) = '<'
            and then (J = Msg'First or else Msg (J - 1) /= ''')
          then
@@ -1265,7 +1277,7 @@ 
       if Is_Warning_Msg or Is_Style_Msg then
          Is_Serious_Error := False;
       end if;
-   end Test_Style_Warning_Serious_Msg;
+   end Test_Style_Warning_Serious_Unconditional_Msg;
 
    --------------------------------
    -- Validate_Specific_Warnings --
Index: erroutc.ads
===================================================================
--- erroutc.ads	(revision 200688)
+++ erroutc.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, 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- --
@@ -47,8 +47,20 @@ 
    Flag_Source : Source_File_Index;
    --  Source file index for source file where error is being posted
 
+   Has_Double_Exclam : Boolean := False;
+   --  Set true to indicate that the current message contains the insertion
+   --  sequence !! (force warnings even in non-main unit source files).
+
+   Is_Serious_Error : Boolean := False;
+   --  Set True for a serious error (i.e. any message that is not a warning
+   --  or style message, and that does not contain a | insertion character).
+
+   Is_Unconditional_Msg : Boolean := False;
+   --  Set True to indicate that the current message contains the insertion
+   --  character ! and is thus to be treated as an unconditional message.
+
    Is_Warning_Msg : Boolean := False;
-   --  Set True to indicate if current message is warning message
+   --  Set True to indicate if current message is warning message (contains ?)
 
    Warning_Msg_Char : Character;
    --  Warning character, valid only if Is_Warning_Msg is True
@@ -61,12 +73,6 @@ 
    --  Set True to indicate if the current message is a style message
    --  (i.e. a message whose text starts with the characters "(style)").
 
-   Is_Serious_Error : Boolean := False;
-   --  Set by Set_Msg_Text to indicate if current message is serious error
-
-   Is_Unconditional_Msg : Boolean := False;
-   --  Set by Set_Msg_Text to indicate if current message is unconditional
-
    Kill_Message : Boolean := False;
    --  A flag used to kill weird messages (e.g. those containing uninterpreted
    --  implicit type references) if we have already seen at least one message
@@ -490,14 +496,26 @@ 
    --  Called in response to a pragma Warnings (On) to record the source
    --  location from which warnings are to be turned back on.
 
-   procedure Test_Style_Warning_Serious_Msg (Msg : String);
-   --  Sets Is_Warning_Msg true if Msg is a warning message (contains a
-   --  question mark character), and False otherwise. Is_Style_Msg is set true
-   --  if Msg is a style message (starts with "(style)". Sets Is_Serious_Error
-   --  True unless the message is a warning or style/info message or contains
-   --  the character | indicating a non-serious error message. Note that the
-   --  call has no effect for continuation messages (those whose first
-   --  character is '\').
+   procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String);
+   --  Scans message text and sets the following variables:
+   --
+   --    Is_Warning_Msg is set True if Msg is a warning message (contains a
+   --    question mark character), and False otherwise.
+   --
+   --    Is_Style_Msg is set True if Msg is a style message (starts with
+   --    "(style)") and False otherwise.
+   --
+   --    Is_Serious_Error is set to True unless the message is a warning or
+   --    style message or contains the character | (non-serious error).
+   --
+   --    Is_Unconditional_Msg is set True if the message contains the character
+   --    ! and is otherwise set False.
+   --
+   --    Has_Double_Exclam is set True if the message contains the sequence !!
+   --    and is otherwise set False.
+   --
+   --  Note that the call has no effect for continuation messages (those whose
+   --  first character is '\'), and all variables are left unchanged.
 
    function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
    --  Determines if given location is covered by a warnings off suppression