Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E R R O U T C                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, 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 2,  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 COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

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

with Debug;    use Debug;

with Err_Vars; use Err_Vars;

with Namet;    use Namet;

with Opt;      use Opt;

with Output;   use Output;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Targparm; use Targparm;

with Table;

with Uintp;    use Uintp;

package body Erroutc is

   -----------------------

   -- Local Subprograms --

   -----------------------

   ---------------

   -- 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), Mixed_Case);

         Set_Msg_Name_Buffer;

      end if;

   end Add_Class;

   ----------------------

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

      --  all messages of Delete with deleted flag set to True, and 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;

            --  Adjust error message count

            if Errors.Table (D).Warn or Errors.Table (D).Style then

               Warnings_Detected := Warnings_Detected - 1;

            else

               Total_Errors_Detected := Total_Errors_Detected - 1;

               if Errors.Table (D).Serious then

                  Serious_Errors_Detected := Serious_Errors_Detected - 1;

               end if;

            end if;

            --  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 continuatins 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_Detected /= 0

                  and then Warning_Mode = Treat_As_Error);

   end Compilation_Errors;

   ------------------

   -- 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 ("  Sfile    = ", Int (E.Sfile));

      Write_Str

        ("  Sptr     = ");

      Write_Location (E.Sptr);

      Write_Eol;

      Write_Str

        ("  Optr     = ");

      Write_Location (E.Optr);

      Write_Eol;

      w ("  Line     = ", Int (E.Line));

      w ("  Col      = ", Int (E.Col));

      w ("  Warn     = ", E.Warn);

      w ("  Style    = ", E.Style);

      w ("  Serious  = ", E.Serious);

      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;

   end Get_Location;

   ----------------

   -- Get_Msg_Id --

   ----------------

   function Get_Msg_Id return Error_Msg_Id is

   begin

      return Cur_Msg;

   end Get_Msg_Id;

   -----------------------

   -- 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 > Errors.Table (E).Sptr 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);

         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

            --  Loop to output blanks till current flag position

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

               if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then

                  Write_Char (ASCII.HT);

               else

                  Write_Char (' ');

               end if;

               P := P + 1;

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

               P := P + 1;

            end if;

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

   ---------------------

   procedure Output_Msg_Text (E : Error_Msg_Id) is

   begin

      if Errors.Table (E).Warn then

         Write_Str ("warning: ");

      elsif Errors.Table (E).Style then

         null;

      elsif Opt.Unique_Error_Tag then

         Write_Str ("error: ");

      end if;

      Write_Str (Errors.Table (E).Text.all);

   end Output_Msg_Text;

   --------------------

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

           and then Errors.Table (E).Sptr < To

         then

            if Errors.Table (E).Warn or Errors.Table (E).Style then

               Warnings_Detected := Warnings_Detected - 1;

            else

               Total_Errors_Detected := Total_Errors_Detected - 1;

               if Errors.Table (E).Serious then

                  Serious_Errors_Detected := Serious_Errors_Detected - 1;

               end if;

            end if;

            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 (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 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_File_Name --

   ---------------------------------

   procedure Set_Msg_Insertion_File_Name 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 the second and third percent

      --  insertion characters will correspond to the Error_Msg_Name_2 and

      --  Error_Msg_Name_3 as required.

      Error_Msg_Name_1 := Error_Msg_Name_2;

      Error_Msg_Name_2 := Error_Msg_Name_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;

   begin

      Set_Msg_Blank;

      if Loc = No_Location then

         Set_Msg_Str ("at 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_Msg_Str ("at ");

            Get_Name_String

              (Reference_Name (Get_Source_File_Index (Loc)));

            Set_Msg_Name_Buffer;

            Set_Msg_Char (':');

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

         else

            Set_Msg_Str ("at line ");

         end if;

         --  Output line number for reference

         Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));

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

   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

            Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);

            Set_Msg_Quote;

            Set_Msg_Name_Buffer;

            Set_Msg_Quote;

         end if;

      end if;

      --  The following assignments ensure that the second and third percent

      --  insertion characters will correspond to the Error_Msg_Name_2 and

      --  Error_Msg_Name_3 as required.

      Error_Msg_Name_1 := Error_Msg_Name_2;

      Error_Msg_Name_2 := Error_Msg_Name_3;

   end Set_Msg_Insertion_Name;

   -------------------------------------

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