gcc-reflection/gcc/ada/erroutc.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E R R O U T C                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2026, 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- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Warning: Error messages can be generated during Gigi processing by direct
--  calls to error message routines, so it is essential that the processing
--  in this body be consistent with the requirements for the Gigi processing
--  environment, and that in particular, no disallowed table expansion is
--  allowed to occur.

with Atree;    use Atree;
with Casing;   use Casing;
with Csets;    use Csets;
with Debug;    use Debug;
with Err_Vars; use Err_Vars;
with Errid.Switch_Repository; use Errid.Switch_Repository;
with Fname;    use Fname;
with Namet;    use Namet;
with Opt;      use Opt;
with Output;   use Output;
with Sinfo.Nodes;
with Sinput;   use Sinput;
with Snames;   use Snames;
with Stringt;  use Stringt;
with Stylesw;  use Stylesw;
with Targparm;
with Uintp;    use Uintp;
with Widechar; use Widechar;
with Warnsw;   use Warnsw;

package body Erroutc is

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean;
   --  Return whether Loc is in the range Start .. Stop, taking instantiation
   --  locations of Loc into account. This is useful for suppressing warnings
   --  from generic instantiations by using pragma Warnings around generic
   --  instances, as needed in GNATprove.

   function Has_Switch_Tag (Id : Error_Msg_Id) return Boolean;
   function Has_Switch_Tag (E_Msg : Error_Msg_Object) return Boolean;
   --  Returns True if the E_Msg is Warning, Style or Info and has a non-empty
   --  Warn_Char.

   ---------------
   -- Add_Class --
   ---------------

   procedure Add_Class is
   begin
      if Class_Flag then
         Class_Flag := False;
         Set_Msg_Char (''');
         Get_Name_String (Name_Class);
         Set_Casing (Identifier_Casing (Flag_Source));
         Set_Msg_Name_Buffer;
      end if;
   end Add_Class;

   ----------------------
   -- Buffer_Ends_With --
   ----------------------

   function Buffer_Ends_With (C : Character) return Boolean is
   begin
      return Msglen > 0 and then Msg_Buffer (Msglen) = C;
   end Buffer_Ends_With;

   function Buffer_Ends_With (S : String) return Boolean is
      Len : constant Natural := S'Length;
   begin
      return Msglen > Len
        and then Msg_Buffer (Msglen - Len) = ' '
        and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
   end Buffer_Ends_With;

   -------------------
   -- Buffer_Remove --
   -------------------

   procedure Buffer_Remove (C : Character) is
   begin
      if Buffer_Ends_With (C) then
         Msglen := Msglen - 1;
      end if;
   end Buffer_Remove;

   procedure Buffer_Remove (S : String) is
   begin
      if Buffer_Ends_With (S) then
         Msglen := Msglen - S'Length;
      end if;
   end Buffer_Remove;

   -----------------------------
   -- Check_Duplicate_Message --
   -----------------------------

   procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
      L1, L2 : Error_Msg_Id;
      N1, N2 : Error_Msg_Id;

      procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
      --  Called to delete message Delete, keeping message Keep. Marks msg
      --  Delete and all its continuations with deleted flag set to True.
      --  Also makes sure that for the error messages that are retained the
      --  preferred message is the one retained (we prefer the shorter one in
      --  the case where one has an Instance tag). Note that we always know
      --  that Keep has at least as many continuations as Delete (since we
      --  always delete the shorter sequence).

      ----------------
      -- Delete_Msg --
      ----------------

      procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
         D, K : Error_Msg_Id;

      begin
         D := Delete;
         K := Keep;

         loop
            Errors.Table (D).Deleted := True;

            Decrease_Error_Msg_Count (Errors.Table (D));

            --  Substitute shorter of the two error messages

            if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
               Errors.Table (K).Text := Errors.Table (D).Text;
            end if;

            D := Errors.Table (D).Next;
            K := Errors.Table (K).Next;

            if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
               return;
            end if;
         end loop;
      end Delete_Msg;

   --  Start of processing for Check_Duplicate_Message

   begin
      --  Both messages must be non-continuation messages and not deleted

      if Errors.Table (M1).Msg_Cont
        or else Errors.Table (M2).Msg_Cont
        or else Errors.Table (M1).Deleted
        or else Errors.Table (M2).Deleted
      then
         return;
      end if;

      --  Definitely not equal if message text does not match

      if not Same_Error (M1, M2) then
         return;
      end if;

      --  Same text. See if all continuations are also identical

      L1 := M1;
      L2 := M2;

      loop
         N1 := Errors.Table (L1).Next;
         N2 := Errors.Table (L2).Next;

         --  If M1 continuations have run out, we delete M1, either the
         --  messages have the same number of continuations, or M2 has
         --  more and we prefer the one with more anyway.

         if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
            Delete_Msg (M1, M2);
            return;

         --  If M2 continuations have run out, we delete M2

         elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
            Delete_Msg (M2, M1);
            return;

         --  Otherwise see if continuations are the same, if not, keep both
         --  sequences, a curious case, but better to keep everything.

         elsif not Same_Error (N1, N2) then
            return;

         --  If continuations are the same, continue scan

         else
            L1 := N1;
            L2 := N2;
         end if;
      end loop;
   end Check_Duplicate_Message;

   ------------------------
   -- Compilation_Errors --
   ------------------------

   function Compilation_Errors return Boolean is
   begin
      return Total_Errors_Detected /= 0
        or else Warnings_Treated_As_Errors /= 0;
   end Compilation_Errors;

   ------------------------------
   -- Decrease_Error_Msg_Count --
   ------------------------------

   procedure Decrease_Error_Msg_Count (E : Error_Msg_Object) is

   begin
      case E.Kind is
         when Info =>
            Info_Messages := Info_Messages - 1;

         when Warning | Style =>
            Warnings_Detected := Warnings_Detected - 1;

            if E.Warn_Err /= None then
               Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
            end if;

         when High_Check | Medium_Check | Low_Check =>
            Check_Messages := Check_Messages - 1;

         when Error =>
            Total_Errors_Detected := Total_Errors_Detected - 1;
            Serious_Errors_Detected := Serious_Errors_Detected - 1;

         when Non_Serious_Error =>
            Total_Errors_Detected := Total_Errors_Detected - 1;
      end case;
   end Decrease_Error_Msg_Count;

   ------------------
   -- Debug_Output --
   ------------------

   procedure Debug_Output (N : Node_Id) is
   begin
      if Debug_Flag_1 then
         Write_Str ("*** following error message posted on node id = #");
         Write_Int (Int (N));
         Write_Str (" ***");
         Write_Eol;
      end if;
   end Debug_Output;

   ----------
   -- dmsg --
   ----------

   procedure dmsg (Id : Error_Msg_Id) is
      E : Error_Msg_Object renames Errors.Table (Id);

   begin
      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
        ("  Sptr               = ");
      Write_Location (E.Sptr.Ptr);  --  ??? Do not write the full span for now
      Write_Eol;

      Write_Str
        ("  Optr               = ");
      Write_Location (E.Optr.Ptr);
      Write_Eol;

      Write_Str
        ("  Insertion_Sloc     = ");
      Write_Location (E.Insertion_Sloc);
      Write_Eol;

      w ("  Line               = ", Int (E.Line));
      w ("  Col                = ", Int (E.Col));
      w ("  Kind               = ", E.Kind'Img);
      w ("  Warn_Err           = ", E.Warn_Err'Img);
      w ("  Warn_Chr           = '" & E.Warn_Chr & ''');
      w ("  Uncond             = ", E.Uncond);
      w ("  Msg_Cont           = ", E.Msg_Cont);
      w ("  Deleted            = ", E.Deleted);

      Write_Eol;
   end dmsg;

   ------------------
   -- Get_Location --
   ------------------

   function Get_Location (E : Error_Msg_Id) return Source_Ptr is
   begin
      return Errors.Table (E).Sptr.Ptr;
   end Get_Location;

   ----------------
   -- Get_Msg_Id --
   ----------------

   function Get_Msg_Id return Error_Msg_Id is
   begin
      return Cur_Msg;
   end Get_Msg_Id;

   ------------------------
   -- Get_Warning_Option --
   ------------------------

   function Get_Warning_Option (Id : Error_Msg_Id) return String is
   begin
      return Get_Warning_Option (Errors.Table (Id));
   end Get_Warning_Option;

   function Get_Warning_Option (E : Error_Msg_Object) return String is
      Is_Style : constant Boolean         := E.Kind in Style;
      Warn_Chr : constant String (1 .. 2) := E.Warn_Chr;

   begin
      if Has_Switch_Tag (E)
        and then Warn_Chr (1) /= '?'
      then
         if Warn_Chr = "$ " then
            return "-gnatel";
         elsif Is_Style then
            return "-gnaty" & Warn_Chr (1);
         elsif Warn_Chr (2) = ' ' then
            return "-gnatw" & Warn_Chr (1);
         else
            return "-gnatw" & Warn_Chr;
         end if;
      end if;

      return "";
   end Get_Warning_Option;

   ---------------------
   -- Get_Warning_Tag --
   ---------------------

   function Get_Warning_Tag (Id : Error_Msg_Id) return String is
   begin
      return Get_Warning_Tag (Errors.Table (Id));
   end Get_Warning_Tag;

   function Get_Warning_Tag (E : Error_Msg_Object) return String is
      Warn_Chr : constant String (1 .. 2) := E.Warn_Chr;
      Option   : constant String          := Get_Warning_Option (E);

   begin
      if Has_Switch_Tag (E) then
         if Warn_Chr = "? " then
            return "[enabled by default]";
         elsif Warn_Chr = "* " then
            return "[restriction warning]";
         elsif Option /= "" then
            return "[" & Option & "]";
         end if;
      end if;

      return "";
   end Get_Warning_Tag;

   ------------------------------
   -- Increase_Error_Msg_Count --
   ------------------------------

   procedure Increase_Error_Msg_Count (E : Error_Msg_Object) is

   begin
      case E.Kind is
         when Info =>
            Info_Messages := Info_Messages + 1;

         when Warning | Style =>
            Warnings_Detected := Warnings_Detected + 1;

            if E.Warn_Err /= None then
               Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;

               --  Propagate Warn_Err to all of the preceeding continuation
               --  messages and the main message.

               for J in reverse 1 .. Errors.Last loop
                  if Errors.Table (J).Warn_Err = None then
                     Errors.Table (J).Warn_Err := E.Warn_Err;

                     Warnings_Treated_As_Errors :=
                       Warnings_Treated_As_Errors + 1;
                  end if;

                  exit when not Errors.Table (J).Msg_Cont;
               end loop;
            end if;

         when High_Check | Medium_Check | Low_Check =>
            Check_Messages := Check_Messages + 1;

         when Error =>
            Total_Errors_Detected := Total_Errors_Detected + 1;
            Serious_Errors_Detected := Serious_Errors_Detected + 1;

         when Non_Serious_Error =>
            Total_Errors_Detected := Total_Errors_Detected + 1;
      end case;
   end Increase_Error_Msg_Count;

   --------------------------------
   -- Is_Redundant_Error_Message --
   --------------------------------

   function Is_Redundant_Error_Message
     (Prev_Msg : Error_Msg_Id; Cur_Msg : Error_Msg_Id) return Boolean is

   begin
      return
        Prev_Msg /= No_Error_Msg

        --  Error messages are posted on the same line

        and then Errors.Table (Prev_Msg).Line = Errors.Table (Cur_Msg).Line
        and then Errors.Table (Prev_Msg).Sfile = Errors.Table (Cur_Msg).Sfile

        --  Do not consider unconditional messages to be redundant right now
        --  They may be removed later.

        and then not Errors.Table (Cur_Msg).Uncond

        --  Do not consider continuation messages as they are removed with
        --  their parent later on.

        and then not Errors.Table (Cur_Msg).Msg_Cont

        --  Don't delete if prev msg is warning or a non-serious-error and new
        --  msg is an error. This is because we don't want a real error masked
        --  by a warning. In all other cases (that is parse errors for the same
        --  line that are not unconditional) we do delete the message. This
        --  helps to avoid junk extra messages from cascaded parsing errors.

        and then (Errors.Table (Prev_Msg).Kind
                  not in Warning | Style | Non_Serious_Error
                  or else Errors.Table (Cur_Msg).Kind
                          in Warning | Style | Non_Serious_Error);
   end Is_Redundant_Error_Message;

   --------------------
   -- Has_Switch_Tag --
   --------------------

   function Has_Switch_Tag (Id : Error_Msg_Id) return Boolean
   is (Has_Switch_Tag (Errors.Table (Id)));

   function Has_Switch_Tag (E_Msg : Error_Msg_Object) return Boolean is
   begin
      return
        E_Msg.Kind in Warning | Info | Style and then E_Msg.Warn_Chr /= "  ";
   end Has_Switch_Tag;

   --------------------
   -- Next_Error_Msg --
   --------------------

   procedure Next_Error_Msg (E : in out Error_Msg_Id) is
   begin
      loop
         E := Errors.Table (E).Next;
         exit when E = No_Error_Msg;
         exit when not Errors.Table (E).Deleted
           and then not Errors.Table (E).Msg_Cont;
      end loop;
   end Next_Error_Msg;

   ---------------------------
   -- Next_Continuation_Msg --
   ---------------------------

   procedure Next_Continuation_Msg (E : in out Error_Msg_Id) is
   begin
      E := Errors.Table (E).Next;

      if E = No_Error_Msg or else not Errors.Table (E).Msg_Cont then
         E := No_Error_Msg;
      end if;
   end Next_Continuation_Msg;

   ----------------------
   -- Primary_Location --
   ----------------------

   function Primary_Location (E : Error_Msg_Object) return Labeled_Span_Id is
      L : Labeled_Span_Id;
   begin
      L := E.Locations;
      while L /= No_Labeled_Span loop
         if Locations.Table (L).Is_Primary then
            return L;
         end if;

         L := Locations.Table (L).Next;
      end loop;

      return No_Labeled_Span;
   end Primary_Location;

   --------------------
   -- Get_Doc_Switch --
   --------------------

   function Get_Doc_Switch (E : Error_Msg_Object) return String is
   begin
      if Warning_Doc_Switch
        and then E.Warn_Chr /= "  "
        and then E.Kind in Info
          | Style
          | Warning
      then
         if E.Switch = No_Switch_Id then
            if E.Warn_Chr = "* " then
               return "[restriction warning]";

               --  Info messages can have a switch tag but they should not have
               --  a default switch tag.

            elsif E.Kind /= Info then

               --  For Default_Warning

               return "[enabled by default]";
            end if;
         else
            return "[-" & Switches (E.Switch).Short_Name.all & "]";
         end if;
      end if;

      return "";
   end Get_Doc_Switch;

   -------------------
   -- Get_Switch_Id --
   -------------------

   function Get_Switch_Id (E : Error_Msg_Object) return Switch_Id is
   begin
      return Get_Switch_Id (E.Kind, E.Warn_Chr);
   end Get_Switch_Id;

   function Get_Switch_Id
     (Kind : Error_Msg_Type; Warn_Chr : String) return Switch_Id is
   begin
      if Warn_Chr = "$ " then
         return Get_Switch_Id ("gnatel");
      elsif Kind in Warning | Info then
         return Get_Switch_Id ("gnatw" & Warn_Chr);
      elsif Kind = Style then
         return Get_Switch_Id ("gnaty" & Warn_Chr);
      else
         return No_Switch_Id;
      end if;
   end Get_Switch_Id;

   -------------
   -- Matches --
   -------------

   function Matches (S : String; P : String) return Boolean is
      Slast : constant Natural := S'Last;
      PLast : constant Natural := P'Last;

      SPtr : Natural := S'First;
      PPtr : Natural := P'First;

   begin
      --  Loop advancing through characters of string and pattern

      SPtr := S'First;
      PPtr := P'First;
      loop
         --  Return True if pattern is a single asterisk

         if PPtr = PLast and then P (PPtr) = '*' then
            return True;

         --  Return True if both pattern and string exhausted

         elsif PPtr > PLast and then SPtr > Slast then
            return True;

         --  Return False, if one exhausted and not the other

         elsif PPtr > PLast or else SPtr > Slast then
            return False;

         --  Case where pattern starts with asterisk

         elsif P (PPtr) = '*' then

            --  Try all possible starting positions in S for match with the
            --  remaining characters of the pattern. This is the recursive
            --  call that implements the scanner backup.

            for J in SPtr .. Slast loop
               if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
                  return True;
               end if;
            end loop;

            return False;

         --  Dealt with end of string and *, advance if we have a match

         elsif Fold_Lower (S (SPtr)) = Fold_Lower (P (PPtr)) then
            SPtr := SPtr + 1;
            PPtr := PPtr + 1;

         --  If first characters do not match, that's decisive

         else
            return False;
         end if;
      end loop;
   end Matches;

   -----------------------
   -- Output_Error_Msgs --
   -----------------------

   procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
      P : Source_Ptr;
      T : Error_Msg_Id;
      S : Error_Msg_Id;

      Flag_Num   : Pos;
      Mult_Flags : Boolean := False;

   begin
      S := E;

      --  Skip deleted messages at start

      if Errors.Table (S).Deleted then
         Set_Next_Non_Deleted_Msg (S);
      end if;

      --  Figure out if we will place more than one error flag on this line

      T := S;
      while T /= No_Error_Msg
        and then Errors.Table (T).Line = Errors.Table (E).Line
        and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
      loop
         if Errors.Table (T).Sptr.Ptr > Errors.Table (E).Sptr.Ptr then
            Mult_Flags := True;
         end if;

         Set_Next_Non_Deleted_Msg (T);
      end loop;

      --  Output the error flags. The circuit here makes sure that the tab
      --  characters in the original line are properly accounted for. The
      --  eight blanks at the start are to match the line number.

      if not Debug_Flag_2 then
         Write_Str ("        ");
         P := Line_Start (Errors.Table (E).Sptr.Ptr);
         Flag_Num := 1;

         --  Loop through error messages for this line to place flags

         T := S;
         while T /= No_Error_Msg
           and then Errors.Table (T).Line = Errors.Table (E).Line
           and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
         loop
            declare
               Src : Source_Buffer_Ptr
                       renames Source_Text (Errors.Table (T).Sfile);

            begin
               --  Loop to output blanks till current flag position

               while P < Errors.Table (T).Sptr.Ptr loop

                  --  Horizontal tab case, just echo the tab

                  if Src (P) = ASCII.HT then
                     Write_Char (ASCII.HT);
                     P := P + 1;

                  --  Deal with wide character case, but don't include brackets
                  --  notation in this circuit, since we know that this will
                  --  display unencoded (no one encodes brackets notation).

                  elsif Src (P) /= '['
                    and then Is_Start_Of_Wide_Char (Src, P)
                  then
                     Skip_Wide (Src, P);
                     Write_Char (' ');

                  --  Normal non-wide character case (or bracket)

                  else
                     P := P + 1;
                     Write_Char (' ');
                  end if;
               end loop;

               --  Output flag (unless already output, this happens if more
               --  than one error message occurs at the same flag position).

               if P = Errors.Table (T).Sptr.Ptr then
                  if (Flag_Num = 1 and then not Mult_Flags)
                    or else Flag_Num > 9
                  then
                     Write_Char ('|');
                  else
                     Write_Char
                       (Character'Val (Character'Pos ('0') + Flag_Num));
                  end if;

                  --  Skip past the corresponding source text character

                  --  Horizontal tab case, we output a flag at the tab position
                  --  so now we output a tab to match up with the text.

                  if Src (P) = ASCII.HT then
                     Write_Char (ASCII.HT);
                     P := P + 1;

                  --  Skip wide character other than left bracket

                  elsif Src (P) /= '['
                    and then Is_Start_Of_Wide_Char (Src, P)
                  then
                     Skip_Wide (Src, P);

                  --  Skip normal non-wide character case (or bracket)

                  else
                     P := P + 1;
                  end if;
               end if;
            end;

            Set_Next_Non_Deleted_Msg (T);
            Flag_Num := Flag_Num + 1;
         end loop;

         Write_Eol;
      end if;

      --  Now output the error messages

      T := S;
      while T /= No_Error_Msg
        and then Errors.Table (T).Line = Errors.Table (E).Line
        and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
      loop
         Write_Str ("        >>> ");
         Output_Msg_Text (T);

         if Debug_Flag_2 then
            while Column < 74 loop
               Write_Char (' ');
            end loop;

            Write_Str (" <<<");
         end if;

         Write_Eol;
         Set_Next_Non_Deleted_Msg (T);
      end loop;

      E := T;
   end Output_Error_Msgs;

   ------------------------
   -- Output_Line_Number --
   ------------------------

   procedure Output_Line_Number (L : Logical_Line_Number) is
      D     : Int;       -- next digit
      C     : Character; -- next character
      Z     : Boolean;   -- flag for zero suppress
      N, M  : Int;       -- temporaries

   begin
      if L = No_Line_Number then
         Write_Str ("        ");

      else
         Z := False;
         N := Int (L);

         M := 100_000;
         while M /= 0 loop
            D := Int (N / M);
            N := N rem M;
            M := M / 10;

            if D = 0 then
               if Z then
                  C := '0';
               else
                  C := ' ';
               end if;
            else
               Z := True;
               C := Character'Val (D + 48);
            end if;

            Write_Char (C);
         end loop;

         Write_Str (". ");
      end if;
   end Output_Line_Number;

   ------------------------
   -- Output_Text_Within --
   ------------------------

   procedure Output_Text_Within (Txt : String; Line_Length : Nat) is
      Offs : constant Nat := Column - 1;
      --  Offset to start of message, used for continuations

      Ptr   : Natural;

      Split : Natural;
      --   Position where a new line was inserted in the original message

      Start : Natural;
      --   Start of the current line

      Max   : Integer := Integer (Line_Length - Column + 1);
      --  Maximum characters to output on next line

      Text_Length : constant Natural := Txt'Length;
      --  Length of the message

   begin
      --  Here we have to split the message up into multiple lines

      Ptr := 1;
      loop
         --  Make sure we do not have ludicrously small line

         Max := Integer'Max (Max, 20);

         --  If remaining text fits, output it respecting LF and we are done

         if Text_Length - Ptr < Max then
            for J in Ptr .. Text_Length 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;

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

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

            --  If we fall through, no space, so split line arbitrarily

            Split := Ptr + Max - 1;
            Ptr := Split + 1;
         end if;

         <<Continue>>
         if Start <= Split then
            Write_Line (Txt (Start .. Split));
            Write_Spaces (Offs);
         end if;

         Max := Integer (Line_Length - Column + 1);
      end loop;
   end Output_Text_Within;

   -------------------------
   -- Output_Msg_Location --
   -------------------------

   procedure Output_Msg_Location (E : Error_Msg_Id) is
      E_Obj : constant Error_Msg_Object := Errors.Table (E);
   begin
      Write_Str (SGR_Locus);

      if Full_Path_Name_For_Brief_Errors then
         Write_Name (Full_Ref_Name (E_Obj.Sfile));
      else
         Write_Name (Reference_Name (E_Obj.Sfile));
      end if;

      Write_Char (':');
      Write_Int (Int (Physical_To_Logical (E_Obj.Line, E_Obj.Sfile)));
      Write_Char (':');

      if E_Obj.Col < 10 then
         Write_Char ('0');
      end if;

      Write_Int (Int (E_Obj.Col));
      Write_Str (": ");

      Write_Str (SGR_Reset);
   end Output_Msg_Location;

   ---------------------
   -- Output_Msg_Text --
   ---------------------

   procedure Output_Msg_Text (E : Error_Msg_Id) is

      E_Msg       : Error_Msg_Object renames Errors.Table (E);
      Text        : constant String_Ptr := E_Msg.Text;
      Tag         : constant String     := Get_Warning_Tag (E);
      SGR_Code    : constant String     := Get_SGR_Code (E_Msg);
      Kind_Prefix : constant String     :=
        (if E_Msg.Kind = Style then Style_Prefix
         else Kind_To_String (E_Msg) & ": ");
      Buf         : Bounded_String (Max_Msg_Length);
      Line_Length : constant Nat        :=
        (if Error_Msg_Line_Length = 0 then Nat'Last
         else Error_Msg_Line_Length);

   begin
      --  Prefix with "error:" rather than warning.
      --  Additionally include the style suffix when needed.

      if E_Msg.Warn_Err in From_Pragma | From_Run_Time_As_Err then
         Append
           (Buf,
            SGR_Error & "error: " & SGR_Reset &
            (if E_Msg.Kind = Style then Style_Prefix else ""));

      --  Print the message kind prefix
      --  * Info/Style/Warning messages
      --  * Check messages that are not continuations in the pretty printer
      --  * Error messages when error tags are allowed

      elsif E_Msg.Kind in Info | Style | Warning
        or else
        (E_Msg.Kind in High_Check | Medium_Check | Low_Check
         and then not (E_Msg.Msg_Cont and then Debug_Flag_FF))
        or else
        (E_Msg.Kind in Error | Non_Serious_Error
         and then Opt.Unique_Error_Tag)
      then
         Append (Buf, SGR_Code & Kind_Prefix & SGR_Reset);
      end if;

      Append (Buf, Text.all);

      --  Postfix warning tag to message if needed

      if Tag /= "" and then Warning_Doc_Switch then
         Append (Buf, ' ' & Tag);
      end if;

      --  Postfix [warning-as-error] at the end

      if E_Msg.Warn_Err = From_Pragma then
         Append (Buf, " " & Warn_As_Err_Tag);
      end if;

      Output_Text_Within (To_String (Buf), Line_Length);
   end Output_Msg_Text;

   ---------------------
   -- Prescan_Message --
   ---------------------

   procedure Prescan_Message (Msg : String) is
      J : Natural;

      function Parse_Message_Class return String;
      --  Convert the warning insertion sequence to a warning class represented
      --  as a length-two string padded, if necessary, with spaces.
      --  Return the Message class and set the iterator J to the character
      --  following the sequence.
      --  Raise a Program_Error if the insertion sequence is not valid.

      -------------------------
      -- Parse_Message_Class --
      -------------------------

      function Parse_Message_Class return String is
         C : constant Character := Msg (J - 1);
         Message_Class : String (1 .. 2) := "  ";
      begin
         if J <= Msg'Last and then Msg (J) = C then
            Message_Class := "? ";
            J := J + 1;

         elsif J < Msg'Last and then Msg (J + 1) = C
           and then Msg (J) in 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '*' | '$'
         then
            Message_Class := Msg (J) & " ";
            J := J + 2;

         elsif J + 1 < Msg'Last and then Msg (J + 2) = C
           and then Msg (J) in '.' | '_'
           and then Msg (J + 1) in 'a' .. 'z'
         then
            Message_Class := Msg (J .. J + 1);
            J := J + 3;
         elsif (J < Msg'Last and then Msg (J + 1) = C) or else
            (J + 1 < Msg'Last and then Msg (J + 2) = C)
         then
            raise Program_Error;
         end if;

         --  In any other cases, this is not a warning insertion sequence
         --  and the default "  " value is returned.

         return Message_Class;
      end Parse_Message_Class;

   --  Start of processing for Prescan_Message

   begin
      --  Continuation lines need to check only for insertion sequences.
      --  Other attributes should be inherited from the main message.

      if Msg (Msg'First) = '\' then
         Has_Insertion_Line := False;

         J := Msg'First;

         --  If we have a quote, don't look at following character

         while J <= Msg'Last loop
            if Msg (J) = ''' then
               J := J + 2;

            --  Insertion line (# insertion)

            elsif Msg (J) = '#' then
               Has_Insertion_Line := True;
               J := J + 1;
            else
               J := J + 1;
            end if;
         end loop;

         return;

      --  Some global variables are not set for continuation messages, as they
      --  only make sense for the initial message.

      else

         --  Set initial values of globals (may be changed during scan)

         Error_Msg_Kind       := Error;
         Is_Unconditional_Msg := False;
         Is_Runtime_Raise_Msg := False;
         Warning_Msg_Char     := "  ";

         --  Check style message

         if Msg'Length > Style_Prefix'Length
           and then
             Msg (Msg'First .. Msg'First + Style_Prefix'Length - 1) =
             Style_Prefix
         then
            Error_Msg_Kind := Style;

            --  Check info message

         elsif Msg'Length > Info_Prefix'Length
           and then
             Msg (Msg'First .. Msg'First + Info_Prefix'Length - 1) =
             Info_Prefix
         then
            Error_Msg_Kind := Info;

            --  Check high check message

         elsif Msg'Length > High_Prefix'Length
           and then
             Msg (Msg'First .. Msg'First + High_Prefix'Length - 1) =
             High_Prefix
         then
            Error_Msg_Kind := High_Check;

            --  Check medium check message

         elsif Msg'Length > Medium_Prefix'Length
           and then
             Msg (Msg'First .. Msg'First + Medium_Prefix'Length - 1) =
             Medium_Prefix
         then
            Error_Msg_Kind := Medium_Check;

            --  Check low check message

         elsif Msg'Length > Low_Prefix'Length
           and then
             Msg (Msg'First .. Msg'First + Low_Prefix'Length - 1) =
             Low_Prefix
         then
            Error_Msg_Kind := Low_Check;
         end if;
      end if;

      Has_Double_Exclam  := False;
      Has_Error_Code     := False;
      Has_Insertion_Line := False;

      --  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
            if Msg (J) = '?' or else Error_Msg_Warn then

               --  Consider Info and Style messages as unique message types.
               --  Those messages can have warning insertion characters within
               --  them. However they should only be switch specific insertion
               --  characters and not the generic ? or ?? warning insertion
               --  characters.

               if Error_Msg_Kind not in Style | Info then
                  Error_Msg_Kind := Warning;
               end if;

               J := J + 1;
               Warning_Msg_Char := Parse_Message_Class;

               --  Bomb if untagged warning message. This code can be
               --  uncommented for debugging when looking for untagged warning
               --  messages.

               --  pragma Assert (Warning_Msg_Char /= "  ");

            else
               J := J + 1;
            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;

         --  Insertion line (# insertion)

         elsif Msg (J) = '#' then
            Has_Insertion_Line := True;
            J := J + 1;

         --  Non-serious error (| insertion)

         elsif Msg (J) = '|' then
            Error_Msg_Kind := Non_Serious_Error;
            J := J + 1;

         --  Error code ([] insertion)

         elsif Msg (J) = '['
           and then J < Msg'Last
           and then Msg (J + 1) = ']'
         then
            Has_Error_Code := True;
            J := J + 2;

         else
            J := J + 1;
         end if;
      end loop;
   end Prescan_Message;

   --------------------
   -- Purge_Messages --
   --------------------

   procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
      E : Error_Msg_Id;

      function To_Be_Purged (E : Error_Msg_Id) return Boolean;
      --  Returns True for a message that is to be purged. Also adjusts
      --  error counts appropriately.

      ------------------
      -- To_Be_Purged --
      ------------------

      function To_Be_Purged (E : Error_Msg_Id) return Boolean is
      begin
         if E /= No_Error_Msg
           and then Errors.Table (E).Sptr.Ptr > From
           and then Errors.Table (E).Sptr.Ptr < To
         then
            Decrease_Error_Msg_Count (Errors.Table (E));

            return True;

         else
            return False;
         end if;
      end To_Be_Purged;

   --  Start of processing for Purge_Messages

   begin
      while To_Be_Purged (First_Error_Msg) loop
         First_Error_Msg := Errors.Table (First_Error_Msg).Next;
      end loop;

      E := First_Error_Msg;
      while E /= No_Error_Msg loop
         while To_Be_Purged (Errors.Table (E).Next) loop
            Errors.Table (Errors.Table (E).Next).Deleted := True;

            Errors.Table (E).Next :=
              Errors.Table (Errors.Table (E).Next).Next;
         end loop;

         E := Errors.Table (E).Next;
      end loop;
   end Purge_Messages;

   ----------------
   -- Same_Error --
   ----------------

   function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
      Msg1 : constant String_Ptr := Errors.Table (M1).Text;
      Msg2 : constant String_Ptr := Errors.Table (M2).Text;

      Msg2_Len : constant Integer := Msg2'Length;
      Msg1_Len : constant Integer := Msg1'Length;

   begin
      return
        Msg1.all = Msg2.all
          or else
            (Msg1_Len - 10 > Msg2_Len
               and then
             Msg2.all = Msg1.all (1 .. Msg2_Len)
               and then
             Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
          or else
            (Msg2_Len - 10 > Msg1_Len
               and then
             Msg1.all = Msg2.all (1 .. Msg1_Len)
               and then
             Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
   end Same_Error;

   -------------------
   -- Set_Msg_Blank --
   -------------------

   procedure Set_Msg_Blank is
   begin
      if Msglen > 0
        and then Msg_Buffer (Msglen) /= ' '
        and then Msg_Buffer (Msglen) /= '('
        and then Msg_Buffer (Msglen) /= '-'
        and then not Manual_Quote_Mode
      then
         Set_Msg_Char (' ');
      end if;
   end Set_Msg_Blank;

   -------------------------------
   -- Set_Msg_Blank_Conditional --
   -------------------------------

   procedure Set_Msg_Blank_Conditional is
   begin
      if Msglen > 0
        and then Msg_Buffer (Msglen) /= ' '
        and then Msg_Buffer (Msglen) /= '('
        and then Msg_Buffer (Msglen) /= '"'
        and then not Manual_Quote_Mode
      then
         Set_Msg_Char (' ');
      end if;
   end Set_Msg_Blank_Conditional;

   ------------------
   -- Set_Msg_Char --
   ------------------

   procedure Set_Msg_Char (C : Character) is
   begin
      --  The check for message buffer overflow is needed to deal with cases
      --  where insertions get too long (in particular a child unit name can
      --  be very long).

      if Msglen < Max_Msg_Length then
         Msglen := Msglen + 1;
         Msg_Buffer (Msglen) := C;
      end if;
   end Set_Msg_Char;

   ----------------------------
   -- Set_Msg_Insertion_Code --
   ----------------------------

   procedure Set_Msg_Insertion_Code is
      H : constant array (Nat range 0 .. 9) of Character := "0123456789";
      P10 : constant array (Natural range 0 .. 3) of Nat :=
        (10 ** 0,
         10 ** 1,
         10 ** 2,
         10 ** 3);

      Code_Len : constant Natural :=
        (case Error_Msg_Code is
           when    0         => 0,
           when    1 ..    9 => 1,
           when   10 ..   99 => 2,
           when  100 ..  999 => 3,
           when 1000 .. 9999 => 4);
      Code_Rest  : Nat := Error_Msg_Code;
      Code_Digit : Nat;

   begin
      Set_Msg_Char ('E');

      for J in 1 .. Error_Msg_Code_Digits - Code_Len loop
         Set_Msg_Char ('0');
      end loop;

      for J in 1 .. Code_Len loop
         Code_Digit := Code_Rest / P10 (Code_Len - J);
         Set_Msg_Char (H (Code_Digit));
         Code_Rest := Code_Rest - Code_Digit * P10 (Code_Len - J);
      end loop;
   end Set_Msg_Insertion_Code;

   ------------------------------
   -- Set_Msg_Insertion_Column --
   ------------------------------

   procedure Set_Msg_Insertion_Column is
   begin
      if RM_Column_Check then
         Set_Msg_Str (" in column ");
         Set_Msg_Int (Int (Error_Msg_Col) + 1);
      end if;
   end Set_Msg_Insertion_Column;

   ---------------------------------
   -- Set_Msg_Insertion_File_Name --
   ---------------------------------

   procedure Set_Msg_Insertion_File_Name is
   begin
      if Error_Msg_File_1 = No_File then
         null;

      elsif Error_Msg_File_1 = Error_File_Name then
         Set_Msg_Blank;
         Set_Msg_Str ("<error>");

      else
         Set_Msg_Blank;
         Get_Name_String (Error_Msg_File_1);
         Set_Msg_Quote;
         Set_Msg_Name_Buffer;
         Set_Msg_Quote;
      end if;

      --  The following assignments ensure that the second and third {
      --  insertion characters will correspond to the Error_Msg_File_2
      --  and Error_Msg_File_3 values.

      Error_Msg_File_1 := Error_Msg_File_2;
      Error_Msg_File_2 := Error_Msg_File_3;
   end Set_Msg_Insertion_File_Name;

   -----------------------------------
   -- Set_Msg_Insertion_Line_Number --
   -----------------------------------

   procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
      Sindex_Loc  : Source_File_Index;
      Sindex_Flag : Source_File_Index;
      Fname       : File_Name_Type;
      Int_File    : Boolean;

      procedure Set_At;
      --  Outputs "at " unless last characters in buffer are " from ". Certain
      --  messages read better with from than at.

      ------------
      -- Set_At --
      ------------

      procedure Set_At is
      begin
         if Msglen < 6
           or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
         then
            Set_Msg_Str ("at ");
         end if;
      end Set_At;

   --  Start of processing for Set_Msg_Insertion_Line_Number

   begin
      Set_Msg_Blank;

      if Loc = No_Location then
         Set_At;
         Set_Msg_Str ("unknown location");

      elsif Loc = System_Location then
         Set_Msg_Str ("in package System");
         Set_Msg_Insertion_Run_Time_Name;

      elsif Loc = Standard_Location then
         Set_Msg_Str ("in package Standard");

      elsif Loc = Standard_ASCII_Location then
         Set_Msg_Str ("in package Standard.ASCII");

      else
         --  Add "at file-name:" if reference is to other than the source
         --  file in which the error message is placed. Note that we check
         --  full file names, rather than just the source indexes, to
         --  deal with generic instantiations from the current file.

         Sindex_Loc  := Get_Source_File_Index (Loc);
         Sindex_Flag := Get_Source_File_Index (Flag);

         if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
            Set_At;
            Fname := Reference_Name (Get_Source_File_Index (Loc));
            Int_File := Is_Internal_File_Name (Fname);
            Get_Name_String (Fname);
            Set_Msg_Name_Buffer;

            if not (Int_File and Debug_Flag_Dot_K) then
               Set_Msg_Char (':');
               Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
            end if;

         --  If in current file, add text "at line "

         else
            Set_At;
            Set_Msg_Str ("line ");
            Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
         end if;

         --  Deal with the instantiation case. We may have a reference to,
         --  e.g. a type, that is declared within a generic template, and
         --  what we are really referring to is the occurrence in an instance.
         --  In this case, the line number of the instantiation is also of
         --  interest, and we add a notation:

         --    , instance at xxx

         --  where xxx is a line number output using this same routine (and
         --  the recursion can go further if the instantiation is itself in
         --  a generic template).

         --  The flag location passed to us in this situation is indeed the
         --  line number within the template, but as described in Sinput.L
         --  (file sinput-l.ads, section "Handling Generic Instantiations")
         --  we can retrieve the location of the instantiation itself from
         --  this flag location value.

         --  Note: this processing is suppressed if Suppress_Instance_Location
         --  is set True. This is used to prevent redundant annotations of the
         --  location of the instantiation in the case where we are placing
         --  the messages on the instantiation in any case.

         if Instantiation (Sindex_Loc) /= No_Location
           and then not Suppress_Instance_Location
         then
            Set_Msg_Str (", instance ");
            Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
         end if;
      end if;
   end Set_Msg_Insertion_Line_Number;

   ----------------------------
   -- Set_Msg_Insertion_Name --
   ----------------------------

   procedure Set_Msg_Insertion_Name is
      procedure Replace_With_Attribute_Definition;
      --  This procedure handles direct attribute definition names of the form:
      --    'D' Prefix_Name "_" Attribute_Name "_Att"
      --  Specifically, it replace the current Namet.Global_Name_Buffer with an
      --  all lowercase string of the prefix, and a tick attribute; at this
      --  stage there is no way to recognize more than an ending attribute ???
      --
      --  Note that, at this point, it is not possible to restore the original
      --  casing thus lowercase is default.a

      procedure Replace_With_Attribute_Definition is
         First   : constant Integer := 2;
         Last    : constant Integer := Name_Len - 4;
         Att_Buf : Bounded_String (Max_Length => Name_Len - 7);
      begin
         Until_Tick :
         for J in First .. Last loop

            --  J could be at the position separating the prefix from the
            --  attribute name.

            if Name_Buffer (J) = '_' then
               Att_Buf.Length := 0;
               Append (Att_Buf, Name_Buffer (J + 1 .. Last));
               Set_Casing (Att_Buf, All_Lower_Case);
               if Is_Direct_Attribute_Definition_Name (Name_Find (Att_Buf))
               then
                  Name_Buffer (J) := ''';
                  exit Until_Tick;
               end if;
            end if;
         end loop Until_Tick;

         --  Remove prefix 'D' and suffix "_Att"

         Name_Buffer (1 .. Last - 1) := Name_Buffer (2 .. Last);
         Name_Len := Last - 1;
         Set_Casing (All_Lower_Case);
      end Replace_With_Attribute_Definition;

   begin
      if Error_Msg_Name_1 = No_Name then
         null;

      elsif Error_Msg_Name_1 = Error_Name then
         Set_Msg_Blank;
         Set_Msg_Str ("<error>");

      else
         Set_Msg_Blank_Conditional;
         Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);

         --  Remove %s or %b at end. These come from unit names. If the
         --  caller wanted the (unit) or (body), then they would have used
         --  the $ insertion character. Certainly no error message should
         --  ever have %b or %s explicitly occurring.

         if Name_Len > 2
           and then Name_Buffer (Name_Len - 1) = '%'
           and then (Name_Buffer (Name_Len) = 'b'
                       or else
                     Name_Buffer (Name_Len) = 's')
         then
            Name_Len := Name_Len - 2;
         end if;

         --  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
            Name_Len := Name_Len - 1;
         end if;

         --  If operator name or character literal name, just print it as is.
         --  Also print as is if it ends in a right paren (case of x'val(nnn)).

         if Name_Buffer (1) = '"'
           or else Name_Buffer (1) = '''
           or else Name_Buffer (Name_Len) = ')'
         then
            Set_Msg_Name_Buffer;

         --  Else output with surrounding quotes in proper casing mode

         else
            if Name_Buffer (1) = 'D'
              and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att"
            then
               Replace_With_Attribute_Definition;
            else
               Set_Casing (Identifier_Casing (Flag_Source));
            end if;

            Set_Msg_Quote;
            Set_Msg_Name_Buffer;
            Set_Msg_Quote;
         end if;
      end if;

      --  The following assignments ensure that other percent insertion
      --  characters will correspond to their appropriate Error_Msg_Name_#
      --  values as required.

      Error_Msg_Name_1 := Error_Msg_Name_2;
      Error_Msg_Name_2 := Error_Msg_Name_3;
      Error_Msg_Name_3 := Error_Msg_Name_4;
      Error_Msg_Name_4 := Error_Msg_Name_5;
      Error_Msg_Name_5 := Error_Msg_Name_6;
   end Set_Msg_Insertion_Name;

   ------------------------------------
   -- Set_Msg_Insertion_Name_Literal --
   ------------------------------------

   procedure Set_Msg_Insertion_Name_Literal is
   begin
      if Error_Msg_Name_1 = No_Name then
         null;

      elsif Error_Msg_Name_1 = Error_Name then
         Set_Msg_Blank;
         Set_Msg_Str ("<error>");

      else
         Set_Msg_Blank;
         Get_Name_String (Error_Msg_Name_1);
         Set_Msg_Quote;
         Set_Msg_Name_Buffer;
         Set_Msg_Quote;
      end if;

      --  The following assignments ensure that other percent insertion
      --  characters will correspond to their appropriate Error_Msg_Name_#
      --  values as required.

      Error_Msg_Name_1 := Error_Msg_Name_2;
      Error_Msg_Name_2 := Error_Msg_Name_3;
      Error_Msg_Name_3 := Error_Msg_Name_4;
      Error_Msg_Name_4 := Error_Msg_Name_5;
      Error_Msg_Name_5 := Error_Msg_Name_6;
   end Set_Msg_Insertion_Name_Literal;

   -------------------------------------
   -- Set_Msg_Insertion_Reserved_Name --
   -------------------------------------

   procedure Set_Msg_Insertion_Reserved_Name is
   begin
      Set_Msg_Blank_Conditional;
      Get_Name_String (Error_Msg_Name_1);
      Set_Msg_Quote;
      Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
      Set_Msg_Name_Buffer;
      Set_Msg_Quote;
   end Set_Msg_Insertion_Reserved_Name;

   -------------------------------------
   -- Set_Msg_Insertion_Reserved_Word --
   -------------------------------------

   procedure Set_Msg_Insertion_Reserved_Word
     (Text : String;
      J    : in out Integer)
   is
   begin
      Set_Msg_Blank_Conditional;
      Name_Len := 0;

      while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
         Add_Char_To_Name_Buffer (Text (J));
         J := J + 1;
      end loop;

      --  Here is where we make the special exception for RM

      if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
         Set_Msg_Name_Buffer;

      --  We make a similar exception for CUDA

      elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "CUDA" then
         Set_Msg_Name_Buffer;

      --  We make a similar exception for SPARK

      elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
         Set_Msg_Name_Buffer;

      --  Otherwise, case appropriately and add surrounding quotes

      else
         Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
         Set_Msg_Quote;
         Set_Msg_Name_Buffer;
         Set_Msg_Quote;
      end if;
   end Set_Msg_Insertion_Reserved_Word;

   -------------------------------------
   -- Set_Msg_Insertion_Run_Time_Name --
   -------------------------------------

   procedure Set_Msg_Insertion_Run_Time_Name is
   begin
      if Targparm.Run_Time_Name_On_Target /= No_Name then
         Set_Msg_Blank_Conditional;
         Set_Msg_Char ('(');
         Get_Name_String (Targparm.Run_Time_Name_On_Target);
         Set_Casing (Mixed_Case);
         Set_Msg_Str (Name_Buffer (1 .. Name_Len));
         Set_Msg_Char (')');
      end if;
   end Set_Msg_Insertion_Run_Time_Name;

   ----------------------------
   -- Set_Msg_Insertion_Uint --
   ----------------------------

   procedure Set_Msg_Insertion_Uint is
   begin
      Set_Msg_Blank;
      UI_Image (Error_Msg_Uint_1);

      for J in 1 .. UI_Image_Length loop
         Set_Msg_Char (UI_Image_Buffer (J));
      end loop;

      --  The following assignment ensures that a second caret insertion
      --  character will correspond to the Error_Msg_Uint_2 parameter.

      Error_Msg_Uint_1 := Error_Msg_Uint_2;
   end Set_Msg_Insertion_Uint;

   -----------------
   -- Set_Msg_Int --
   -----------------

   procedure Set_Msg_Int (Line : Int) is
   begin
      if Line > 9 then
         Set_Msg_Int (Line / 10);
      end if;

      Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
   end Set_Msg_Int;

   -------------------------
   -- Set_Msg_Name_Buffer --
   -------------------------

   procedure Set_Msg_Name_Buffer is
   begin
      Set_Msg_Str (Name_Buffer (1 .. Name_Len));
      Destroy_Global_Name_Buffer;
   end Set_Msg_Name_Buffer;

   -------------------
   -- Set_Msg_Quote --
   -------------------

   procedure Set_Msg_Quote is
   begin
      if not Manual_Quote_Mode then
         Set_Msg_Char ('"');
      end if;
   end Set_Msg_Quote;

   -----------------
   -- Set_Msg_Str --
   -----------------

   procedure Set_Msg_Str (Text : String) is
   begin
      --  Do replacement for special x'Class aspect names

      if Text = "_Pre" then
         Set_Msg_Str ("Pre'Class");

      elsif Text = "_Post" then
         Set_Msg_Str ("Post'Class");

      elsif Text = "_Type_Invariant" then
         Set_Msg_Str ("Type_Invariant'Class");

      elsif Text = "_pre" then
         Set_Msg_Str ("pre'class");

      elsif Text = "_post" then
         Set_Msg_Str ("post'class");

      elsif Text = "_type_invariant" then
         Set_Msg_Str ("type_invariant'class");

      elsif Text = "_PRE" then
         Set_Msg_Str ("PRE'CLASS");

      elsif Text = "_POST" then
         Set_Msg_Str ("POST'CLASS");

      elsif Text = "_TYPE_INVARIANT" then
         Set_Msg_Str ("TYPE_INVARIANT'CLASS");

      --  Preserve casing for names that include acronyms

      elsif Text = "Cpp_Class" then
         Set_Msg_Str ("CPP_Class");

      elsif Text = "Cpp_Constructor" then
         Set_Msg_Str ("CPP_Constructor");

      elsif Text = "Cpp_Virtual" then
         Set_Msg_Str ("CPP_Virtual");

      elsif Text = "Cpp_Vtable" then
         Set_Msg_Str ("CPP_Vtable");

      elsif Text = "Cuda_Device" then
         Set_Msg_Str ("CUDA_Device");

      elsif Text = "Cuda_Global" then
         Set_Msg_Str ("CUDA_Global");

      elsif Text = "Persistent_Bss" then
         Set_Msg_Str ("Persistent_BSS");

      elsif Text = "Spark_Mode" then
         Set_Msg_Str ("SPARK_Mode");

      elsif Text = "Use_Vads_Size" then
         Set_Msg_Str ("Use_VADS_Size");

      elsif Text = "Vads_Size" then
         Set_Msg_Str ("VADS_size");

      --  Normal case with no replacement

      else
         for J in Text'Range loop
            Set_Msg_Char (Text (J));
         end loop;
      end if;
   end Set_Msg_Str;

   ------------------------------
   -- Set_Next_Non_Deleted_Msg --
   ------------------------------

   procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
   begin
      if E = No_Error_Msg then
         return;

      else
         loop
            E := Errors.Table (E).Next;
            exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
         end loop;
      end if;
   end Set_Next_Non_Deleted_Msg;

   ------------------------------
   -- Set_Specific_Warning_Off --
   ------------------------------

   procedure Set_Specific_Warning_Off
     (Node   : Node_Id;
      Msg    : String;
      Reason : String_Id;
      Config : Boolean;
      Used   : Boolean := False)
   is
      Loc : constant Source_Ptr := Sinfo.Nodes.Sloc (Node);
   begin
      Specific_Warnings.Append
        ((Start      => Loc,
          Msg        => new String'(Msg),
          Stop       => Source_Last (Get_Source_File_Index (Loc)),
          Reason     => Reason,
          Open       => True,
          Used       => Used,
          Config     => Config));
   end Set_Specific_Warning_Off;

   -----------------------------
   -- Set_Specific_Warning_On --
   -----------------------------

   procedure Set_Specific_Warning_On
     (Loc : Source_Ptr;
      Msg : String;
      Err : out Boolean)
   is
   begin
      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
              and then SWE.Open
              and then Get_Source_File_Index (SWE.Start) =
                       Get_Source_File_Index (Loc)
            then
               SWE.Stop := Loc;
               SWE.Open := False;
               Err := False;

               --  If a config pragma is specifically cancelled, consider
               --  that it is no longer active as a configuration pragma.

               SWE.Config := False;
               return;
            end if;
         end;
      end loop;

      Err := True;
   end Set_Specific_Warning_On;

   ---------------------------
   -- Set_Warnings_Mode_Off --
   ---------------------------

   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
   begin
      --  Don't bother with entries from instantiation copies, since we will
      --  already have a copy in the template, which is what matters.

      if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
         return;
      end if;

      --  If all warnings are suppressed by command line switch, this can
      --  be ignored, unless we are in GNATprove_Mode which requires pragma
      --  Warnings to be stored for the formal verification backend.

      if Warning_Mode = Suppress
        and then not GNATprove_Mode
      then
         return;
      end if;

      --  If last entry in table already covers us, this is a redundant pragma
      --  Warnings (Off) and can be ignored.

      if Warnings.Last >= Warnings.First
        and then Warnings.Table (Warnings.Last).Start <= Loc
        and then Loc <= Warnings.Table (Warnings.Last).Stop
      then
         return;
      end if;

      --  If none of those special conditions holds, establish a new entry,
      --  extending from the location of the pragma to the end of the current
      --  source file. This ending point will be adjusted by a subsequent
      --  corresponding pragma Warnings (On).

      Warnings.Append
        ((Start  => Loc,
          Stop   => Source_Last (Get_Source_File_Index (Loc)),
          Reason => Reason));
   end Set_Warnings_Mode_Off;

   --------------------------
   -- Set_Warnings_Mode_On --
   --------------------------

   procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
   begin
      --  Don't bother with entries from instantiation copies, since we will
      --  already have a copy in the template, which is what matters.

      if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
         return;
      end if;

      --  If all warnings are suppressed by command line switch, this can
      --  be ignored, unless we are in GNATprove_Mode which requires pragma
      --  Warnings to be stored for the formal verification backend.

      if Warning_Mode = Suppress
        and then not GNATprove_Mode
      then
         return;
      end if;

      --  If the last entry in the warnings table covers this pragma, then
      --  we adjust the end point appropriately.

      if Warnings.Last >= Warnings.First
        and then Warnings.Table (Warnings.Last).Start <= Loc
        and then Loc <= Warnings.Table (Warnings.Last).Stop
      then
         Warnings.Table (Warnings.Last).Stop := Loc;
      end if;
   end Set_Warnings_Mode_On;

   -------------------
   -- Sloc_In_Range --
   -------------------

   function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean is
      Cur_Loc : Source_Ptr := Loc;

   begin
      while Cur_Loc /= No_Location loop
         if Start <= Cur_Loc and then Cur_Loc <= Stop then
            return True;
         end if;

         Cur_Loc := Instantiation_Location (Cur_Loc);
      end loop;

      return False;
   end Sloc_In_Range;

   -------------------------------------
   -- Warning_Specifically_Suppressed --
   -------------------------------------

   function Warning_Specifically_Suppressed
     (Loc : Source_Ptr;
      Msg : String_Ptr;
      Tag : String := "") return String_Id
   is
   begin
      --  Loop through specific warning suppression entries

      for J in Specific_Warnings.First .. Specific_Warnings.Last loop
         declare
            SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
         begin
            --  Pragma applies if it is a configuration pragma, or if the
            --  location is in range of a specific non-configuration pragma.

            if SWE.Config
              or else Sloc_In_Range (Loc, SWE.Start, SWE.Stop)
            then
               if Matches (Msg.all, SWE.Msg.all)
                 or else Matches (Tag, SWE.Msg.all)
               then
                  SWE.Used := True;
                  return SWE.Reason;
               end if;
            end if;
         end;
      end loop;

      return No_String;
   end Warning_Specifically_Suppressed;

   ------------------------------
   -- Warning_Treated_As_Error --
   ------------------------------

   function Warning_Treated_As_Error (Msg : String) return Boolean is
   begin
      for J in 1 .. Warnings_As_Errors_Count loop
         if Matches (Msg, Warnings_As_Errors (J).all) then
            return True;
         end if;
      end loop;

      return False;
   end Warning_Treated_As_Error;

   function Warning_Treated_As_Error (E : Error_Msg_Object) return Boolean is

   begin
      return
        Warning_Treated_As_Error (E.Text.all)
        or else Warning_Treated_As_Error (Get_Warning_Tag (E));
   end Warning_Treated_As_Error;

   -------------------------
   -- Warnings_Suppressed --
   -------------------------

   function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
   begin
      --  Loop through table of ON/OFF warnings

      for J in Warnings.First .. Warnings.Last loop
         if Sloc_In_Range (Loc, Warnings.Table (J).Start,
                                Warnings.Table (J).Stop)
         then
            return Warnings.Table (J).Reason;
         end if;
      end loop;

      if Warning_Mode = Suppress then
         return Null_String_Id;
      else
         return No_String;
      end if;
   end Warnings_Suppressed;

   -------------------------
   -- Write_Error_Summary --
   -------------------------

   procedure Write_Error_Summary is
   begin
      --  Extra blank line if error messages or source listing were output

      if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List
      then
         Write_Eol;
      end if;

      --  Message giving number of lines read and number of errors detected.
      --  This normally goes to Standard_Output. The exception is when brief
      --  mode is not set, verbose mode (or full list mode) is set, and
      --  there are errors. In this case we send the message to standard
      --  error to make sure that *something* appears on standard error
      --  in an error situation.

      if Total_Errors_Detected + Warnings_Detected /= 0
         and then not Brief_Output
         and then (Verbose_Mode or Full_List)
      then
         Set_Standard_Error;
      end if;

      --  Message giving total number of lines. Don't give this message if
      --  the Main_Source line is unknown (this happens in error situations,
      --  e.g. when integrated preprocessing fails).

      if Main_Source_File > No_Source_File then
         Write_Str (" ");
         Write_Int (Num_Source_Lines (Main_Source_File));

         if Num_Source_Lines (Main_Source_File) = 1 then
            Write_Str (" line: ");
         else
            Write_Str (" lines: ");
         end if;
      end if;

      if Total_Errors_Detected = 0 then
         Write_Str ("No errors");

      elsif Total_Errors_Detected = 1 then
         Write_Str ("1 error");

      else
         Write_Int (Total_Errors_Detected);
         Write_Str (" errors");
      end if;

      if Warnings_Detected > 0 then
         Write_Str (", ");
         Write_Int (Warnings_Detected);
         Write_Str (" warning");

         if Warnings_Detected > 1 then
            Write_Char ('s');
         end if;

         if Warnings_Treated_As_Errors > 0 then
            Write_Str (" (");

            if Warnings_Treated_As_Errors /= Warnings_Detected then
               Write_Int (Warnings_Treated_As_Errors);
               Write_Str (" ");
            end if;

            Write_Str ("treated as error");

            if Warnings_Treated_As_Errors > 1 then
               Write_Str ("s");
            end if;

            Write_Str (")");
         end if;
      end if;

      if Info_Messages /= 0 then
         Write_Str (", ");
         Write_Int (Info_Messages);
         Write_Str (" info message");

         if Info_Messages > 1 then
            Write_Char ('s');
         end if;
      end if;

      Write_Eol;
      Set_Standard_Output;
   end Write_Error_Summary;

end Erroutc;