OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Arnaud Charlet 2013-01-02 10:46:07 +01:00
parent 6a04272a9a
commit a3633438f3
14 changed files with 438 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/ChangeLog
View File

@ -1,3 +1,36 @@
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

10
gcc/ada/err_vars.ads
View File

@ -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;

63
gcc/ada/errout.adb
View File

@ -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

24
gcc/ada/errout.ads
View File

@ -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

172
gcc/ada/erroutc.adb
View File

@ -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;
begin
-- For warning, add "warning: " unless msg starts with "info: "
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;
-- No prefix needed for style message, "(style)" is there already
elsif Errors.Table (E).Style then
null;
-- All other cases, add "error: "
elsif Opt.Unique_Error_Tag then
Write_Str ("error: ");
Max := Max - 7;
end if;
-- No prefix needed for style message, since "(style)" is there already
-- Here we have to split the message up into multiple lines
elsif Errors.Table (E).Style then
null;
Ptr := 1;
loop
-- Make sure we do not have ludicrously small line
-- All other cases, add "error: "
Max := Integer'Max (Max, 20);
elsif Opt.Unique_Error_Tag then
Write_Str ("error: ");
Max := Max - 7;
end if;
-- If remaining text fits, output it respecting LF and we are done
-- Here we have to split the message up into multiple lines
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;
Ptr := 1;
loop
-- Make sure we do not have ludicrously small line
Max := Integer'Max (Max, 20);
-- If remaining text fits, output it respecting LF and we are done
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;
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) /= ''')

14
gcc/ada/erroutc.ads
View File

@ -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)")

1
gcc/ada/errutil.adb
View File

@ -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;

313
gcc/ada/init.c
View File

@ -821,34 +821,46 @@ int __gnat_features_set = 0;
#endif
/* Define macro symbols for the VMS conditions that become Ada exceptions.
Most of these are also defined in the header file ssdef.h which has not
yet been converted to be recognized by GNU C. */
It would be better to just include <ssdef.h> */
/* Defining these as macros, as opposed to external addresses, allows
them to be used in a case statement below. */
#define SS$_ACCVIO 12
#define SS$_HPARITH 1284
#define SS$_INTDIV 1156
#define SS$_STKOVF 1364
#define SS$_RESIGNAL 2328
#define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */
/* The following codes must be resignalled, and not handled here. */
/* These codes are in standard message libraries. */
extern int C$_SIGKILL;
extern int SS$_DEBUG;
extern int LIB$_KEYNOTFOU;
extern int LIB$_ACTIMAGE;
#define CMA$_EXIT_THREAD 4227492
#define MTH$_FLOOVEMAT 1475268 /* Some ACVC_21 CXA tests */
#define SS$_INTDIV 1156
/* These codes are non standard, which is to say the author is
not sure if they are defined in the standard message libraries
so keep them as macros for now. */
#define RDB$_STREAM_EOF 20480426
#define FDL$_UNPRIKW 11829410
#define CMA$_EXIT_THREAD 4227492
struct cond_sigargs {
unsigned int sigarg;
unsigned int sigargval;
};
struct cond_subtests {
unsigned int num;
const struct cond_sigargs sigargs[];
};
struct cond_except {
unsigned int cond;
const struct Exception_Data *except;
unsigned int needs_adjust; /* 1 = adjust PC, 0 = no adjust */
const struct cond_subtests *subtests;
};
struct descriptor_s {
@ -928,53 +940,74 @@ extern Exception_Code Base_Code_In (Exception_Code);
/* DEC Ada specific conditions. */
static const struct cond_except dec_ada_cond_except_table [] = {
{ADA$_PROGRAM_ERROR, &program_error},
{ADA$_USE_ERROR, &Use_Error},
{ADA$_KEYSIZERR, &program_error},
{ADA$_STAOVF, &storage_error},
{ADA$_CONSTRAINT_ERRO, &constraint_error},
{ADA$_IOSYSFAILED, &Device_Error},
{ADA$_LAYOUT_ERROR, &Layout_Error},
{ADA$_STORAGE_ERROR, &storage_error},
{ADA$_DATA_ERROR, &Data_Error},
{ADA$_DEVICE_ERROR, &Device_Error},
{ADA$_END_ERROR, &End_Error},
{ADA$_MODE_ERROR, &Mode_Error},
{ADA$_NAME_ERROR, &Name_Error},
{ADA$_STATUS_ERROR, &Status_Error},
{ADA$_NOT_OPEN, &Use_Error},
{ADA$_ALREADY_OPEN, &Use_Error},
{ADA$_USE_ERROR, &Use_Error},
{ADA$_UNSUPPORTED, &Use_Error},
{ADA$_FAC_MODE_MISMAT, &Use_Error},
{ADA$_ORG_MISMATCH, &Use_Error},
{ADA$_RFM_MISMATCH, &Use_Error},
{ADA$_RAT_MISMATCH, &Use_Error},
{ADA$_MRS_MISMATCH, &Use_Error},
{ADA$_MRN_MISMATCH, &Use_Error},
{ADA$_KEY_MISMATCH, &Use_Error},
{ADA$_MAXLINEXC, &constraint_error},
{ADA$_LINEXCMRS, &constraint_error},
{ADA$_PROGRAM_ERROR, &program_error, 0, 0},
{ADA$_USE_ERROR, &Use_Error, 0, 0},
{ADA$_KEYSIZERR, &program_error, 0, 0},
{ADA$_STAOVF, &storage_error, 0, 0},
{ADA$_CONSTRAINT_ERRO, &constraint_error, 0, 0},
{ADA$_IOSYSFAILED, &Device_Error, 0, 0},
{ADA$_LAYOUT_ERROR, &Layout_Error, 0, 0},
{ADA$_STORAGE_ERROR, &storage_error, 0, 0},
{ADA$_DATA_ERROR, &Data_Error, 0, 0},
{ADA$_DEVICE_ERROR, &Device_Error, 0, 0},
{ADA$_END_ERROR, &End_Error, 0, 0},
{ADA$_MODE_ERROR, &Mode_Error, 0, 0},
{ADA$_NAME_ERROR, &Name_Error, 0, 0},
{ADA$_STATUS_ERROR, &Status_Error, 0, 0},
{ADA$_NOT_OPEN, &Use_Error, 0, 0},
{ADA$_ALREADY_OPEN, &Use_Error, 0, 0},
{ADA$_USE_ERROR, &Use_Error, 0, 0},
{ADA$_UNSUPPORTED, &Use_Error, 0, 0},
{ADA$_FAC_MODE_MISMAT, &Use_Error, 0, 0},
{ADA$_ORG_MISMATCH, &Use_Error, 0, 0},
{ADA$_RFM_MISMATCH, &Use_Error, 0, 0},
{ADA$_RAT_MISMATCH, &Use_Error, 0, 0},
{ADA$_MRS_MISMATCH, &Use_Error, 0, 0},
{ADA$_MRN_MISMATCH, &Use_Error, 0, 0},
{ADA$_KEY_MISMATCH, &Use_Error, 0, 0},
{ADA$_MAXLINEXC, &constraint_error, 0, 0},
{ADA$_LINEXCMRS, &constraint_error, 0, 0},
#if 0
/* Already handled by a pragma Import_Exception
in Aux_IO_Exceptions */
{ADA$_LOCK_ERROR, &Lock_Error},
{ADA$_EXISTENCE_ERROR, &Existence_Error},
{ADA$_KEY_ERROR, &Key_Error},
{ADA$_LOCK_ERROR, &Lock_Error, 0, 0},
{ADA$_EXISTENCE_ERROR, &Existence_Error, 0, 0},
{ADA$_KEY_ERROR, &Key_Error, 0, 0},
#endif
{0, 0}
{0, 0, 0, 0}
};
#endif /* IN_RTS */
/* Non-DEC Ada specific conditions. We could probably also put
SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */
static const struct cond_except cond_except_table [] = {
{MTH$_FLOOVEMAT, &constraint_error},
{SS$_INTDIV, &constraint_error},
{0, 0}
/* Non-DEC Ada specific conditions that map to Ada exceptions. */
/* Subtest for ACCVIO Constraint_Error, kept for compatibility,
in hindsight should have just made ACCVIO == Storage_Error. */
#define ACCVIO_REASON_MASK 2
#define ACCVIO_VIRTUAL_ADDR 3
static const struct cond_subtests accvio_c_e =
{2, /* number of subtests below */
{
{ACCVIO_REASON_MASK, 0},
{ACCVIO_VIRTUAL_ADDR, 0}
}
};
/* Macro flag to adjust PC which gets off by one for some conditions,
not sure if this is reliably true, PC could be off by more for
HPARITH for example, unless a trapb is inserted. */
#define NEEDS_ADJUST 1
static const struct cond_except system_cond_except_table [] = {
{MTH$_FLOOVEMAT, &constraint_error, 0, 0},
{SS$_INTDIV, &constraint_error, 0, 0},
{SS$_HPARITH, &constraint_error, NEEDS_ADJUST, 0},
{SS$_ACCVIO, &constraint_error, NEEDS_ADJUST, &accvio_c_e},
{SS$_ACCVIO, &storage_error, NEEDS_ADJUST, 0},
{SS$_STKOVF, &storage_error, NEEDS_ADJUST, 0},
{0, 0, 0, 0}
};
/* To deal with VMS conditions and their mapping to Ada exceptions,
@ -1039,7 +1072,7 @@ __gnat_default_resignal_p (int code)
for (i = 0, iexcept = 0;
cond_resignal_table [i]
&& !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i]));
&& !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i]));
i++);
return iexcept;
@ -1092,10 +1125,62 @@ copy_msg (struct descriptor_s *msgdesc, char *message)
return 0;
}
/* Scan TABLE for a match for the condition contained in SIGARGS,
and return the entry, or the empty entry if no match found. */
static const struct cond_except *
scan_conditions ( int *sigargs, const struct cond_except *table [])
{
int i;
struct cond_except entry;
/* Scan the exception condition table for a match and fetch
the associated GNAT exception pointer. */
for (i = 0; (*table) [i].cond; i++)
{
unsigned int match = LIB$MATCH_COND (&sigargs [1], &(*table) [i].cond);
const struct cond_subtests *subtests = (*table) [i].subtests;
if (match)
{
if (!subtests)
{
return &(*table) [i];
}
else
{
unsigned int ii;
int num = (*subtests).num;
/* Perform subtests to differentiate exception. */
for (ii = 0; ii < num; ii++)
{
unsigned int arg = (*subtests).sigargs [ii].sigarg;
unsigned int argval = (*subtests).sigargs [ii].sigargval;
if (sigargs [arg] != argval)
{
num = 0;
break;
}
}
/* All subtests passed. */
if (num == (*subtests).num)
return &(*table) [i];
}
}
}
/* No match, return the null terminating entry. */
return &(*table) [i];
}
long
__gnat_handle_vms_condition (int *sigargs, void *mechargs)
{
struct Exception_Data *exception = 0;
unsigned int needs_adjust = 0;
Exception_Code base_code;
struct descriptor_s gnat_facility = {4, 0, "GNAT"};
char message [Default_Exception_Msg_Max_Length];
@ -1106,112 +1191,60 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
Import_Exception. */
if (__gnat_resignal_p (sigargs [1]))
return SS$_RESIGNAL;
#ifndef IN_RTS
/* toplev.c handles this for compiler. */
if (sigargs [1] == SS$_HPARITH)
return SS$_RESIGNAL;
#endif
#ifdef IN_RTS
/* See if it's an imported exception. Beware that registered exceptions
are bound to their base code, with the severity bits masked off. */
base_code = Base_Code_In ((Exception_Code) sigargs[1]);
exception = Coded_Exception (base_code);
if (exception)
{
message[0] = 0;
/* Subtract PC & PSL fields which messes with PUTMSG. */
sigargs[0] -= 2;
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
sigargs[0] += 2;
msg = message;
exception->Name_Length = 19;
/* ??? The full name really should be get SYS$GETMSG returns. */
exception->Full_Name = "IMPORTED_EXCEPTION";
exception->Import_Code = base_code;
#ifdef __IA64
/* Do not adjust the program counter as already points to the next
instruction (just after the call to LIB$STOP). */
Raise_From_Signal_Handler (exception, msg);
#endif
}
#endif
if (exception == 0)
switch (sigargs[1])
{
case SS$_ACCVIO:
if (sigargs[3] == 0)
{
exception = &constraint_error;
msg = "access zero";
}
else
{
exception = &storage_error;
msg = "stack overflow or erroneous memory access";
}
__gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs);
break;
case SS$_STKOVF:
exception = &storage_error;
msg = "stack overflow";
__gnat_adjust_context_for_raise (SS$_STKOVF, (void *)mechargs);
break;
case SS$_HPARITH:
#ifndef IN_RTS
return SS$_RESIGNAL; /* toplev.c handles for compiler */
#else
exception = &constraint_error;
msg = "arithmetic error";
__gnat_adjust_context_for_raise (SS$_HPARITH, (void *)mechargs);
#endif
break;
default:
#ifdef IN_RTS
{
int i;
struct cond_except cond;
const struct cond_except *cond_table;
const struct cond_except *cond_tables [] = {dec_ada_cond_except_table,
system_cond_except_table,
0};
i = 0;
while ((cond_table = cond_tables[i++]) && !exception)
{
int i;
/* Scan the DEC Ada exception condition table for a match and fetch
the associated GNAT exception pointer. */
for (i = 0;
dec_ada_cond_except_table [i].cond &&
!LIB$MATCH_COND (&sigargs [1],
&dec_ada_cond_except_table [i].cond);
i++);
exception = (struct Exception_Data *)
dec_ada_cond_except_table [i].except;
if (!exception)
{
/* Scan the VMS standard condition table for a match and fetch
the associated GNAT exception pointer. */
for (i = 0;
cond_except_table[i].cond &&
!LIB$MATCH_COND (&sigargs[1], &cond_except_table[i].cond);
i++);
exception = (struct Exception_Data *)
cond_except_table [i].except;
if (!exception)
/* User programs expect Non_Ada_Error to be raised, reference
DEC Ada test CXCONDHAN. */
exception = &Non_Ada_Error;
}
cond = *scan_conditions (sigargs, &cond_table);
exception = (struct Exception_Data *) cond.except;
}
#else
exception = &program_error;
#endif
message[0] = 0;
/* Subtract PC & PSL fields which messes with PUTMSG. */
sigargs[0] -= 2;
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
sigargs[0] += 2;
msg = message;
break;
if (exception)
needs_adjust = cond.needs_adjust;
else
/* User programs expect Non_Ada_Error to be raised if no match,
reference DEC Ada test CXCONDHAN. */
exception = &Non_Ada_Error;
}
#else
{
/* Pretty much everything is just a program error in the compiler */
exception = &program_error;
}
#endif
message[0] = 0;
/* Subtract PC & PSL fields as per ABI for SYS$PUTMSG. */
sigargs[0] -= 2;
SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
/* Add back PC & PSL fields as per ABI for SYS$PUTMSG. */
sigargs[0] += 2;
msg = message;
if (needs_adjust)
__gnat_adjust_context_for_raise (sigargs [1], (void *)mechargs);
Raise_From_Signal_Handler (exception, msg);
}
@ -1244,11 +1277,11 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
if (signo == SS$_HPARITH)
{
/* Sub one to the address of the instruction signaling the condition,
located in the sigargs array. */
located in the sigargs array. */
CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
CHF$SIGNAL_ARRAY * sigargs
= (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
= (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
int vcount = sigargs->chf$is_sig_args;
int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];

4
gcc/ada/opt.ads
View File

@ -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

12
gcc/ada/scn.adb
View File

@ -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;

9
gcc/ada/sem_ch13.adb
View File

@ -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

4
gcc/ada/sem_ch6.adb
View File

@ -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;

2
gcc/ada/sem_res.adb
View File

@ -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;

10
gcc/ada/warnsw.adb
View File

@ -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;