Skip to content

R
riscv-gcc-1
Commit a3633438 by Arnaud Charlet
Options

[multiple changes] 

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).

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

	* opt.ads: Minor reformatting.

2013-01-02  Doug Rupp  <rupp@adacore.com>

	* init.c: Reorganize VMS section.
	(scan_condtions): New function for scanning condition tables.
	(__gnat_handle_vms_condtion): Use actual exception name for imported
	exceptions vice IMPORTED_EXCEPTION.
	Move condition table scanning into separate function. Move formerly
	special handled conditions to system condition table. Use SYS$PUTMSG
	output to fill exception message field for formally special handled
	condtions, in particular HPARITH to provide more clues about cause and
	location then raised from the translated image.

From-SVN: r194784
parent 6a04272a
Showing with 262 additions and 90 deletions
gcc/ada/ChangeLog
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).
2013-01-02 Robert Dewar <dewar@adacore.com>
* opt.ads: Minor reformatting.
2013-01-02 Doug Rupp <rupp@adacore.com>
* init.c: Reorganize VMS section.
(scan_condtions): New function for scanning condition tables.
(__gnat_handle_vms_condtion): Use actual exception name for imported
exceptions vice IMPORTED_EXCEPTION.
Move condition table scanning into separate function. Move formerly
special handled conditions to system condition table. Use SYS$PUTMSG
output to fill exception message field for formally special handled
condtions, in particular HPARITH to provide more clues about cause and
location then raised from the translated image.
2013-01-02 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): For a Pre/Post
......
gcc/ada/err_vars.ads
......@@ -88,6 +88,12 @@ package Err_Vars is
-- 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 @@ package Err_Vars is
-- 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;
......
gcc/ada/errout.adb
......@@ -821,9 +821,7 @@ package body Errout is
-- 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 @@ package body Errout is
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 @@ package body Errout is
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 @@ package body Errout is
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,10 +2770,16 @@ package body Errout is
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
......
gcc/ada/errout.ads
......@@ -59,6 +59,12 @@ package Errout is
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 @@ package Errout is
-- 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
......
gcc/ada/erroutc.adb
......@@ -442,13 +442,37 @@ package body Erroutc is
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 @@ package body Erroutc is
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 @@ package body Erroutc is
-- 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 @@ package body Erroutc is
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) /= ''')
......
gcc/ada/erroutc.ads
......@@ -50,6 +50,13 @@ package Erroutc is
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 @@ package Erroutc is
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)")
......
gcc/ada/errutil.adb
......@@ -211,6 +211,7 @@ package body Errutil is
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;
......
gcc/ada/opt.ads
......@@ -1533,7 +1533,8 @@ package Opt is
Warn_On_Hiding : Boolean := False;
-- GNAT
-- Set to True to generate warnings if a declared entity hides another
-- entity. The default is that this warning is suppressed.
-- entity. The default is that this warning is suppressed. Modified by
-- use of -gnatwh/H.
Warn_On_Modified_Unread : Boolean := False;
-- GNAT
......@@ -1593,6 +1594,7 @@ package Opt is
-- GNAT
-- Set to True to generate warnings for redundant constructs (e.g. useless
-- assignments/conversions). The default is that this warning is disabled.
-- Modified by use of -gnatwr/R.
Warn_On_Reverse_Bit_Order : Boolean := True;
-- GNAT
......
gcc/ada/scn.adb
......@@ -339,9 +339,9 @@ package body Scn is
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 @@ package body Scn is
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 @@ package body Scn is
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;
......
gcc/ada/sem_ch13.adb
......@@ -1610,6 +1610,7 @@ package body Sem_Ch13 is
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 @@ package body Sem_Ch13 is
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 @@ package body Sem_Ch13 is
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
......
gcc/ada/sem_ch6.adb
......@@ -6912,10 +6912,10 @@ package body Sem_Ch6 is
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;
......
gcc/ada/sem_res.adb
......@@ -3095,7 +3095,7 @@ package body Sem_Res is
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;
......
gcc/ada/warnsw.adb
......@@ -22,8 +22,8 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Opt; use Opt;
with Err_Vars; use Err_Vars;
with Opt; use Opt;
package body Warnsw is
......@@ -52,6 +52,12 @@ package body Warnsw is
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment