diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2013-01-02 10:46:07 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2013-01-02 10:46:07 +0100 |
commit | a3633438f36dbcef65df4758dcbc552303ad578d (patch) | |
tree | 4d0f6d7aa46aefc5cb77c2d6fa4e0ccdcd2aabc0 /gcc | |
parent | 6a04272a9a6981d30d4c21d99f10405c9a48a5c6 (diff) | |
download | gcc-a3633438f36dbcef65df4758dcbc552303ad578d.zip gcc-a3633438f36dbcef65df4758dcbc552303ad578d.tar.gz gcc-a3633438f36dbcef65df4758dcbc552303ad578d.tar.bz2 |
[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
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 33 | ||||
-rw-r--r-- | gcc/ada/err_vars.ads | 10 | ||||
-rw-r--r-- | gcc/ada/errout.adb | 63 | ||||
-rw-r--r-- | gcc/ada/errout.ads | 24 | ||||
-rw-r--r-- | gcc/ada/erroutc.adb | 166 | ||||
-rw-r--r-- | gcc/ada/erroutc.ads | 14 | ||||
-rw-r--r-- | gcc/ada/errutil.adb | 1 | ||||
-rw-r--r-- | gcc/ada/init.c | 311 | ||||
-rw-r--r-- | gcc/ada/opt.ads | 4 | ||||
-rw-r--r-- | gcc/ada/scn.adb | 12 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 9 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 4 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 2 | ||||
-rw-r--r-- | gcc/ada/warnsw.adb | 10 |
14 files changed, 434 insertions, 229 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 607bcb8..ce78425 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index 64d68e0..0791a35 100644 --- a/gcc/ada/err_vars.ads +++ b/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; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 6f45020..88606d2 100644 --- a/gcc/ada/errout.adb +++ b/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 diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 0f746d9..7dc67a0 100644 --- a/gcc/ada/errout.ads +++ b/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 diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 56a4e35..35f71a4 100644 --- a/gcc/ada/erroutc.adb +++ b/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) /= ''') diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index fc5cfa9..4e38fbd 100644 --- a/gcc/ada/erroutc.ads +++ b/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)") diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index d6fa960..3a087ca 100644 --- a/gcc/ada/errutil.adb +++ b/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; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 916c3be..158e203 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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; } + + 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 - exception = &program_error; + { + /* Pretty much everything is just a program error in the compiler */ + 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; - } + + 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]; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index b8d1697..39a341a 100644 --- a/gcc/ada/opt.ads +++ b/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 diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index 52431b3..9f8ce207 100644 --- a/gcc/ada/scn.adb +++ b/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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 221c866..b23b299 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2903e89..4835c1c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 445458c..26183a6 100644 --- a/gcc/ada/sem_res.adb +++ b/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; diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 7920ac9..a8d31e4 100644 --- a/gcc/ada/warnsw.adb +++ b/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; |