From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 8439 invoked by alias); 2 Jan 2013 09:46:28 -0000 Received: (qmail 8429 invoked by uid 22791); 2 Jan 2013 09:46:27 -0000 X-SWARE-Spam-Status: No, hits=0.4 required=5.0 tests=AWL,BAYES_50,KHOP_SPAMHAUS_DROP,RCVD_IN_HOSTKARMA_NO,SARE_FWDLOOK,WEIRD_QUOTING X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 02 Jan 2013 09:46:19 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 769602E224; Wed, 2 Jan 2013 04:46:18 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id GtfFavs0Ry6s; Wed, 2 Jan 2013 04:46:18 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 4B4392E21D; Wed, 2 Jan 2013 04:46:18 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 4AABB3FF09; Wed, 2 Jan 2013 04:46:18 -0500 (EST) Date: Wed, 02 Jan 2013 09:46:00 -0000 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement tagging of warning messages Message-ID: <20130102094618.GA2186@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="LZvS9be/3tNcYl/X" Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2013-01/txt/msg00023.txt.bz2 --LZvS9be/3tNcYl/X Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 1971 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 * 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). --LZvS9be/3tNcYl/X Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename=difs Content-length: 21269 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; - <> - if Start <= Split then - Write_Line (Txt (Start .. Split)); - Write_Spaces (Offs); - end if; + <> + 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)") --LZvS9be/3tNcYl/X--