2014-06-11 Geert Bosch <bosch@adacore.com>

	* s-exctab.adb: avoid race conditions in exception registration.

2014-06-11  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Warn_Insertion): New function.
	(Error_Msg): Use Warn_Insertion and Prescan_Message.
	(Error_Msg_Internal): Set Info field of error object.
	(Error_Msg_NEL): Use Prescan_Message.
	(Set_Msg_Text): Don't store info: at start of message.
	(Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning.
	(Skip_Msg_Insertion_Warning): Now just skips warning insertion.
	* errout.ads: Document new ?$? and >$> insertion sequences
	Document use of "(style)" and "info: "
	* erroutc.adb (dmsg): Print several missing fields
	(Get_Warning_Tag): Handle -gnatel case (?$?)  (Output_Msg_Text):
	Deal with new tagging of info messages
	* erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object):
	Add field Info (Prescan_Message): New procedure, this procedure
	replaces the old Test_Style_Warning_Serious_Unconditional_Msg
	* errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb,
	sem_elab.adb: Follow new rules for info message (info belongs
	only at the start of a message, and only in the first message,
	not in any of the continuations).
	* gnat_ugn.texi: Document full set of warning tags.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@211447 138bc75d-0d04-0410-961f-82ee72b054a4

13 files changed, 590 insertions, 300 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0a404e082c4..a2ce54e9b0f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,30 @@
+2014-06-11  Geert Bosch  <bosch@adacore.com>
+
+	* s-exctab.adb: avoid race conditions in exception registration.
+
+2014-06-11  Robert Dewar  <dewar@adacore.com>
+
+	* errout.adb (Warn_Insertion): New function.
+	(Error_Msg): Use Warn_Insertion and Prescan_Message.
+	(Error_Msg_Internal): Set Info field of error object.
+	(Error_Msg_NEL): Use Prescan_Message.
+	(Set_Msg_Text): Don't store info: at start of message.
+	(Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning.
+	(Skip_Msg_Insertion_Warning): Now just skips warning insertion.
+	* errout.ads: Document new ?$? and >$> insertion sequences
+	Document use of "(style)" and "info: "
+	* erroutc.adb (dmsg): Print several missing fields
+	(Get_Warning_Tag): Handle -gnatel case (?$?)  (Output_Msg_Text):
+	Deal with new tagging of info messages
+	* erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object):
+	Add field Info (Prescan_Message): New procedure, this procedure
+	replaces the old Test_Style_Warning_Serious_Unconditional_Msg
+	* errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb,
+	sem_elab.adb: Follow new rules for info message (info belongs
+	only at the start of a message, and only in the first message,
+	not in any of the continuations).
+	* gnat_ugn.texi: Document full set of warning tags.
+
 2014-06-11  Gary Dismukes  <dismukes@adacore.com>
 
 	* sem_util.adb: Minor typo fix.
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 37a1b64d686..7f02fe22571 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -197,6 +197,17 @@ package body Errout is
    --  spec for precise definition of the conversion that is performed by this
    --  routine in OpenVMS mode.
 
+   function Warn_Insertion return String;
+   --  This is called for warning messages only (so Warning_Msg_Char is set)
+   --  and returns a corresponding string to use at the beginning of generated
+   --  auxiliary messages, such as "in instantiation at ...".
+   --    'a' .. 'z'   returns "?x?"
+   --    'A' .. 'Z'   returns "?X?"
+   --    '*'          returns "?*?"
+   --    '$'          returns "?$?info: "
+   --    ' '          returns " "
+   --  No other settings are valid
+
    -----------------------
    -- Change_Error_Text --
    -----------------------
@@ -282,7 +293,7 @@ package body Errout is
       --  Start of processing for new message
 
       Sindex := Get_Source_File_Index (Flag_Location);
-      Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+      Prescan_Message (Msg);
       Orig_Loc := Original_Location (Flag_Location);
 
       --  If the current location is in an instantiation, the issue arises of
@@ -332,8 +343,7 @@ package body Errout is
       --  that style checks are not considered warning messages for this
       --  purpose.
 
-      if Is_Warning_Msg
-        and then Warnings_Suppressed (Orig_Loc) /= No_String
+      if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
       then
          return;
 
@@ -438,9 +448,9 @@ package body Errout is
                --  Case of inlined body
 
                if Inlined_Body (X) then
-                  if Is_Warning_Msg or else Is_Style_Msg then
+                  if Is_Warning_Msg or Is_Style_Msg then
                      Error_Msg_Internal
-                       ("?in inlined body #",
+                       (Warn_Insertion & "in inlined body #",
                         Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
                   else
                      Error_Msg_Internal
@@ -453,7 +463,7 @@ package body Errout is
                else
                   if Is_Warning_Msg or else Is_Style_Msg then
                      Error_Msg_Internal
-                       ("?in instantiation #",
+                       (Warn_Insertion & "in instantiation #",
                         Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
                   else
                      Error_Msg_Internal
@@ -732,7 +742,6 @@ package body Errout is
       Continuation_New_Line := False;
       Suppress_Message := False;
       Kill_Message := False;
-      Warning_Msg_Char := ' ';
       Set_Msg_Text (Msg, Sptr);
 
       --  Kill continuation if parent message killed
@@ -944,6 +953,7 @@ package body Errout is
           Line     => Get_Physical_Line_Number (Sptr),
           Col      => Get_Column_Number (Sptr),
           Warn     => Is_Warning_Msg,
+          Info     => Is_Info_Msg,
           Warn_Err => False, -- reset below
           Warn_Chr => Warning_Msg_Char,
           Style    => Is_Style_Msg,
@@ -1159,7 +1169,7 @@ package body Errout is
          return;
       end if;
 
-      Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+      Prescan_Message (Msg);
 
       --  Special handling for warning messages
 
@@ -2745,19 +2755,21 @@ package body Errout is
       C : Character;   -- Current character
       P : Natural;     -- Current index;
 
-      procedure Set_Msg_Insertion_Warning (C : Character);
-      --  Deal with ? ?? ?x? ?X? insertion sequences (also < << <x< <X<). The
-      --  caller has already bumped the pointer past the initial ? or < and C
-      --  is set to this initial character (? or <).
+      procedure Skip_Msg_Insertion_Warning (C : Character);
+      --  Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
+      --  sequences using < instead of ?). The caller has already bumped
+      --  the pointer past the initial ? or < and C is set to this initial
+      --  character (? or <). This procedure skips past the rest of the
+      --  sequence. We do not need to set Msg_Insertion_Char, since this
+      --  was already done during the message prescan.
 
-      -------------------------------
-      -- Set_Msg_Insertion_Warning --
-      -------------------------------
+      --------------------------------
+      -- Skip_Msg_Insertion_Warning --
+      --------------------------------
 
-      procedure Set_Msg_Insertion_Warning (C : Character) is
+      procedure Skip_Msg_Insertion_Warning (C : Character) is
       begin
          if P <= Text'Last and then Text (P) = C then
-            Warning_Msg_Char := '?';
             P := P + 1;
 
          elsif P + 1 <= Text'Last
@@ -2765,15 +2777,14 @@ package body Errout is
                        or else
                      Text (P) in 'A' .. 'Z'
                        or else
-                     Text (P) = '*')
+                     Text (P) = '*'
+                       or else
+                     Text (P) = '$')
            and then Text (P + 1) = C
          then
-            Warning_Msg_Char := Text (P);
             P := P + 2;
-         else
-            Warning_Msg_Char := ' ';
          end if;
-      end Set_Msg_Insertion_Warning;
+      end Skip_Msg_Insertion_Warning;
 
    --  Start of processing for Set_Msg_Text
 
@@ -2782,7 +2793,21 @@ package body Errout is
       Msglen := 0;
       Flag_Source := Get_Source_File_Index (Flag);
 
-      P := Text'First;
+      --  Skip info: at start, we have recorded this in Is_Info_Msg, and this
+      --  will be used (Info field in error message object) to put back the
+      --  string when it is printed. We need to do this, or we get confused
+      --  with instantiation continuations.
+
+      if Text'Length > 6
+        and then Text (Text'First .. Text'First + 5) = "info: "
+      then
+         P := Text'First + 6;
+      else
+         P := Text'First;
+      end if;
+
+      --  Loop through characters of message
+
       while P <= Text'Last loop
          C := Text (P);
          P := P + 1;
@@ -2846,16 +2871,10 @@ package body Errout is
                null; -- already dealt with
 
             when '?' =>
-               Set_Msg_Insertion_Warning ('?');
+               Skip_Msg_Insertion_Warning ('?');
 
             when '<' =>
-
-               --  Note: the prescan already set Is_Warning_Msg True if and
-               --  only if Error_Msg_Warn is set to True. If Error_Msg_Warn
-               --  is False, the call to Set_Msg_Insertion_Warning here does
-               --  no harm, since Warning_Msg_Char is ignored in that case.
-
-               Set_Msg_Insertion_Warning ('<');
+               Skip_Msg_Insertion_Warning ('<');
 
             when '|' =>
                null; -- already dealt with
@@ -3233,4 +3252,22 @@ package body Errout is
       end loop;
    end VMS_Convert;
 
+   --------------------
+   -- Warn_Insertion --
+   --------------------
+
+   function Warn_Insertion return String is
+   begin
+      case Warning_Msg_Char is
+         when '?' =>
+            return "??";
+         when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
+            return '?' & Warning_Msg_Char & '?';
+         when ' ' =>
+            return "?";
+         when others =>
+            raise Program_Error;
+      end case;
+   end Warn_Insertion;
+
 end Errout;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index a42d3dba75c..45234a4dc9b 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -60,12 +60,13 @@ package Errout is
    --  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
-   --  generate appropriate tags for the output error messages. If this switch
-   --  is False, then these sequences are still recognized (for the purposes
-   --  of implementing pragmas Warnings (Off,..) and Warning_As_Pragma(...) but
-   --  do not result in adding the error message tag. The -gnatw.d switch sets
-   --  this flag True, -gnatw.D sets this flag False.
+   --  If this is set True, then the ??/?*?/?$?/?x?/?X? insertion sequences in
+   --  error messages generate appropriate tags for the output error messages.
+   --  If this switch is False, then these sequences are still recognized (for
+   --  the purposes of implementing the pattern matching in pragmas Warnings
+   --  (Off,..) and Warning_As_Pragma(...) but do not result in adding the
+   --  error message tag. The -gnatw.d switch sets this flag True, -gnatw.D
+   --  sets this flag False.
 
    -----------------------------------
    -- Suppression of Error Messages --
@@ -283,7 +284,7 @@ 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.
    --
-   --      Note: this usage is obsolete, use ?? ?*? ?x? ?X? instead to specify
+   --      Note: this usage is obsolete, use ?? ?*? ?$? ?x? ?X? to specify
    --      the string to be added when Warn_Doc_Switch is set to True. If this
    --      switch is True, then for simple ? messages it has no effect. This
    --      simple form is to ease transition and will be removed later.
@@ -309,11 +310,17 @@ package Errout is
    --      "[restriction warning]" at the end of the warning message. For
    --      continuations, use this on each continuation message.
 
+   --    Insertion character ?$? (elaboration information messages)
+   --      Like ?, but if the flag Warn_Doc_Switch is True, adds the string
+   --      "[-gnatel]" at the end of the info message. This is used for the
+   --      messages generated by the switch -gnatel. For 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
-   --      effect is the same as ? described above, and in particular <<
-   --      <X< and <*< have the effect of ?? ?X? and ?*? respectively. If
+   --      effect is the same as ? described above, and in particular << <X<
+   --      <x< <$< <*< have the effect of ?? ?X? ?x? ?$? ?*? respectively. If
    --      Error_Msg_Warn is False, then the < << or <X< sequence is ignored
    --      and the message is treated as a error rather than a warning.
 
@@ -392,6 +399,19 @@ package Errout is
    --      This is like [ except that the insertion messages say may/might,
    --      instead of will/would.
 
+   --    Insertion sequence "(style)" (style message)
+   --      This appears only at the start of the message (and not any of its
+   --      continuations, if any), and indicates that the message is a style
+   --      message. Style messages are also considered to be warnings, but
+   --      they do not get a tag.
+
+   --    Insertion sequence "info: " (information message)
+   --      This appears only at the start of the message (and not any of its
+   --      continuations, if any), and indicates that the message is an info
+   --      message. The message will be output with this prefix, and if there
+   --      are continuations that are not printed using the -gnatj switch they
+   --      will also have this prefix.
+
    ----------------------------------------
    -- Specialization of Messages for VMS --
    ----------------------------------------
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index 4a107d1df10..c27b76e642f 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -257,6 +257,7 @@ package body Erroutc is
       w ("Dumping error message, Id = ", Int (Id));
       w ("  Text     = ", E.Text.all);
       w ("  Next     = ", Int (E.Next));
+      w ("  Prev     = ", Int (E.Prev));
       w ("  Sfile    = ", Int (E.Sfile));
 
       Write_Str
@@ -272,6 +273,8 @@ package body Erroutc is
       w ("  Line     = ", Int (E.Line));
       w ("  Col      = ", Int (E.Col));
       w ("  Warn     = ", E.Warn);
+      w ("  Warn_Err = ", E.Warn_Err);
+      w ("  Warn_Chr = '" & E.Warn_Chr & ''');
       w ("  Style    = ", E.Style);
       w ("  Serious  = ", E.Serious);
       w ("  Uncond   = ", E.Uncond);
@@ -312,6 +315,8 @@ package body Erroutc is
             return "[enabled by default]";
          elsif Warn_Chr = '*' then
             return "[restriction warning]";
+         elsif Warn_Chr = '$' then
+            return "[-gnatel]";
          elsif Warn_Chr in 'a' .. 'z' then
             return "[-gnatw" & Warn_Chr & ']';
          else pragma Assert (Warn_Chr in 'A' .. 'Z');
@@ -574,24 +579,22 @@ package body Erroutc is
 
          if Errors.Table (E).Warn then
 
-            --  Nothing to do with info messages, "info " already set
+            --  For info messages, prefix message with "info: "
 
-            if Txt'Length >= 6
-              and then Txt (Txt'First .. Txt'First + 5) = "info: "
-            then
-               null;
+            if Errors.Table (E).Info then
+               Txt := new String'("info: " & Txt.all);
 
             --  Warning treated as error
 
             elsif Errors.Table (E).Warn_Err then
 
-               --  We prefix the tag error: rather than warning: and postfix
+               --  We prefix with "error:" rather than warning: and postfix
                --  [warning-as-error] at the end.
 
                Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
                Txt := new String'("error: " & Txt.all & " [warning-as-error]");
 
-            --  Normal case, prefix
+            --  Normal case, prefix with "warning: "
 
             else
                Txt := new String'("warning: " & Txt.all);
@@ -683,6 +686,103 @@ package body Erroutc is
       end;
    end Output_Msg_Text;
 
+   ---------------------
+   -- Prescan_Message --
+   ---------------------
+
+   procedure Prescan_Message (Msg : String) is
+      J : Natural;
+
+   begin
+      --  Nothing to do for continuation line
+
+      if Msg (Msg'First) = '\' then
+         return;
+      end if;
+
+      --  Set initial values of globals (may be changed during scan)
+
+      Is_Serious_Error     := True;
+      Is_Unconditional_Msg := False;
+      Is_Warning_Msg       := False;
+      Has_Double_Exclam    := False;
+
+      --  Check style message
+
+      Is_Style_Msg :=
+        Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
+
+      --  Check info message
+
+      Is_Info_Msg :=
+        Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
+
+      --  Loop through message looking for relevant insertion sequences
+
+      J := Msg'First;
+      while J <= Msg'Last loop
+
+         --  If we have a quote, don't look at following character
+
+         if Msg (J) = ''' then
+            J := J + 2;
+
+         --  Warning message (? or < insertion sequence)
+
+         elsif Msg (J) = '?' or else Msg (J) = '<' then
+            Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn;
+            Warning_Msg_Char := ' ';
+            J := J + 1;
+
+            if Is_Warning_Msg then
+               declare
+                  C : constant Character := Msg (J - 1);
+               begin
+                  if J <= Msg'Last then
+                     if Msg (J) = C then
+                        Warning_Msg_Char := '?';
+                        J := J + 1;
+
+                     elsif J < Msg'Last and then Msg (J + 1) = C
+                       and then (Msg (J) in 'a' .. 'z' or else
+                                 Msg (J) in 'A' .. 'Z' or else
+                                 Msg (J) = '*'         or else
+                                 Msg (J) = '$')
+                     then
+                        Warning_Msg_Char := Msg (J);
+                        J := J + 2;
+                     end if;
+                  end if;
+               end;
+            end if;
+
+         --  Unconditional message (! insertion)
+
+         elsif Msg (J) = '!' then
+            Is_Unconditional_Msg := True;
+            J := J + 1;
+
+            if J <= Msg'Last and then Msg (J) = '!' then
+               Has_Double_Exclam := True;
+               J := J + 1;
+            end if;
+
+         --  Non-serious error (| insertion)
+
+         elsif Msg (J) = '|' then
+            Is_Serious_Error := False;
+            J := J + 1;
+
+         else
+            J := J + 1;
+         end if;
+      end loop;
+
+      if Is_Warning_Msg or Is_Style_Msg then
+         Is_Serious_Error := False;
+      end if;
+   end Prescan_Message;
+
    --------------------
    -- Purge_Messages --
    --------------------
@@ -1251,6 +1351,7 @@ package body Erroutc is
       for J in 1 .. Specific_Warnings.Last loop
          declare
             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
+
          begin
             if Msg = SWE.Msg.all
               and then Loc > SWE.Start
@@ -1352,63 +1453,6 @@ package body Erroutc is
       end if;
    end Set_Warnings_Mode_On;
 
-   ------------------------------------
-   -- Test_Style_Warning_Serious_Msg --
-   ------------------------------------
-
-   procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
-   begin
-      --  Nothing to do for continuation line
-
-      if Msg (Msg'First) = '\' then
-         return;
-      end if;
-
-      --  Set initial values of globals (may be changed during scan)
-
-      Is_Serious_Error     := True;
-      Is_Unconditional_Msg := False;
-      Is_Warning_Msg       := False;
-      Has_Double_Exclam    := False;
-
-      Is_Style_Msg :=
-        (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
-
-      for J in Msg'Range loop
-         if Msg (J) = '?'
-           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_Unconditional_Msg := True;
-            Warning_Msg_Char := ' ';
-
-            if J < Msg'Last and then Msg (J + 1) = '!' then
-               Has_Double_Exclam := True;
-            end if;
-
-         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) /= ''')
-         then
-            Is_Serious_Error := False;
-         end if;
-      end loop;
-
-      if Is_Warning_Msg or Is_Style_Msg then
-         Is_Serious_Error := False;
-      end if;
-   end Test_Style_Warning_Serious_Unconditional_Msg;
-
    --------------------------------
    -- Validate_Specific_Warnings --
    --------------------------------
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index c638aac1b1e..f23f4df588f 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -60,15 +60,24 @@ package Erroutc is
    --  character ! and is thus to be treated as an unconditional message.
 
    Is_Warning_Msg : Boolean := False;
-   --  Set True to indicate if current message is warning message (contains ?)
+   --  Set True to indicate if current message is warning message (contains ?
+   --  or contains < and Error_Msg_Warn is True.
+
+   Is_Info_Msg : Boolean := False;
+   --  Set True to indicate that the current message starts with the characters
+   --  "info: " and is to be treated as an information message. This string
+   --  will be prepended to the message and all its continuations.
 
    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 = a .. z)
-   --    'X'      -- ?X? appeared in message (X = A .. Z)
-   --    '*'      -- ?*? appeared in message
+   --    ' '      -- ?   or <   appeared on its own in message
+   --    '?'      -- ??  or <<  appeared in message
+   --    'x'      -- ?x? or <x< appeared in message (x = a .. z)
+   --    'X'      -- ?X? or <X< appeared in message (X = A .. Z)
+   --    '*'      -- ?*? or <*< appeared in message
+   --    '$'      -- ?$? or <$< appeared in message
+   --  In the case of the < sequences, this is set only if the message is
+   --  actually a warning, i.e. if Error_Msg_Warn is True
 
    Is_Style_Msg : Boolean := False;
    --  Set True to indicate if the current message is a style message
@@ -194,7 +203,10 @@ package Erroutc is
       --  Column number for error message
 
       Warn : Boolean;
-      --  True if warning message (i.e. insertion character ? appeared)
+      --  True if warning message
+
+      Info : Boolean;
+      --  True if info message
 
       Warn_Err : Boolean;
       --  True if this is a warning message which is to be treated as an error
@@ -202,11 +214,14 @@ package Erroutc is
 
       Warn_Chr : Character;
       --  Warning character (note: set even if Warning_Doc_Switch is False)
-      --    ' '      -- ?   appeared on its own in message
-      --    '?'      -- ??  appeared in message
-      --    'x'      -- ?x? appeared in message (x = a .. z)
-      --    'X'      -- ?X? appeared in message (X = A .. Z)
-      --    '*'      -- ?*? appeared in message
+      --    ' '      -- ?   or <   appeared on its own in message
+      --    '?'      -- ??  or <<  appeared in message
+      --    'x'      -- ?x? or <x< appeared in message (x = a .. z)
+      --    'X'      -- ?X? or <X< appeared in message (X = A .. Z)
+      --    '*'      -- ?*? or <*< appeared in message
+      --    '$'      -- ?$? or <$< appeared in message
+      --  In the case of the < sequences, this is set only if the message is
+      --  actually a warning, i.e. if Error_Msg_Warn is True
 
       Style : Boolean;
       --  True if style message (starts with "(style)")
@@ -404,6 +419,34 @@ package Erroutc is
    --  splits the line generating multiple lines of output, and in this case
    --  the last line has no terminating end of line character.
 
+   procedure Prescan_Message (Msg : String);
+   --  Scans message text and sets the following variables:
+   --
+   --    Is_Warning_Msg is set True if Msg is a warning message (contains a
+   --    question mark character), and False otherwise.
+   --
+   --    Is_Style_Msg is set True if Msg is a style message (starts with
+   --    "(style)") and False otherwise.
+   --
+   --    Is_Info_Msg is set True if Msg is an information message (starts
+   --    with "info: ". Such messages must contain a ? sequence since they
+   --    are also considered to be warning messages, and get a tag.
+   --
+   --    Is_Serious_Error is set to True unless the message is a warning or
+   --    style message or contains the character | (non-serious error).
+   --
+   --    Is_Unconditional_Msg is set True if the message contains the character
+   --    ! and is otherwise set False.
+   --
+   --    Has_Double_Exclam is set True if the message contains the sequence !!
+   --    and is otherwise set False.
+   --
+   --  We need to know right away these aspects of a message, since we will
+   --  test these values before doing the full error scan.
+   --
+   --  Note that the call has no effect for continuation messages (those whose
+   --  first character is '\'), and all variables are left unchanged.
+
    procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
    --  All error messages whose location is in the range From .. To (not
    --  including the end points) will be deleted from the error listing.
@@ -523,27 +566,6 @@ package Erroutc is
    --  Called in response to a pragma Warnings (On) to record the source
    --  location from which warnings are to be turned back on.
 
-   procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String);
-   --  Scans message text and sets the following variables:
-   --
-   --    Is_Warning_Msg is set True if Msg is a warning message (contains a
-   --    question mark character), and False otherwise.
-   --
-   --    Is_Style_Msg is set True if Msg is a style message (starts with
-   --    "(style)") and False otherwise.
-   --
-   --    Is_Serious_Error is set to True unless the message is a warning or
-   --    style message or contains the character | (non-serious error).
-   --
-   --    Is_Unconditional_Msg is set True if the message contains the character
-   --    ! and is otherwise set False.
-   --
-   --    Has_Double_Exclam is set True if the message contains the sequence !!
-   --    and is otherwise set False.
-   --
-   --  Note that the call has no effect for continuation messages (those whose
-   --  first character is '\'), and all variables are left unchanged.
-
    function Warnings_Suppressed (Loc : Source_Ptr) return String_Id;
    --  Determines if given location is covered by a warnings off suppression
    --  range in the warnings table (or is suppressed by compilation option,
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index 0d4af6c49c8..f15eec9a7b1 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1991-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1991-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -177,7 +177,7 @@ package body Errutil is
          raise Error_Msg_Exception;
       end if;
 
-      Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+      Prescan_Message (Msg);
       Set_Msg_Text (Msg, Sptr);
 
       --  Kill continuation if parent message killed
@@ -212,6 +212,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).Info     := Is_Info_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;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f409cb07ae5..3e72bac9063 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -228,10 +228,10 @@ package body Exp_Util is
 
          if Present (Msg_Node) then
             Error_Msg_N
-              ("?N?info: atomic synchronization set for &", Msg_Node);
+              ("info: atomic synchronization set for &?N?", Msg_Node);
          else
             Error_Msg_N
-              ("?N?info: atomic synchronization set", N);
+              ("info: atomic synchronization set?N?", N);
          end if;
       end if;
    end Activate_Atomic_Synchronization;
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index 9a347525e91..0edd66ce165 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -5096,19 +5096,46 @@ This switch suppresses warnings for implicit dereferences in
 indexed components, slices, and selected components.
 
 @item -gnatw.d
-@emph{Activate tagging of warning messages.}
+@emph{Activate tagging of warning and info messages.}
 @cindex @option{-gnatw.d} (@command{gcc})
-If this switch is set, then warning messages are tagged, either with
-the string ``@option{-gnatw?}'' showing which switch controls the warning,
-or with ``[enabled by default]'' if the warning is not under control of a
-specific @option{-gnatw?} switch. This mode is off by default, and is not
-affected by the use of @code{-gnatwa}.
+If this switch is set, then warning messages are tagged, with one of the
+following strings:
+
+@table @option
+
+@item [-gnatw?]
+Used to tag warnings controlled by the switch @option{-gnatwx} where x
+is a letter a-z.
+
+@item [-gnatw.?]
+Used to tag warnings controlled by the switch @option{-gnatw.x} where x
+is a letter a-z.
+
+@item [-gnatel]
+Used to tag elaboration information (info) messages generated when the
+static model of elaboration is used and the @option{-gnatel} switch is set.
+
+@item [restriction warning]
+Used to tag warning messages for restriction violations, activated by use
+of the pragma @option{Restriction_Warnings}.
+
+@item [warning-as-error]
+Used to tag warning messages that have been converted to error messages by
+use of the pragma Warning_As_Error. Note that such warnings are prefixed by
+the string "error: " rather than "warning: ".
+
+@item [enabled by default]
+Used to tag all other warnings that are always given by default, unless
+warnings are completely suppressed using pragma @option{Warnings(Off)} or
+the switch @option{-gnatws}.
+
+@end table
 
 @item -gnatw.D
-@emph{Deactivate tagging of warning messages.}
+@emph{Deactivate tagging of warning and info messages messages.}
 @cindex @option{-gnatw.d} (@command{gcc})
 If this switch is set, then warning messages return to the default
-mode in which warnings are not tagged as described above for
+mode in which warnings and info messages are not tagged as described above for
 @code{-gnatw.d}.
 
 @item -gnatwe
diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb
index 0a658c963e1..dd4bdb4b329 100644
--- a/gcc/ada/par-ch7.adb
+++ b/gcc/ada/par-ch7.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -270,7 +270,7 @@ package body Ch7 is
                if Aspect_Sloc /= No_Location
                  and then not Aspect_Specifications_Present
                then
-                  Error_Msg_SC ("\info: aspect specifications belong here");
+                  Error_Msg_SC ("info: aspect specifications belong here??");
                   Move_Aspects (From => Dummy_Node, To => Package_Node);
                end if;
 
diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb
index a94d99a4eba..23a48158092 100644
--- a/gcc/ada/s-exctab.adb
+++ b/gcc/ada/s-exctab.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1996-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1996-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -31,71 +31,167 @@
 
 pragma Compiler_Unit_Warning;
 
-with System.HTable;
-with System.Soft_Links;   use System.Soft_Links;
+with System.Soft_Links; use System.Soft_Links;
 
 package body System.Exception_Table is
 
    use System.Standard_Library;
 
-   type HTable_Headers is range 1 .. 37;
-
-   procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
-   function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
-
-   function Hash (F : System.Address) return HTable_Headers;
-   function Equal (A, B : System.Address) return Boolean;
-   function Get_Key (T : Exception_Data_Ptr) return System.Address;
-
-   package Exception_HTable is new System.HTable.Static_HTable (
-     Header_Num => HTable_Headers,
-     Element    => Exception_Data,
-     Elmt_Ptr   => Exception_Data_Ptr,
-     Null_Ptr   => null,
-     Set_Next   => Set_HT_Link,
-     Next       => Get_HT_Link,
-     Key        => System.Address,
-     Get_Key    => Get_Key,
-     Hash       => Hash,
-     Equal      => Equal);
-
-   -----------
-   -- Equal --
-   -----------
-
-   function Equal (A, B : System.Address) return Boolean is
-      S1 : constant Big_String_Ptr := To_Ptr (A);
-      S2 : constant Big_String_Ptr := To_Ptr (B);
-      J : Integer := 1;
+   type Hash_Val is mod 2 ** 8;
+   subtype Hash_Idx is Hash_Val range 1 .. 37;
+
+   HTable : array (Hash_Idx) of aliased Exception_Data_Ptr;
+   --  Actual hash table containing all registered exceptions
+   --
+   --  The table is very small and the hash function weak, as looking up
+   --  registered exceptions is rare and minimizing space and time overhead
+   --  of registration is more important. In addition, it is expected that the
+   --  exceptions that need to be looked up are registered dynamically, and
+   --  therefore will be at the begin of the hash chains.
+   --
+   --  The table differs from System.HTable.Static_HTable in that the final
+   --  element of each chain is not marked by null, but by a pointer to self.
+   --  This way it is possible to defend against the same entry being inserted
+   --  twice, without having to do a lookup which is relatively expensive for
+   --  programs with large number
+   --
+   --  All non-local subprograms use the global Task_Lock to protect against
+   --  concurrent use of the exception table. This is needed as local
+   --  exceptions may be declared concurrently with those declared at the
+   --  library level.
+
+   --  Local Subprograms
+
+   generic
+      with procedure Process (T : Exception_Data_Ptr; More : out Boolean);
+   procedure Iterate;
+   --  Iterate over all
+
+   function Lookup  (Name : String) return Exception_Data_Ptr;
+   --  Find and return the Exception_Data of the exception with the given Name
+   --  (which must be in all uppercase), or null if none was registered.
+
+   procedure Register (Item : Exception_Data_Ptr);
+   --  Register an exception with the given Exception_Data in the table.
+
+   function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean;
+   --  Return True iff Item.Full_Name and Name are equal. Both names are
+   --  assumed to be in all uppercase and end with ASCII.NUL.
+
+   function Hash (S : String) return Hash_Idx;
+   --  Return the index in the hash table for S, which is assumed to be all
+   --  uppercase and end with ASCII.NUL.
+
+   --------------
+   -- Has_Name --
+   --------------
+
+   function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean
+   is
+      S : constant Big_String_Ptr := To_Ptr (Item.Full_Name);
+      J : Integer := S'First;
+
    begin
-      loop
-         if S1 (J) /= S2 (J) then
+      for K in Name'Range loop
+
+         --  Note that as both items are terminated with ASCII.NUL, the
+         --  comparison below must fail for strings of different lengths.
+
+         if S (J) /= Name (K) then
             return False;
-         elsif S1 (J) = ASCII.NUL then
-            return True;
-         else
-            J := J + 1;
          end if;
+
+         J := J + 1;
       end loop;
-   end Equal;
 
-   -----------------
-   -- Get_HT_Link --
-   -----------------
+      return True;
+   end Has_Name;
+
+   ------------
+   -- Lookup --
+   ------------
+
+   function Lookup (Name : String) return Exception_Data_Ptr is
+      Prev   : Exception_Data_Ptr;
+      Curr   : Exception_Data_Ptr;
+
+   begin
+      Curr := HTable (Hash (Name));
+      Prev := null;
+      while Curr /= Prev loop
+         if Has_Name (Curr, Name) then
+            return Curr;
+         end if;
+
+         Prev := Curr;
+         Curr := Curr.HTable_Ptr;
+      end loop;
+
+      return null;
+   end Lookup;
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (S : String) return Hash_Idx is
+      Hash : Hash_Val := 0;
 
-   function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
    begin
-      return T.HTable_Ptr;
-   end Get_HT_Link;
+      for J in S'Range loop
+         exit when S (J) = ASCII.NUL;
+         Hash := Hash xor Character'Pos (S (J));
+      end loop;
+
+      return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1);
+   end Hash;
 
    -------------
-   -- Get_Key --
+   -- Iterate --
    -------------
 
-   function Get_Key (T : Exception_Data_Ptr) return System.Address is
+   procedure Iterate is
+      More : Boolean;
+      Prev, Curr : Exception_Data_Ptr;
+
    begin
-      return T.Full_Name;
-   end Get_Key;
+      Outer : for Idx in HTable'Range loop
+         Prev   := null;
+         Curr   := HTable (Idx);
+
+         while Curr /= Prev loop
+               Process (Curr, More);
+
+               exit Outer when not More;
+
+               Prev := Curr;
+               Curr := Curr.HTable_Ptr;
+         end loop;
+      end loop Outer;
+   end Iterate;
+
+   --------------
+   -- Register --
+   --------------
+
+   procedure Register (Item : Exception_Data_Ptr) is
+   begin
+      if Item.HTable_Ptr = null then
+         Prepend_To_Chain : declare
+            Chain : Exception_Data_Ptr
+                      renames HTable (Hash (To_Ptr (Item.Full_Name).all));
+
+         begin
+            if Chain = null then
+               Item.HTable_Ptr := Item;
+            else
+               Item.HTable_Ptr := Chain;
+            end if;
+
+            Chain := Item;
+         end Prepend_To_Chain;
+      end if;
+   end Register;
 
    -------------------------------
    -- Get_Registered_Exceptions --
@@ -105,44 +201,40 @@ package body System.Exception_Table is
      (List : out Exception_Data_Array;
       Last : out Integer)
    is
-      Data : Exception_Data_Ptr := Exception_HTable.Get_First;
+      procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean);
+      --  Add Item to List (List'First .. Last) by first incrementing Last
+      --  and storing Item in List (Last). Last should be in List'First - 1
+      --  and List'Last.
 
-   begin
-      Lock_Task.all;
-      Last := List'First - 1;
+      procedure Get_All is new Iterate (Get_One);
+      --  Store all registered exceptions in List, updating Last
 
-      while Last < List'Last and then Data /= null loop
-         Last := Last + 1;
-         List (Last) := Data;
-         Data := Exception_HTable.Get_Next;
-      end loop;
+      -------------
+      -- Get_One --
+      -------------
 
-      Unlock_Task.all;
-   end Get_Registered_Exceptions;
+      procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is
+      begin
+         if Last < List'Last then
+            Last := Last + 1;
+            List (Last) := Item;
+            More := True;
 
-   ----------
-   -- Hash --
-   ----------
+         else
+            More := False;
+         end if;
+      end Get_One;
 
-   function Hash (F : System.Address) return HTable_Headers is
-      type S is mod 2**8;
+   begin
+      --  In this routine the invariant is that List (List'First .. Last)
+      --  contains the registered exceptions retrieved so far.
 
-      Str  : constant Big_String_Ptr := To_Ptr (F);
-      Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
-      Tmp  : S := 0;
-      J    : Positive;
+      Last := List'First - 1;
 
-   begin
-      J := 1;
-      loop
-         if Str (J) = ASCII.NUL then
-            return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
-         else
-            Tmp := Tmp xor S (Character'Pos (Str (J)));
-         end if;
-         J := J + 1;
-      end loop;
-   end Hash;
+      Lock_Task.all;
+      Get_All;
+      Unlock_Task.all;
+   end Get_Registered_Exceptions;
 
    ------------------------
    -- Internal_Exception --
@@ -152,25 +244,30 @@ package body System.Exception_Table is
      (X                   : String;
       Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
    is
+      --  If X was not yet registered and Create_if_Not_Exist is True,
+      --  dynamically allocate and register a new exception.
+
       type String_Ptr is access all String;
 
-      Copy     : aliased String (X'First .. X'Last + 1);
-      Res      : Exception_Data_Ptr;
       Dyn_Copy : String_Ptr;
+      Copy     : aliased String (X'First .. X'Last + 1);
+      Result   : Exception_Data_Ptr;
 
    begin
+      Lock_Task.all;
+
       Copy (X'Range) := X;
       Copy (Copy'Last) := ASCII.NUL;
-      Res := Exception_HTable.Get (Copy'Address);
+      Result := Lookup (Copy);
 
       --  If unknown exception, create it on the heap. This is a legitimate
-      --  situation in the distributed case when an exception is defined only
-      --  in a partition
+      --  situation in the distributed case when an exception is defined
+      --  only in a partition
 
-      if Res = null and then Create_If_Not_Exist then
+      if Result = null and then Create_If_Not_Exist then
          Dyn_Copy := new String'(Copy);
 
-         Res :=
+         Result :=
            new Exception_Data'
              (Not_Handled_By_Others => False,
               Lang                  => 'A',
@@ -180,10 +277,12 @@ package body System.Exception_Table is
               Foreign_Data          => Null_Address,
               Raise_Hook            => null);
 
-         Register_Exception (Res);
+         Register (Result);
       end if;
 
-      return Res;
+      Unlock_Task.all;
+
+      return Result;
    end Internal_Exception;
 
    ------------------------
@@ -192,7 +291,9 @@ package body System.Exception_Table is
 
    procedure Register_Exception (X : Exception_Data_Ptr) is
    begin
-      Exception_HTable.Set (X);
+      Lock_Task.all;
+      Register (X);
+      Unlock_Task.all;
    end Register_Exception;
 
    ---------------------------------
@@ -201,43 +302,38 @@ package body System.Exception_Table is
 
    function Registered_Exceptions_Count return Natural is
       Count : Natural := 0;
-      Data  : Exception_Data_Ptr := Exception_HTable.Get_First;
 
-   begin
-      --  We need to lock the runtime in the meantime, to avoid concurrent
-      --  access since we have only one iterator.
-
-      Lock_Task.all;
+      procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean);
+      --  Update Count for given Item
 
-      while Data /= null loop
+      procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is
+         pragma Unreferenced (Item);
+      begin
          Count := Count + 1;
-         Data := Exception_HTable.Get_Next;
-      end loop;
+         More := Count < Natural'Last;
+      end Count_Item;
 
-      Unlock_Task.all;
-      return Count;
-   end Registered_Exceptions_Count;
-
-   -----------------
-   -- Set_HT_Link --
-   -----------------
+      procedure Count_All is new Iterate (Count_Item);
 
-   procedure Set_HT_Link
-     (T    : Exception_Data_Ptr;
-      Next : Exception_Data_Ptr)
-   is
    begin
-      T.HTable_Ptr := Next;
-   end Set_HT_Link;
+      Lock_Task.all;
+      Count_All;
+      Unlock_Task.all;
 
---  Register the standard exceptions at elaboration time
+      return Count;
+   end Registered_Exceptions_Count;
 
 begin
-   Register_Exception (Abort_Signal_Def'Access);
-   Register_Exception (Tasking_Error_Def'Access);
-   Register_Exception (Storage_Error_Def'Access);
-   Register_Exception (Program_Error_Def'Access);
-   Register_Exception (Numeric_Error_Def'Access);
-   Register_Exception (Constraint_Error_Def'Access);
-
+   --  Register the standard exceptions at elaboration time
+
+   --  We don't need to use the locking version here as the elaboration
+   --  will not be concurrent and no tasks can call any subprograms of this
+   --  unit before it has been elaborated.
+
+   Register (Abort_Signal_Def'Access);
+   Register (Tasking_Error_Def'Access);
+   Register (Storage_Error_Def'Access);
+   Register (Program_Error_Def'Access);
+   Register (Numeric_Error_Def'Access);
+   Register (Constraint_Error_Def'Access);
 end System.Exception_Table;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index bf42b0eebc4..6417523335a 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -661,12 +661,12 @@ package body Sem_Ch13 is
 
                            if Bytes_Big_Endian then
                               Error_Msg_NE
-                                ("\info: big-endian range for "
+                                ("\big-endian range for "
                                  & "component & is ^ .. ^?V?",
                                  First_Bit (CC), Comp);
                            else
                               Error_Msg_NE
-                                ("\info: little-endian range "
+                                ("\little-endian range "
                                  & "for component & is ^ .. ^?V?",
                                  First_Bit (CC), Comp);
                            end if;
@@ -6324,7 +6324,7 @@ package body Sem_Ch13 is
                if Inherit and Opt.List_Inherited_Aspects then
                   Error_Msg_Sloc := Sloc (Ritem);
                   Error_Msg_N
-                    ("?L?info: & inherits `Invariant''Class` aspect from #",
+                    ("info: & inherits `Invariant''Class` aspect from #?L?",
                      Typ);
                end if;
             end if;
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 7afe23676c5..d9a9dab88ec 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2885,13 +2885,12 @@ package body Sem_Ch7 is
       --  Body required if library package with pragma Elaborate_Body
 
       elsif Has_Pragma_Elaborate_Body (P) then
-         Error_Msg_N
-           ("?Y?info: & requires body (Elaborate_Body)", P);
+         Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", P);
 
       --  Body required if subprogram
 
       elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
-         Error_Msg_N ("?Y?info: & requires body (subprogram case)", P);
+         Error_Msg_N ("info: & requires body (subprogram case)?Y?", P);
 
       --  Body required if generic parent has Elaborate_Body
 
@@ -2904,7 +2903,7 @@ package body Sem_Ch7 is
          begin
             if Has_Pragma_Elaborate_Body (G_P) then
                Error_Msg_N
-                 ("?Y?info: & requires body (generic parent Elaborate_Body)",
+                 ("info: & requires body (generic parent Elaborate_Body)?Y?",
                   P);
             end if;
          end;
@@ -2922,7 +2921,7 @@ package body Sem_Ch7 is
           not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
       then
          Error_Msg_N
-           ("?Y?info: & requires body (non-null abstract state aspect)", P);
+           ("info: & requires body (non-null abstract state aspect)?Y?", P);
       end if;
 
       --  Otherwise search entity chain for entity requiring completion
@@ -2985,7 +2984,7 @@ package body Sem_Ch7 is
          then
             Error_Msg_Node_2 := E;
             Error_Msg_NE
-              ("?Y?info: & requires body (& requires completion)",
+              ("info: & requires body (& requires completion)?Y?",
                E, P);
 
          --  Entity that does not require completion
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 7f494d85183..da327315730 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -942,7 +942,7 @@ package body Sem_Elab is
                if Inst_Case then
                   Elab_Warning
                     ("instantiation of& may raise Program_Error?l?",
-                     "info: instantiation of& during elaboration?", Ent);
+                     "info: instantiation of& during elaboration?$?", Ent);
 
                --  Indirect call case, info message only in static elaboration
                --  case, because the attribute reference itself cannot raise
@@ -950,7 +950,7 @@ package body Sem_Elab is
 
                elsif Access_Case then
                   Elab_Warning
-                    ("", "info: access to& during elaboration?", Ent);
+                    ("", "info: access to& during elaboration?$?", Ent);
 
                --  Subprogram call case
 
@@ -961,13 +961,13 @@ package body Sem_Elab is
                   then
                      Elab_Warning
                        ("implicit call to & may raise Program_Error?l?",
-                        "info: implicit call to & during elaboration?",
+                        "info: implicit call to & during elaboration?$?",
                         Ent);
 
                   else
                      Elab_Warning
                        ("call to & may raise Program_Error?l?",
-                        "info: call to & during elaboration?",
+                        "info: call to & during elaboration?$?",
                         Ent);
                   end if;
                end if;
@@ -977,13 +977,13 @@ package body Sem_Elab is
                if Nkind (N) in N_Subprogram_Instantiation then
                   Elab_Warning
                     ("\missing pragma Elaborate for&?l?",
-                     "\info: implicit pragma Elaborate for& generated?",
+                     "\implicit pragma Elaborate for& generated?$?",
                      W_Scope);
 
                else
                   Elab_Warning
                     ("\missing pragma Elaborate_All for&?l?",
-                     "\info: implicit pragma Elaborate_All for & generated?",
+                     "\implicit pragma Elaborate_All for & generated?$?",
                      W_Scope);
                end if;
             end Generate_Elab_Warnings;
@@ -1063,7 +1063,7 @@ package body Sem_Elab is
                   Error_Msg_Node_2 := W_Scope;
                   Error_Msg_NE
                     ("info: call to& in elaboration code " &
-                     "requires pragma Elaborate_All on&?", N, E);
+                     "requires pragma Elaborate_All on&?$?", N, E);
                end if;
 
                --  Set indication for binder to generate Elaborate_All
@@ -2320,15 +2320,14 @@ package body Sem_Elab is
 
             if Inst_Case then
                Error_Msg_NE
-                 ("instantiation of& may occur before body is seen<<",
+                 ("instantiation of& may occur before body is seen<l<",
                   N, Orig_Ent);
             else
                Error_Msg_NE
-                 ("call to& may occur before body is seen<<", N, Orig_Ent);
+                 ("call to& may occur before body is seen<l<", N, Orig_Ent);
             end if;
 
-            Error_Msg_N
-              ("\Program_Error ]<<", N);
+            Error_Msg_N ("\Program_Error ]<l<", N);
 
             Output_Calls (N);
          end if;
@@ -2570,7 +2569,7 @@ package body Sem_Elab is
                Error_Msg_Node_2 := Task_Scope;
                Error_Msg_NE
                  ("info: activation of an instance of task type&" &
-                  " requires pragma Elaborate_All on &?", N, Ent);
+                  " requires pragma Elaborate_All on &?$?", N, Ent);
             end if;
 
             Activate_Elaborate_All_Desirable (N, Task_Scope);
@@ -3056,6 +3055,10 @@ package body Sem_Elab is
       --  by the error message circuits (i.e. it has a single upper
       --  case letter at the end).
 
+      -----------------------------
+      -- Is_Printable_Error_Name --
+      -----------------------------
+
       function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
       begin
          if not Is_Internal_Name (Nm) then
@@ -3078,17 +3081,31 @@ package body Sem_Elab is
 
          Ent := Elab_Call.Table (J).Ent;
 
-         if Is_Generic_Unit (Ent) then
-            Error_Msg_NE ("\??& instantiated #", N, Ent);
+         --  Dynamic elaboration model, warnings controlled by -gnatwl
 
-         elsif Is_Init_Proc (Ent) then
-            Error_Msg_N ("\??initialization procedure called #", N);
+         if Dynamic_Elaboration_Checks then
+            if Is_Generic_Unit (Ent) then
+               Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
+            elsif Is_Init_Proc (Ent) then
+               Error_Msg_N ("\\?l?initialization procedure called #", N);
+            elsif Is_Printable_Error_Name (Chars (Ent)) then
+               Error_Msg_NE ("\\?l?& called #", N, Ent);
+            else
+               Error_Msg_N ("\\?l?called #", N);
+            end if;
 
-         elsif Is_Printable_Error_Name (Chars (Ent)) then
-            Error_Msg_NE ("\??& called #", N, Ent);
+         --  Static elaboration model, info messages controlled by -gnatel
 
          else
-            Error_Msg_N ("\?? called #", N);
+            if Is_Generic_Unit (Ent) then
+               Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
+            elsif Is_Init_Proc (Ent) then
+               Error_Msg_N ("\\?$?initialization procedure called #", N);
+            elsif Is_Printable_Error_Name (Chars (Ent)) then
+               Error_Msg_NE ("\\?$?& called #", N, Ent);
+            else
+               Error_Msg_N ("\\?$?called #", N);
+            end if;
          end if;
       end loop;
    end Output_Calls;