[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

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/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];

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;