Patchwork [Ada] Implement tagging of warning messages

login
register
mail settings
Submitter Arnaud Charlet
Date Jan. 2, 2013, 9:46 a.m.
Message ID <20130102094618.GA2186@adacore.com>
Download mbox | patch
Permalink /patch/208982/
State New
Headers show

Comments

Arnaud Charlet - Jan. 2, 2013, 9:46 a.m.
This patch implements the -gnatw.d switch to activate tagging of warning
messages. With this switch set, warning messages will have a tag at the
end which is one of:

   [-gnatw?]               ? in a .. z
   [-gnatw.?]              ? in a .. z
   [enabled by default]

So, similar to the tags emitted by GCC for other languages.

The patch enables the general mechanism (using new insertion tags ??
and ?x?). So far only a few messages have been tagged, but eventually
we will tag as many warning messages as possible. The following source
program is compiled with -gnatj.p.d -gnatj70:

     1. function warndoc (a, b, c : integer) return integer is
     2.    x : string := %abc%;
                         |
        >>> warning: use of "%" is an obsolescent feature (RM
            J.2(4)), use """ instead [-gnatwj]

     3. begin
     4.    if b > 0 then
           |
        >>> warning: "return" statement missing following this
            statement, Program_Error may be raised at run time
            [enabled by default]

     5.       return warndoc (b, a, c);
                     |
        >>> warning: actuals for this call may be in wrong order
            [-gnatw.p]

     6.    end if;
     7. end;

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

2013-01-02  Robert Dewar  <dewar@adacore.com>

	* err_vars.ads (Warning_Doc_Switch): New flag.
	* errout.adb (Error_Msg_Internal): Implement new warning flag
	doc tag stuff (Set_Msg_Insertion_Warning): New procedure.
	* errout.ads: Document new insertion sequences ?? ?x? ?.x?
	* erroutc.adb (Output_Msg_Text): Handle ?? and ?x? warning doc
	tag stuff.
	* erroutc.ads (Warning_Msg_Char): New variable.
	(Warn_Chr): New field in error message object.
	* errutil.adb (Error_Msg): Set Warn_Chr in error message object.
	* sem_ch13.adb: Minor reformatting.
	* warnsw.adb: Add handling for -gnatw.d and -gnatw.D
	(Warning_Doc_Switch).
	* warnsw.ads: Add handling of -gnatw.d/.D switches (warning
	doc tag).

Patch

Index: err_vars.ads
===================================================================
--- err_vars.ads	(revision 194776)
+++ err_vars.ads	(working copy)
@@ -88,6 +88,12 @@ 
    --  Source_Reference line, then this is initialized to No_Source_File,
    --  to force an initial reference to the real source file name.
 
+   Warning_Doc_Switch : Boolean := False;
+   --  If this is set True, then the ??/?x?/?.x? sequences in error messages
+   --  are active (see errout.ads for details). If this switch is False, then
+   --  these sequences are ignored (i.e. simply equivalent to a single ?). The
+   --  -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.
+
    ----------------------------------------
    -- Error Message Insertion Parameters --
    ----------------------------------------
@@ -133,7 +139,9 @@ 
    --  before any call to Error_Msg_xxx with a < insertion character present.
    --  Setting is irrelevant if no < insertion character is present. Note
    --  that it is not necessary to reset this after using it, since the proper
-   --  procedure is always to set it before issuing such a message.
+   --  procedure is always to set it before issuing such a message. Note that
+   --  the warning documentation tag is always [enabled by default] in the
+   --  case where this flag is True.
 
    Error_Msg_String : String (1 .. 4096);
    Error_Msg_Strlen : Natural;
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 194776)
+++ sem_res.adb	(working copy)
@@ -3095,7 +3095,7 @@ 
 
                if Wrong_Order then
                   Error_Msg_N
-                    ("actuals for this call may be in wrong order?", N);
+                    ("?P?actuals for this call may be in wrong order", N);
                end if;
             end;
          end;
Index: warnsw.adb
===================================================================
--- warnsw.adb	(revision 194776)
+++ warnsw.adb	(working copy)
@@ -22,9 +22,9 @@ 
 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
 --                                                                          --
 ------------------------------------------------------------------------------
+with Err_Vars; use Err_Vars;
+with Opt;      use Opt;
 
-with Opt; use Opt;
-
 package body Warnsw is
 
    ----------------------------
@@ -52,6 +52,12 @@ 
          when 'C' =>
             Warn_On_Unrepped_Components         := False;
 
+         when 'd' =>
+            Warning_Doc_Switch                     := True;
+
+         when 'D' =>
+            Warning_Doc_Switch                     := False;
+
          when 'e' =>
             Address_Clause_Overlay_Warnings     := True;
             Check_Unreferenced                  := True;
Index: errout.adb
===================================================================
--- errout.adb	(revision 194776)
+++ errout.adb	(working copy)
@@ -821,9 +821,7 @@ 
       --  with a comma space separator (eliminating a possible (style) or
       --  info prefix).
 
-      if Error_Msg_Line_Length /= 0
-        and then Continuation
-      then
+      if Error_Msg_Line_Length /= 0 and then Continuation then
          Cur_Msg := Errors.Last;
 
          declare
@@ -894,12 +892,24 @@ 
               Msg_Buffer (M .. Msglen);
             Newl := Newl + Msglen - M + 1;
             Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
+
+            --  Update warning msg flag and message doc char if needed
+
+            if Is_Warning_Msg then
+               if not Errors.Table (Cur_Msg).Warn then
+                  Errors.Table (Cur_Msg).Warn := True;
+                  Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
+
+               elsif Warning_Msg_Char /= ' ' then
+                  Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
+               end if;
+            end if;
          end;
 
          return;
       end if;
 
-      --  Otherwise build error message object for new message
+      --  Here we build a new error object
 
       Errors.Append
         ((Text     => new String'(Msg_Buffer (1 .. Msglen)),
@@ -911,6 +921,7 @@ 
           Line     => Get_Physical_Line_Number (Sptr),
           Col      => Get_Column_Number (Sptr),
           Warn     => Is_Warning_Msg,
+          Warn_Chr => Warning_Msg_Char,
           Style    => Is_Style_Msg,
           Serious  => Is_Serious_Error,
           Uncond   => Is_Unconditional_Msg,
@@ -2655,6 +2666,40 @@ 
       C : Character;   -- Current character
       P : Natural;     -- Current index;
 
+      procedure Set_Msg_Insertion_Warning;
+      --  Deal with ? ?? ?x? ?X? insertion sequences
+
+      -------------------------------
+      -- Set_Msg_Insertion_Warning --
+      -------------------------------
+
+      procedure Set_Msg_Insertion_Warning is
+      begin
+         Warning_Msg_Char := ' ';
+
+         if P + 1 <= Text'Last and then Text (P) = '?' then
+            if Warning_Doc_Switch then
+               Warning_Msg_Char := '?';
+            end if;
+
+            P := P + 1;
+
+         elsif P + 2 <= Text'Last
+           and then (Text (P) in 'a' .. 'z'
+                      or else
+                     Text (P) in 'A' .. 'Z')
+           and then Text (P + 1) = '?'
+         then
+            if Warning_Doc_Switch then
+               Warning_Msg_Char := Text (P);
+            end if;
+
+            P := P + 2;
+         end if;
+      end Set_Msg_Insertion_Warning;
+
+   --  Start of processing for Set_Msg_Text
+
    begin
       Manual_Quote_Mode := False;
       Is_Unconditional_Msg := False;
@@ -2725,11 +2770,17 @@ 
                Is_Unconditional_Msg := True;
 
             when '?' =>
-               null; -- already dealt with
+               Set_Msg_Insertion_Warning;
 
             when '<' =>
-               null; -- already dealt with
 
+               --  If tagging of messages is enabled, and this is a warning,
+               --  then it is treated as being [enabled by default].
+
+               if Error_Msg_Warn and Warning_Doc_Switch then
+                  Warning_Msg_Char := '?';
+               end if;
+
             when '|' =>
                null; -- already dealt with
 
Index: errout.ads
===================================================================
--- errout.ads	(revision 194776)
+++ errout.ads	(working copy)
@@ -59,6 +59,12 @@ 
    Error_Msg_Exception : exception renames Err_Vars.Error_Msg_Exception;
    --  Exception raised if Raise_Exception_On_Error is true
 
+   Warning_Doc_Switch : Boolean renames Err_Vars.Warning_Doc_Switch;
+   --  If this is set True, then the ??/?x?/?.x? sequences in error messages
+   --  are active (see errout.ads for details). If this switch is False, then
+   --  these sequences are ignored (i.e. simply equivalent to a single ?). The
+   --  -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.
+
    -----------------------------------
    -- Suppression of Error Messages --
    -----------------------------------
@@ -275,6 +281,24 @@ 
    --      messages, and the usual style is to include it, since it makes it
    --      clear that the continuation is part of a warning message.
 
+   --    Insertion character ?? (two question marks)
+   --      Like ?, but if the flag Warn_Doc_Switch is True, adds the string
+   --      "[enabled by default]" at the end of the warning message. In the
+   --      case of continuations, use this in each continuation message.
+
+   --    Insertion character ?x? (warning with switch)
+   --      Like ?, but if the flag Warn_Doc_Switch is True, adds the string
+   --      "[-gnatwx]" at the end of the warning message. x is a lower case
+   --      letter. In the case of continuations, use this on each continuation
+   --      message.
+
+   --    Insertion character ?X? (warning with dot switch)
+   --      Like ?, but if the flag Warn_Doc_Switch is True, adds the string
+   --      "[-gnatw.x]" at the end of the warning message. X is an upper case
+   --      letter corresponding to the lower case letter x in the message. In
+   --      the case of continuations, use this on each continuation
+   --      message.
+
    --    Insertion character < (Less Than: conditional warning message)
    --      The character < appearing anywhere in a message is used for a
    --      conditional error message. If Error_Msg_Warn is True, then the
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 194776)
+++ sem_ch6.adb	(working copy)
@@ -6912,10 +6912,10 @@ 
          if Mode = 'F' then
             if not Raise_Exception_Call then
                Error_Msg_N
-                 ("?RETURN statement missing following this statement!",
+                 ("??RETURN statement missing following this statement!",
                   Last_Stm);
                Error_Msg_N
-                 ("\?Program_Error may be raised at run time!",
+                 ("\??Program_Error may be raised at run time!",
                   Last_Stm);
             end if;
 
Index: scn.adb
===================================================================
--- scn.adb	(revision 194776)
+++ scn.adb	(working copy)
@@ -339,9 +339,9 @@ 
 
             if Warn_On_Obsolescent_Feature then
                Error_Msg
-                 ("use of "":"" is an obsolescent feature (RM J.2(3))?", S);
+                 ("?j?use of "":"" is an obsolescent feature (RM J.2(3))", S);
                Error_Msg
-                 ("\use ""'#"" instead?", S);
+                 ("\?j?use ""'#"" instead", S);
             end if;
          end if;
       end Check_Obsolete_Base_Char;
@@ -382,8 +382,8 @@ 
 
                if Warn_On_Obsolescent_Feature then
                   Error_Msg_SC
-                    ("use of ""'%"" is an obsolescent feature (RM J.2(4))?");
-                  Error_Msg_SC ("\use """""" instead?");
+                    ("?j?use of ""'%"" is an obsolescent feature (RM J.2(4))");
+                  Error_Msg_SC ("\?j?use """""" instead");
                end if;
             end if;
 
@@ -398,8 +398,8 @@ 
 
                if Warn_On_Obsolescent_Feature then
                   Error_Msg_SC
-                    ("use of ""'!"" is an obsolescent feature (RM J.2(2))?");
-                  Error_Msg_SC ("\use ""'|"" instead?");
+                    ("?j?use of ""'!"" is an obsolescent feature (RM J.2(2))");
+                  Error_Msg_SC ("\?j?use ""'|"" instead");
                end if;
             end if;
 
Index: errutil.adb
===================================================================
--- errutil.adb	(revision 194776)
+++ errutil.adb	(working copy)
@@ -211,6 +211,7 @@ 
       Errors.Table (Cur_Msg).Col      := Get_Column_Number (Sptr);
       Errors.Table (Cur_Msg).Style    := Is_Style_Msg;
       Errors.Table (Cur_Msg).Warn     := Is_Warning_Msg;
+      Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
       Errors.Table (Cur_Msg).Serious  := Is_Serious_Error;
       Errors.Table (Cur_Msg).Uncond   := Is_Unconditional_Msg;
       Errors.Table (Cur_Msg).Msg_Cont := Continuation;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 194783)
+++ sem_ch13.adb	(working copy)
@@ -1610,6 +1610,7 @@ 
                   if Nkind (Parent (N)) = N_Compilation_Unit then
                      declare
                         Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
+
                      begin
                         if No (Pragmas_After (Aux)) then
                            Set_Pragmas_After (Aux, New_List);
@@ -2014,9 +2015,9 @@ 
 
       if Warn_On_Obsolescent_Feature then
          Error_Msg_N
-           ("at clause is an obsolescent feature (RM J.7(2))?", N);
+           ("?j?at clause is an obsolescent feature (RM J.7(2))", N);
          Error_Msg_N
-           ("\use address attribute definition clause instead?", N);
+           ("\?j?use address attribute definition clause instead", N);
       end if;
 
       --  Rewrite as address clause
@@ -4720,9 +4721,9 @@ 
 
             if Warn_On_Obsolescent_Feature then
                Error_Msg_N
-                 ("mod clause is an obsolescent feature (RM J.8)?", N);
+                 ("?j?mod clause is an obsolescent feature (RM J.8)", N);
                Error_Msg_N
-                 ("\use alignment attribute definition clause instead?", N);
+                 ("\?j?use alignment attribute definition clause instead?", N);
             end if;
 
             if Present (P) then
Index: erroutc.adb
===================================================================
--- erroutc.adb	(revision 194776)
+++ erroutc.adb	(working copy)
@@ -442,13 +442,37 @@ 
       Length : Nat;
       --  Maximum total length of lines
 
-      Txt   : constant String_Ptr := Errors.Table (E).Text;
-      Len   : constant Natural    := Txt'Length;
-      Ptr   : Natural;
-      Split : Natural;
-      Start : Natural;
+      Text     : constant String_Ptr := Errors.Table (E).Text;
+      Warn     : constant Boolean    := Errors.Table (E).Warn;
+      Warn_Chr : constant Character  := Errors.Table (E).Warn_Chr;
+      Warn_Tag : String_Ptr;
+      Ptr      : Natural;
+      Split    : Natural;
+      Start    : Natural;
 
    begin
+      --  Add warning doc tag if needed
+
+      if Warn and then Warn_Chr /= ' ' then
+         if Warn_Chr = '?' then
+            Warn_Tag := new String'(" [enabled by default]");
+
+         elsif Warn_Chr in 'a' .. 'z' then
+            Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']');
+
+         else pragma Assert (Warn_Chr in 'A' .. 'Z');
+            Warn_Tag :=
+              new String'(" [-gnatw."
+                          & Character'Val (Character'Pos (Warn_Chr) + 32)
+                          & ']');
+         end if;
+
+      else
+         Warn_Tag := new String'("");
+      end if;
+
+      --  Set error message line length
+
       if Error_Msg_Line_Length = 0 then
          Length := Nat'Last;
       else
@@ -457,87 +481,95 @@ 
 
       Max := Integer (Length - Column + 1);
 
-      --  For warning message, add "warning: " unless msg starts with "info: "
+      declare
+         Txt : constant String := Text.all & Warn_Tag.all;
+         Len : constant Natural    := Txt'Length;
 
-      if Errors.Table (E).Warn then
-         if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
-            Write_Str ("warning: ");
-            Max := Max - 9;
-         end if;
+      begin
+         --  For warning, add "warning: " unless msg starts with "info: "
 
-      --  No prefix needed for style message, since "(style)" is there already
+         if Errors.Table (E).Warn then
+            if Len < 6
+              or else Txt (Txt'First .. Txt'First + 5) /= "info: "
+            then
+               Write_Str ("warning: ");
+               Max := Max - 9;
+            end if;
 
-      elsif Errors.Table (E).Style then
-         null;
+            --  No prefix needed for style message, "(style)" is there already
 
-      --  All other cases, add "error: "
+         elsif Errors.Table (E).Style then
+            null;
 
-      elsif Opt.Unique_Error_Tag then
-         Write_Str ("error: ");
-         Max := Max - 7;
-      end if;
+            --  All other cases, add "error: "
 
-      --  Here we have to split the message up into multiple lines
+         elsif Opt.Unique_Error_Tag then
+            Write_Str ("error: ");
+            Max := Max - 7;
+         end if;
 
-      Ptr := 1;
-      loop
-         --  Make sure we do not have ludicrously small line
+         --  Here we have to split the message up into multiple lines
 
-         Max := Integer'Max (Max, 20);
+         Ptr := 1;
+         loop
+            --  Make sure we do not have ludicrously small line
 
-         --  If remaining text fits, output it respecting LF and we are done
+            Max := Integer'Max (Max, 20);
 
-         if Len - Ptr < Max then
-            for J in Ptr .. Len loop
-               if Txt (J) = ASCII.LF then
-                  Write_Eol;
-                  Write_Spaces (Offs);
-               else
-                  Write_Char (Txt (J));
-               end if;
-            end loop;
+            --  If remaining text fits, output it respecting LF and we are done
 
-            return;
+            if Len - Ptr < Max then
+               for J in Ptr .. Len loop
+                  if Txt (J) = ASCII.LF then
+                     Write_Eol;
+                     Write_Spaces (Offs);
+                  else
+                     Write_Char (Txt (J));
+                  end if;
+               end loop;
 
+               return;
+
             --  Line does not fit
 
-         else
-            Start := Ptr;
+            else
+               Start := Ptr;
 
-            --  First scan forward looking for a hard end of line
+               --  First scan forward looking for a hard end of line
 
-            for Scan in Ptr .. Ptr + Max - 1 loop
-               if Txt (Scan) = ASCII.LF then
-                  Split := Scan - 1;
-                  Ptr := Scan + 1;
-                  goto Continue;
-               end if;
-            end loop;
+               for Scan in Ptr .. Ptr + Max - 1 loop
+                  if Txt (Scan) = ASCII.LF then
+                     Split := Scan - 1;
+                     Ptr := Scan + 1;
+                     goto Continue;
+                  end if;
+               end loop;
 
-            --  Otherwise scan backwards looking for a space
+               --  Otherwise scan backwards looking for a space
 
-            for Scan in reverse Ptr .. Ptr + Max - 1 loop
-               if Txt (Scan) = ' ' then
-                  Split := Scan - 1;
-                  Ptr := Scan + 1;
-                  goto Continue;
-               end if;
-            end loop;
+               for Scan in reverse Ptr .. Ptr + Max - 1 loop
+                  if Txt (Scan) = ' ' then
+                     Split := Scan - 1;
+                     Ptr := Scan + 1;
+                     goto Continue;
+                  end if;
+               end loop;
 
-            --  If we fall through, no space, so split line arbitrarily
+               --  If we fall through, no space, so split line arbitrarily
 
-            Split := Ptr + Max - 1;
-            Ptr := Split + 1;
-         end if;
+               Split := Ptr + Max - 1;
+               Ptr := Split + 1;
+            end if;
 
-         <<Continue>>
-         if Start <= Split then
-            Write_Line (Txt (Start .. Split));
-            Write_Spaces (Offs);
-         end if;
+            <<Continue>>
+            if Start <= Split then
+               Write_Line (Txt (Start .. Split));
+               Write_Spaces (Offs);
+            end if;
 
-         Max := Integer (Length - Column + 1);
-      end loop;
+            Max := Integer (Length - Column + 1);
+         end loop;
+      end;
    end Output_Msg_Text;
 
    --------------------
@@ -846,9 +878,7 @@ 
          --  Remove upper case letter at end, again, we should not be getting
          --  such names, and what we hope is that the remainder makes sense.
 
-         if Name_Len > 1
-           and then Name_Buffer (Name_Len) in 'A' .. 'Z'
-         then
+         if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
             Name_Len := Name_Len - 1;
          end if;
 
@@ -1217,11 +1247,13 @@ 
            and then (J = Msg'First or else Msg (J - 1) /= ''')
          then
             Is_Warning_Msg := True;
+            Warning_Msg_Char := ' ';
 
          elsif Msg (J) = '<'
            and then (J = Msg'First or else Msg (J - 1) /= ''')
          then
             Is_Warning_Msg := Error_Msg_Warn;
+            Warning_Msg_Char := ' ';
 
          elsif Msg (J) = '|'
            and then (J = Msg'First or else Msg (J - 1) /= ''')
Index: erroutc.ads
===================================================================
--- erroutc.ads	(revision 194776)
+++ erroutc.ads	(working copy)
@@ -50,6 +50,13 @@ 
    Is_Warning_Msg : Boolean := False;
    --  Set True to indicate if current message is warning message
 
+   Warning_Msg_Char : Character;
+   --  Warning character, valid only if Is_Warning_Msg is True
+   --    ' '      -- ? appeared on its own in message
+   --    '?'      -- ?? appeared in message
+   --    'x'      -- ?x? appeared in message
+   --    'X'      -- ?x? appeared in message (X is upper case of x)
+
    Is_Style_Msg : Boolean := False;
    --  Set True to indicate if the current message is a style message
    --  (i.e. a message whose text starts with the characters "(style)").
@@ -182,6 +189,13 @@ 
       Warn : Boolean;
       --  True if warning message (i.e. insertion character ? appeared)
 
+      Warn_Chr : Character;
+      --  Warning character, valid only if Warn is True
+      --    ' '      -- ? appeared on its own in message
+      --    '?'      -- ?? appeared in message
+      --    'x'      -- ?x? appeared in message
+      --    'X'      -- ?x? appeared in message (X is upper case of x)
+
       Style : Boolean;
       --  True if style message (starts with "(style)")