1016 lines
30 KiB
Ada
1016 lines
30 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E R R O U T C --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2004 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, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, 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 Types; use Types;
|
|
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_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;
|