URL https://opencores.org/ocsvn/scarts/scarts/trunk
Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [erroutc.adb] - Blame information for rev 12

Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         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;
      Name_Len := 0;
 
      while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := Text (J);
         J := J + 1;
      end loop;
 
      Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
      Set_Msg_Quote;
      Set_Msg_Name_Buffer;
      Set_Msg_Quote;
   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 carret 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
      for J in 1 .. Name_Len loop
         Set_Msg_Char (Name_Buffer (J));
      end loop;
   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
      for J in Text'Range loop
         Set_Msg_Char (Text (J));
      end loop;
   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_Warnings_Mode_Off --
   ---------------------------
 
   procedure Set_Warnings_Mode_Off (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 last entry in table already covers us, this is a redundant
      --  pragma Warnings (Off) and can be ignored. This also handles the
      --  case where all warnings are suppressed by command line switch.
 
      if Warnings.Last >= Warnings.First
        and then Warnings.Table (Warnings.Last).Start <= Loc
        and then Loc <= Warnings.Table (Warnings.Last).Stop
      then
         return;
 
      --  Otherwise 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 pragma Warnings (On).
 
      else
         Warnings.Increment_Last;
         Warnings.Table (Warnings.Last).Start := Loc;
         Warnings.Table (Warnings.Last).Stop :=
           Source_Last (Current_Source_File);
      end if;
   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;
 
      --  Nothing to do unless command line switch to suppress all warnings
      --  is off, and the last entry in the warnings table covers this
      --  pragma Warnings (On), in which case adjust the end point.
 
      if (Warnings.Last >= Warnings.First
           and then Warnings.Table (Warnings.Last).Start <= Loc
           and then Loc <= Warnings.Table (Warnings.Last).Stop)
        and then Warning_Mode /= Suppress
      then
         Warnings.Table (Warnings.Last).Stop := Loc;
      end if;
   end Set_Warnings_Mode_On;
 
   ------------------------------------
   -- Test_Style_Warning_Serious_Msg --
   ------------------------------------
 
   procedure Test_Style_Warning_Serious_Msg (Msg : String) is
   begin
      if Msg (Msg'First) = '\' then
         return;
      end if;
 
      Is_Serious_Error := True;
      Is_Warning_Msg   := 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;
 
         elsif Msg (J) = '<'
           and then (J = Msg'First or else Msg (J - 1) /= ''')
         then
            Is_Warning_Msg := Error_Msg_Warn;
 
         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 else Is_Style_Msg then
         Is_Serious_Error := False;
      end if;
   end Test_Style_Warning_Serious_Msg;
 
   -------------------------
   -- Warnings_Suppressed --
   -------------------------
 
   function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
   begin
      for J in Warnings.First .. Warnings.Last loop
         if Warnings.Table (J).Start <= Loc
           and then Loc <= Warnings.Table (J).Stop
         then
            return True;
         end if;
      end loop;
 
      return False;
   end Warnings_Suppressed;
 
end Erroutc;
Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [erroutc.adb] - Blame information for rev 12

Line No.	Rev	Author	Line
1	12	jlechner	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- E R R O U T C --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 2, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING. If not, write --`
19			`-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --`
20			`-- Boston, MA 02110-1301, USA. --`
21			`-- --`
22			`-- GNAT was originally developed by the GNAT team at New York University. --`
23			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
24			`-- --`
25			`------------------------------------------------------------------------------`
26
27			`-- Warning! Error messages can be generated during Gigi processing by direct`
28			`-- calls to error message routines, so it is essential that the processing`
29			`-- in this body be consistent with the requirements for the Gigi processing`
30			`-- environment, and that in particular, no disallowed table expansion is`
31			`-- allowed to occur.`
32
33			`with Casing; use Casing;`
34			`with Debug; use Debug;`
35			`with Err_Vars; use Err_Vars;`
36			`with Namet; use Namet;`
37			`with Opt; use Opt;`
38			`with Output; use Output;`
39			`with Sinput; use Sinput;`
40			`with Snames; use Snames;`