with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Fname; use Fname;
with Hostparm;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Scans; use Scans;
with Sinput; use Sinput;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Style;
with Uintp; use Uintp;
with Uname; use Uname;
package body Errout is
Class_Flag : Boolean := False;
Continuation : Boolean;
Cur_Msg : Error_Msg_Id;
Flag_Source : Source_File_Index;
Is_Warning_Msg : Boolean;
Is_Unconditional_Msg : Boolean;
Kill_Message : Boolean;
Last_Killed : Boolean := False;
List_Pragmas_Index : Int;
List_Pragmas_Mode : Boolean;
Manual_Quote_Mode : Boolean;
Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length;
Msg_Buffer : String (1 .. Max_Msg_Length);
Msglen : Integer;
Suppress_Message : Boolean;
Suppress_Instance_Location : Boolean := False;
type Error_Msg_Object is record
Text : String_Ptr;
Next : Error_Msg_Id;
Sfile : Source_File_Index;
Sptr : Source_Ptr;
Fptr : Source_Ptr;
Line : Physical_Line_Number;
Col : Column_Number;
Warn : Boolean;
Uncond : Boolean;
Msg_Cont : Boolean;
Deleted : Boolean;
end record;
package Errors is new Table.Table (
Table_Component_Type => Error_Msg_Object,
Table_Index_Type => Error_Msg_Id,
Table_Low_Bound => 1,
Table_Initial => 200,
Table_Increment => 200,
Table_Name => "Error");
Error_Msgs : Error_Msg_Id;
type Warnings_Entry is record
Start : Source_Ptr;
Stop : Source_Ptr;
end record;
package Warnings is new Table.Table (
Table_Component_Type => Warnings_Entry,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Warnings");
procedure Add_Class;
function Buffer_Ends_With (S : String) return Boolean;
procedure Buffer_Remove (S : String);
procedure Debug_Output (N : Node_Id);
procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
procedure Error_Msg_Internal
(Msg : String;
Flag_Location : Source_Ptr;
Msg_Cont : Boolean);
procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id);
function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
function OK_Node (N : Node_Id) return Boolean;
procedure Output_Error_Msgs (E : in out Error_Msg_Id);
procedure Output_Line_Number (L : Logical_Line_Number);
procedure Output_Msg_Text (E : Error_Msg_Id);
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
Errs : Boolean);
function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
procedure Set_Msg_Blank;
procedure Set_Msg_Blank_Conditional;
procedure Set_Msg_Char (C : Character);
procedure Set_Msg_Insertion_Column;
procedure Set_Msg_Insertion_Name;
procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr);
procedure Set_Msg_Insertion_Node;
procedure Set_Msg_Insertion_Reserved_Name;
procedure Set_Msg_Insertion_Reserved_Word
(Text : String;
J : in out Integer);
procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
procedure Set_Msg_Insertion_Uint;
procedure Set_Msg_Insertion_Unit_Name;
procedure Set_Msg_Insertion_File_Name;
procedure Set_Msg_Int (Line : Int);
procedure Set_Msg_Name_Buffer;
procedure Set_Msg_Node (Node : Node_Id);
procedure Set_Msg_Quote;
procedure Set_Msg_Str (Text : String);
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
procedure Set_Posted (N : Node_Id);
procedure Set_Qualification (N : Nat; E : Entity_Id);
procedure Test_Warning_Msg (Msg : String);
procedure Unwind_Internal_Type (Ent : in out Entity_Id);
function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
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;
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;
procedure Buffer_Remove (S : String) is
begin
if Buffer_Ends_With (S) then
Msglen := Msglen - S'Length;
end if;
end Buffer_Remove;
procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is
Save_Next : Error_Msg_Id;
Err_Id : Error_Msg_Id := Error_Id;
begin
Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
if Debug_Flag_OO then
Save_Next := Errors.Table (Error_Id).Next;
Errors.Table (Error_Id).Next := No_Error_Msg;
Write_Eol;
Output_Source_Line
(Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
Output_Error_Msgs (Err_Id);
Errors.Table (Error_Id).Next := Save_Next;
end if;
end Change_Error_Text;
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);
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;
if Errors.Table (D).Warn then
Warnings_Detected := Warnings_Detected - 1;
else
Errors_Detected := Errors_Detected - 1;
end if;
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;
begin
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;
if not Same_Error (M1, M2) then
return;
end if;
L1 := M1;
L2 := M2;
loop
N1 := Errors.Table (L1).Next;
N2 := Errors.Table (L2).Next;
if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
Delete_Msg (M1, M2);
return;
elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
Delete_Msg (M2, M1);
return;
elsif not Same_Error (N1, N2) then
return;
else
L1 := N1;
L2 := N2;
end if;
end loop;
end Check_Duplicate_Message;
function Compilation_Errors return Boolean is
begin
return Errors_Detected /= 0
or else (Warnings_Detected /= 0
and then Warning_Mode = Treat_As_Error);
end Compilation_Errors;
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;
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
(" Fptr = ");
Write_Location (E.Fptr);
Write_Eol;
w (" Line = ", Int (E.Line));
w (" Col = ", Int (E.Col));
w (" Warn = ", E.Warn);
w (" Uncond = ", E.Uncond);
w (" Msg_Cont = ", E.Msg_Cont);
w (" Deleted = ", E.Deleted);
Write_Eol;
end dmsg;
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
Sindex : Source_File_Index;
Orig_Loc : Source_Ptr;
begin
if Flag_Location < First_Source_Ptr
and then Errors_Detected > 0
then
return;
end if;
Sindex := Get_Source_File_Index (Flag_Location);
Test_Warning_Msg (Msg);
pragma Assert (Source /= Internal_Source_Ptr);
Orig_Loc := Original_Location (Flag_Location);
if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
return;
end if;
if Instantiation (Sindex) = No_Location then
Error_Msg_Internal (Msg, Flag_Location, False);
return;
end if;
if (not Warn_On_Instance) and then Is_Warning_Msg then
Error_Msg_Internal (Msg, Flag_Location, False);
return;
end if;
for Err in Errors.First .. Errors.Last loop
if Errors.Table (Err).Sptr = Orig_Loc then
if Is_Warning_Msg
or else not Errors.Table (Err).Warn
then
return;
end if;
end if;
end loop;
declare
Actual_Error_Loc : Source_Ptr;
Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
X : Source_File_Index;
Msg_Cont_Status : Boolean;
begin
X := Sindex;
loop
Actual_Error_Loc := Instantiation (X);
X := Get_Source_File_Index (Actual_Error_Loc);
exit when Instantiation (X) = No_Location;
end loop;
Suppress_Instance_Location := True;
Msg_Cont_Status := False;
Error_Msg_Sloc := Flag_Location;
X := Get_Source_File_Index (Flag_Location);
while Instantiation (X) /= No_Location loop
if Msg (1) /= '\' then
if Is_Warning_Msg then
Error_Msg_Internal
("?in instantiation #",
Actual_Error_Loc, Msg_Cont_Status);
else
Error_Msg_Internal
("instantiation error #",
Actual_Error_Loc, Msg_Cont_Status);
end if;
end if;
Error_Msg_Sloc := Instantiation (X);
X := Get_Source_File_Index (Error_Msg_Sloc);
Msg_Cont_Status := True;
end loop;
Suppress_Instance_Location := False;
Error_Msg_Sloc := Save_Error_Msg_Sloc;
Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status);
end;
end Error_Msg;
procedure Error_Msg_AP (Msg : String) is
S1 : Source_Ptr;
C : Character;
begin
S1 := Prev_Token_Ptr;
C := Source (S1);
if Prev_Token = Tok_String_Literal then
loop
S1 := S1 + 1;
if Source (S1) = C then
S1 := S1 + 1;
exit when Source (S1) /= C;
elsif Source (S1) in Line_Terminator then
exit;
end if;
end loop;
elsif Prev_Token = Tok_Char_Literal then
S1 := S1 + 3;
else
while Source (S1) not in Line_Terminator
and then Source (S1) /= ' '
and then Source (S1) /= ASCII.HT
and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
and then S1 /= Token_Ptr
loop
S1 := S1 + 1;
end loop;
end if;
Error_Msg (Msg, S1);
end Error_Msg_AP;
procedure Error_Msg_BC (Msg : String) is
begin
if Token = Tok_EOF then
Error_Msg_AP (Msg);
elsif Token_Ptr = Source_First (Current_Source_File) then
Error_Msg_SC (Msg);
elsif Source (Token_Ptr - 1) = ' '
or else Source (Token_Ptr - 1) = ASCII.HT
then
Error_Msg (Msg, Token_Ptr - 1);
else
Error_Msg (Msg, Token_Ptr);
end if;
end Error_Msg_BC;
procedure Error_Msg_Internal
(Msg : String;
Flag_Location : Source_Ptr;
Msg_Cont : Boolean)
is
Next_Msg : Error_Msg_Id;
Prev_Msg : Error_Msg_Id;
Temp_Msg : Error_Msg_Id;
Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location);
procedure Handle_Fatal_Error;
procedure Handle_Fatal_Error is
begin
if Operating_Mode = Generate_Code then
Operating_Mode := Check_Semantics;
Expander_Active := False;
end if;
if not Try_Semantics
and then Current_Source_Unit /= No_Unit
then
Set_Fatal_Error (Get_Source_Unit (Orig_Loc));
end if;
end Handle_Fatal_Error;
begin
if Raise_Exception_On_Error /= 0 then
raise Error_Msg_Exception;
end if;
Continuation := Msg_Cont;
Suppress_Message := False;
Kill_Message := False;
Set_Msg_Text (Msg, Orig_Loc);
if Continuation and Last_Killed then
return;
end if;
if Suppress_Message
and not All_Errors_Mode
and not (Msg (Msg'Last) = '!')
then
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
if Kill_Message
and then not All_Errors_Mode
and then Errors_Detected /= 0
then
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
Cur_Msg := No_Error_Msg;
return;
end if;
if Ignore_Errors_Enable > 0 then
Handle_Fatal_Error;
return;
end if;
Errors.Increment_Last;
Cur_Msg := Errors.Last;
Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen));
Errors.Table (Cur_Msg).Next := No_Error_Msg;
Errors.Table (Cur_Msg).Sptr := Orig_Loc;
Errors.Table (Cur_Msg).Fptr := Flag_Location;
Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Orig_Loc);
Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Orig_Loc);
Errors.Table (Cur_Msg).Col := Get_Column_Number (Orig_Loc);
Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg;
Errors.Table (Cur_Msg).Msg_Cont := Continuation;
Errors.Table (Cur_Msg).Deleted := False;
if Debug_Flag_OO or else Debug_Flag_1 then
Write_Eol;
Output_Source_Line (Errors.Table (Cur_Msg).Line,
Errors.Table (Cur_Msg).Sfile, True);
Temp_Msg := Cur_Msg;
Output_Error_Msgs (Temp_Msg);
else
Prev_Msg := No_Error_Msg;
Next_Msg := Error_Msgs;
while Next_Msg /= No_Error_Msg loop
exit when
Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
if Errors.Table (Cur_Msg).Sfile =
Errors.Table (Next_Msg).Sfile
then
exit when Orig_Loc < Errors.Table (Next_Msg).Sptr;
end if;
Prev_Msg := Next_Msg;
Next_Msg := Errors.Table (Next_Msg).Next;
end loop;
if Prev_Msg /= No_Error_Msg
and then Errors.Table (Prev_Msg).Line =
Errors.Table (Cur_Msg).Line
and then Errors.Table (Prev_Msg).Sfile =
Errors.Table (Cur_Msg).Sfile
and then Compiler_State = Parsing
and then not All_Errors_Mode
then
if not Errors.Table (Cur_Msg).Uncond
and then not Continuation
then
if not Errors.Table (Prev_Msg).Warn
or else Errors.Table (Cur_Msg).Warn
then
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
end if;
end if;
if not Continuation then
Last_Killed := False;
end if;
if Prev_Msg = No_Error_Msg then
Error_Msgs := Cur_Msg;
else
Errors.Table (Prev_Msg).Next := Cur_Msg;
end if;
Errors.Table (Cur_Msg).Next := Next_Msg;
end if;
if Errors.Table (Cur_Msg).Warn then
Warnings_Detected := Warnings_Detected + 1;
else
Errors_Detected := Errors_Detected + 1;
Handle_Fatal_Error;
end if;
if Errors_Detected + Warnings_Detected = Maximum_Errors then
raise Unrecoverable_Error;
end if;
end Error_Msg_Internal;
procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
begin
if No_Warnings (N) then
Test_Warning_Msg (Msg);
if Is_Warning_Msg then
return;
end if;
end if;
if All_Errors_Mode
or else Msg (Msg'Last) = '!'
or else OK_Node (N)
or else (Msg (1) = '\' and not Last_Killed)
then
Debug_Output (N);
Error_Msg_Node_1 := N;
Error_Msg (Msg, Sloc (N));
else
Last_Killed := True;
end if;
if not Is_Warning_Msg then
Set_Posted (N);
end if;
end Error_Msg_N;
procedure Error_Msg_NE
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
begin
if No_Warnings (N) or else No_Warnings (E) then
Test_Warning_Msg (Msg);
if Is_Warning_Msg then
return;
end if;
end if;
if All_Errors_Mode
or else Msg (Msg'Last) = '!'
or else OK_Node (N)
or else (Msg (1) = '\' and not Last_Killed)
then
Debug_Output (N);
Error_Msg_Node_1 := E;
Error_Msg (Msg, Sloc (N));
else
Last_Killed := True;
end if;
if not Is_Warning_Msg then
Set_Posted (N);
end if;
end Error_Msg_NE;
procedure Error_Msg_S (Msg : String) is
begin
Error_Msg (Msg, Scan_Ptr);
end Error_Msg_S;
procedure Error_Msg_SC (Msg : String) is
begin
if Token = Tok_EOF then
Error_Msg_AP (Msg);
else
Error_Msg (Msg, Token_Ptr);
end if;
end Error_Msg_SC;
procedure Error_Msg_SP (Msg : String) is
begin
Error_Msg (Msg, Prev_Token_Ptr);
end Error_Msg_SP;
procedure Finalize is
Cur : Error_Msg_Id;
Nxt : Error_Msg_Id;
E, F : Error_Msg_Id;
Err_Flag : Boolean;
begin
if Num_SRef_Pragmas (Main_Source_File) /= 0 then
Current_Error_Source_File := No_Source_File;
end if;
Cur := Error_Msgs;
while Cur /= No_Error_Msg loop
Nxt := Errors.Table (Cur).Next;
F := Nxt;
while F /= No_Error_Msg
and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
loop
Check_Duplicate_Message (Cur, F);
F := Errors.Table (F).Next;
end loop;
Cur := Nxt;
end loop;
if Brief_Output or (not Full_List and not Verbose_Mode) then
E := Error_Msgs;
Set_Standard_Error;
while E /= No_Error_Msg loop
if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
Write_Name (Reference_Name (Errors.Table (E).Sfile));
Write_Char (':');
Write_Int (Int (Physical_To_Logical
(Errors.Table (E).Line,
Errors.Table (E).Sfile)));
Write_Char (':');
if Errors.Table (E).Col < 10 then
Write_Char ('0');
end if;
Write_Int (Int (Errors.Table (E).Col));
Write_Str (": ");
Output_Msg_Text (E);
Write_Eol;
end if;
E := Errors.Table (E).Next;
end loop;
Set_Standard_Output;
end if;
if Full_List then
List_Pragmas_Index := 1;
List_Pragmas_Mode := True;
E := Error_Msgs;
Write_Eol;
for N in 1 .. Last_Source_Line (Main_Source_File) loop
Err_Flag :=
E /= No_Error_Msg
and then Errors.Table (E).Line = N
and then Errors.Table (E).Sfile = Main_Source_File;
Output_Source_Line (N, Main_Source_File, Err_Flag);
if Err_Flag then
Output_Error_Msgs (E);
if not Debug_Flag_2 then
Write_Eol;
end if;
end if;
end loop;
while E /= No_Error_Msg
and then Errors.Table (E).Sfile /= Main_Source_File
loop
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end loop;
end if;
if Verbose_Mode and not Full_List then
E := Error_Msgs;
while E /= No_Error_Msg loop
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end loop;
end if;
if Verbose_Mode or else Full_List then
if Errors_Detected + Warnings_Detected > 0 or else Full_List then
Write_Eol;
end if;
if Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
and then (Verbose_Mode or Full_List)
then
Set_Standard_Error;
end if;
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;
if Errors_Detected = 0 then
Write_Str ("No errors");
elsif Errors_Detected = 1 then
Write_Str ("1 error");
else
Write_Int (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 Warning_Mode = Treat_As_Error then
Write_Str (" (treated as error");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
Write_Char (')');
end if;
end if;
Write_Eol;
Set_Standard_Output;
end if;
if Maximum_Errors /= 0
and then Errors_Detected + Warnings_Detected = Maximum_Errors
then
Set_Standard_Error;
Write_Str ("fatal error: maximum errors reached");
Write_Eol;
Set_Standard_Output;
end if;
if Warning_Mode = Treat_As_Error then
Errors_Detected := Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
end Finalize;
function Get_Location (E : Error_Msg_Id) return Source_Ptr is
begin
return Errors.Table (E).Sptr;
end Get_Location;
function Get_Msg_Id return Error_Msg_Id is
begin
return Cur_Msg;
end Get_Msg_Id;
procedure Initialize is
begin
Errors.Init;
Error_Msgs := No_Error_Msg;
Errors_Detected := 0;
Warnings_Detected := 0;
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
Warnings.Init;
if Warning_Mode = Suppress then
Warnings.Increment_Last;
Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
end if;
end Initialize;
function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
begin
if Error_Posted (N) then
return True;
elsif Nkind (N) in N_Entity and then Warnings_Off (N) then
return True;
elsif Is_Entity_Name (N)
and then Present (Entity (N))
and then Warnings_Off (Entity (N))
then
return True;
else
return False;
end if;
end No_Warnings;
function OK_Node (N : Node_Id) return Boolean is
K : constant Node_Kind := Nkind (N);
begin
if Error_Posted (N) then
return False;
elsif K in N_Has_Etype
and then Present (Etype (N))
and then Error_Posted (Etype (N))
then
return False;
elsif (K in N_Op
or else K = N_Attribute_Reference
or else K = N_Character_Literal
or else K = N_Expanded_Name
or else K = N_Identifier
or else K = N_Operator_Symbol)
and then Present (Entity (N))
and then Error_Posted (Entity (N))
then
return False;
else
return True;
end if;
end OK_Node;
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;
if Errors.Table (S).Deleted then
Set_Next_Non_Deleted_Msg (S);
end if;
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;
if not Debug_Flag_2 then
Write_Str (" ");
P := Line_Start (Errors.Table (E).Sptr);
Flag_Num := 1;
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
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;
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;
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;
procedure Output_Line_Number (L : Logical_Line_Number) is
D : Int; C : Character; Z : Boolean; N, M : Int;
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;
procedure Output_Msg_Text (E : Error_Msg_Id) is
begin
if Errors.Table (E).Warn then
if Errors.Table (E).Text'Length > 7
and then Errors.Table (E).Text (1 .. 7) /= "(style)"
then
Write_Str ("warning: ");
end if;
elsif Opt.Unique_Error_Tag then
Write_Str ("error: ");
end if;
Write_Str (Errors.Table (E).Text.all);
end Output_Msg_Text;
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
Errs : Boolean)
is
S : Source_Ptr;
C : Character;
Line_Number_Output : Boolean := False;
begin
if Sfile /= Current_Error_Source_File then
Write_Str ("==============Error messages for source file: ");
Write_Name (Full_File_Name (Sfile));
Write_Eol;
if Num_SRef_Pragmas (Sfile) > 0 then
Write_Str ("--------------Line numbers from file: ");
Write_Name (Full_Ref_Name (Sfile));
Write_Str (" (starting at line ");
Write_Int (Int (First_Mapped_Line (Sfile)));
Write_Char (')');
Write_Eol;
end if;
Current_Error_Source_File := Sfile;
end if;
if Errs or List_Pragmas_Mode then
Output_Line_Number (Physical_To_Logical (L, Sfile));
Line_Number_Output := True;
end if;
S := Line_Start (L, Sfile);
loop
C := Source_Text (Sfile) (S);
exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
if Full_List
and then List_Pragmas_Index <= List_Pragmas.Last
and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
then
case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
when Page =>
Write_Char (C);
if not Errs then
Write_Char (ASCII.FF);
end if;
when List_On =>
List_Pragmas_Mode := True;
if not Line_Number_Output then
Output_Line_Number (Physical_To_Logical (L, Sfile));
Line_Number_Output := True;
end if;
Write_Char (C);
when List_Off =>
Write_Char (C);
List_Pragmas_Mode := False;
end case;
List_Pragmas_Index := List_Pragmas_Index + 1;
else
if Errs or List_Pragmas_Mode then
Write_Char (C);
end if;
end if;
S := S + 1;
end loop;
if Line_Number_Output then
Write_Eol;
end if;
end Output_Source_Line;
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
E : Error_Msg_Id;
function To_Be_Purged (E : Error_Msg_Id) return Boolean;
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 then
Warnings_Detected := Warnings_Detected - 1;
else
Errors_Detected := Errors_Detected - 1;
end if;
return True;
else
return False;
end if;
end To_Be_Purged;
begin
while To_Be_Purged (Error_Msgs) loop
Error_Msgs := Errors.Table (Error_Msgs).Next;
end loop;
E := Error_Msgs;
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;
procedure Remove_Warning_Messages (N : Node_Id) is
function Check_For_Warning (N : Node_Id) return Traverse_Result;
function Check_All_Warnings is new
Traverse_Func (Check_For_Warning);
function Check_For_Warning (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
E : Error_Msg_Id;
function To_Be_Removed (E : Error_Msg_Id) return Boolean;
function To_Be_Removed (E : Error_Msg_Id) return Boolean is
begin
if E /= No_Error_Msg
and then Errors.Table (E).Fptr = Loc
and then Errors.Table (E).Warn
then
Warnings_Detected := Warnings_Detected - 1;
return True;
else
return False;
end if;
end To_Be_Removed;
begin
while To_Be_Removed (Error_Msgs) loop
Error_Msgs := Errors.Table (Error_Msgs).Next;
end loop;
E := Error_Msgs;
while E /= No_Error_Msg loop
while To_Be_Removed (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;
if Nkind (N) = N_Raise_Constraint_Error
and then Original_Node (N) /= N
then
declare
Old : Node_Id := N;
Status : Traverse_Result;
begin
Rewrite (N, Original_Node (N));
Status := Check_For_Warning (N);
Rewrite (N, Old);
return Status;
end;
else
return OK;
end if;
end Check_For_Warning;
begin
if Warnings_Detected /= 0 then
declare
Discard : Traverse_Result;
begin
Discard := Check_All_Warnings (N);
end;
end if;
end Remove_Warning_Messages;
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;
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;
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;
procedure Set_Msg_Char (C : Character) is
begin
if Msglen < Max_Msg_Length then
Msglen := Msglen + 1;
Msg_Buffer (Msglen) := C;
end if;
end Set_Msg_Char;
procedure Set_Msg_Insertion_Column is
begin
if Style.RM_Column_Check then
Set_Msg_Str (" in column ");
Set_Msg_Int (Int (Error_Msg_Col) + 1);
end if;
end Set_Msg_Insertion_Column;
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;
Error_Msg_Name_1 := Error_Msg_Name_2;
Error_Msg_Name_2 := Error_Msg_Name_3;
end Set_Msg_Insertion_File_Name;
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 <= Standard_Location then
Set_Msg_Str ("in package Standard");
if Loc = Standard_ASCII_Location then
Set_Msg_Str (".ASCII");
end if;
else
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 (':');
else
Set_Msg_Str ("at line ");
end if;
Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
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;
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);
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;
if Name_Len > 1
and then Name_Buffer (Name_Len) in 'A' .. 'Z'
then
Name_Len := Name_Len - 1;
end if;
if Name_Buffer (1) = '"'
or else Name_Buffer (1) = '''
or else Name_Buffer (Name_Len) = ')'
then
Set_Msg_Name_Buffer;
else
Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
end if;
end if;
Error_Msg_Name_1 := Error_Msg_Name_2;
Error_Msg_Name_2 := Error_Msg_Name_3;
end Set_Msg_Insertion_Name;
procedure Set_Msg_Insertion_Node is
begin
Suppress_Message :=
Error_Msg_Node_1 = Error
or else Error_Msg_Node_1 = Any_Type;
if Error_Msg_Node_1 = Empty then
Set_Msg_Blank_Conditional;
Set_Msg_Str ("<empty>");
elsif Error_Msg_Node_1 = Error then
Set_Msg_Blank;
Set_Msg_Str ("<error>");
elsif Error_Msg_Node_1 = Standard_Void_Type then
Set_Msg_Blank;
Set_Msg_Str ("procedure name");
else
Set_Msg_Blank_Conditional;
if Nkind (Error_Msg_Node_1) in N_Op then
Set_Msg_Node (Error_Msg_Node_1);
else
Set_Msg_Quote;
Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
Set_Msg_Node (Error_Msg_Node_1);
Set_Msg_Quote;
end if;
end if;
Error_Msg_Node_1 := Error_Msg_Node_2;
end Set_Msg_Insertion_Node;
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;
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;
procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
Ent : Entity_Id;
begin
Set_Msg_Blank;
if Error_Msg_Node_1 = Standard_Void_Type then
Set_Msg_Str ("package or procedure name");
return;
elsif Error_Msg_Node_1 = Standard_Exception_Type then
Set_Msg_Str ("exception name");
return;
elsif Error_Msg_Node_1 = Any_Access
or else Error_Msg_Node_1 = Any_Array
or else Error_Msg_Node_1 = Any_Boolean
or else Error_Msg_Node_1 = Any_Character
or else Error_Msg_Node_1 = Any_Composite
or else Error_Msg_Node_1 = Any_Discrete
or else Error_Msg_Node_1 = Any_Fixed
or else Error_Msg_Node_1 = Any_Integer
or else Error_Msg_Node_1 = Any_Modular
or else Error_Msg_Node_1 = Any_Numeric
or else Error_Msg_Node_1 = Any_Real
or else Error_Msg_Node_1 = Any_Scalar
or else Error_Msg_Node_1 = Any_String
then
Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
Set_Msg_Name_Buffer;
return;
elsif Error_Msg_Node_1 = Universal_Real then
Set_Msg_Str ("type universal real");
return;
elsif Error_Msg_Node_1 = Universal_Integer then
Set_Msg_Str ("type universal integer");
return;
elsif Error_Msg_Node_1 = Universal_Fixed then
Set_Msg_Str ("type universal fixed");
return;
end if;
if Nkind (Error_Msg_Node_1) in N_Entity
and then Is_Array_Type (Error_Msg_Node_1)
and then Present (Related_Array_Object (Error_Msg_Node_1))
then
Set_Msg_Str ("type of ");
Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
Set_Msg_Str (" declared");
Set_Msg_Insertion_Line_Number
(Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
return;
end if;
if Is_Private_Type (Error_Msg_Node_1) then
Set_Msg_Str ("private type ");
else
Set_Msg_Str ("type ");
end if;
Ent := Error_Msg_Node_1;
if Is_Internal_Name (Chars (Ent)) then
Unwind_Internal_Type (Ent);
end if;
if Sloc (Ent) <= Standard_Location then
Set_Msg_Quote;
Set_Msg_Str ("Standard.");
Set_Msg_Node (Ent);
Add_Class;
Set_Msg_Quote;
elsif
Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent)))
then
Get_Unqualified_Decoded_Name_String
(Unit_Name (Get_Source_Unit (Ent)));
Name_Len := Name_Len - 2;
Set_Msg_Quote;
Set_Casing (Mixed_Case);
Set_Msg_Name_Buffer;
Set_Msg_Char ('.');
Set_Casing (Mixed_Case);
Set_Msg_Node (Ent);
Add_Class;
Set_Msg_Quote;
else
Set_Msg_Quote;
Set_Qualification (Error_Msg_Qual_Level, Ent);
Set_Msg_Node (Ent);
Add_Class;
Set_Msg_Quote;
end if;
if Sloc (Error_Msg_Node_1) > Standard_Location
and then
not Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)))
then
Set_Msg_Str (" defined");
Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
else
if Sloc (Error_Msg_Node_1) > Standard_Location then
declare
Iloc : constant Source_Ptr :=
Instantiation_Location (Sloc (Error_Msg_Node_1));
begin
if Iloc /= No_Location
and then not Suppress_Instance_Location
then
Set_Msg_Str (" from instance");
Set_Msg_Insertion_Line_Number (Iloc, Flag);
end if;
end;
end if;
end if;
end Set_Msg_Insertion_Type_Reference;
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;
Error_Msg_Uint_1 := Error_Msg_Uint_2;
end Set_Msg_Insertion_Uint;
procedure Set_Msg_Insertion_Unit_Name is
begin
if Error_Msg_Unit_1 = No_Name then
null;
elsif Error_Msg_Unit_1 = Error_Name then
Set_Msg_Blank;
Set_Msg_Str ("<error>");
else
Get_Unit_Name_String (Error_Msg_Unit_1);
Set_Msg_Blank;
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
end if;
Error_Msg_Unit_1 := Error_Msg_Unit_2;
end Set_Msg_Insertion_Unit_Name;
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;
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;
procedure Set_Msg_Node (Node : Node_Id) is
Ent : Entity_Id;
Nam : Name_Id;
begin
if Nkind (Node) = N_Designator then
Set_Msg_Node (Name (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Identifier (Node));
return;
elsif Nkind (Node) = N_Defining_Program_Unit_Name then
Set_Msg_Node (Name (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Defining_Identifier (Node));
return;
elsif Nkind (Node) = N_Selected_Component then
Set_Msg_Node (Prefix (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Selector_Name (Node));
return;
end if;
if Is_Internal_Name (Chars (Node))
and then
((Is_Entity_Name (Node)
and then Present (Entity (Node))
and then Is_Type (Entity (Node)))
or else
(Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
then
if Nkind (Node) = N_Identifier then
Ent := Entity (Node);
else
Ent := Node;
end if;
Unwind_Internal_Type (Ent);
Nam := Chars (Ent);
else
Nam := Chars (Node);
end if;
Get_Unqualified_Decoded_Name_String (Nam);
while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
Name_Len := Name_Len - 1;
end loop;
if Name_Len > 4
and then Name_Buffer (1 .. 4) = "any "
then
Kill_Message := True;
end if;
declare
Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1);
Sbuffer : Source_Buffer_Ptr;
Ref_Ptr : Integer;
Src_Ptr : Source_Ptr;
begin
Ref_Ptr := 1;
Src_Ptr := Src_Loc;
if Src_Loc /= No_Location
and then Src_Loc > Standard_Location
then
Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
while Ref_Ptr <= Name_Len loop
exit when
Fold_Lower (Sbuffer (Src_Ptr)) /=
Fold_Lower (Name_Buffer (Ref_Ptr));
Ref_Ptr := Ref_Ptr + 1;
Src_Ptr := Src_Ptr + 1;
end loop;
end if;
if Ref_Ptr > Name_Len then
Src_Ptr := Src_Loc;
for J in 1 .. Name_Len loop
Name_Buffer (J) := Sbuffer (Src_Ptr);
Src_Ptr := Src_Ptr + 1;
end loop;
else
Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
end if;
end;
Set_Msg_Name_Buffer;
Add_Class;
if Class_Flag then
Set_Msg_Char (''');
Get_Name_String (Name_Class);
Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
Set_Msg_Name_Buffer;
end if;
end Set_Msg_Node;
procedure Set_Msg_Quote is
begin
if not Manual_Quote_Mode then
Set_Msg_Char ('"');
end if;
end Set_Msg_Quote;
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;
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
C : Character; P : Natural;
begin
Manual_Quote_Mode := False;
Is_Unconditional_Msg := False;
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
P := Text'First;
while P <= Text'Last loop
C := Text (P);
P := P + 1;
if C = '%' then
Set_Msg_Insertion_Name;
elsif C = '$' then
Set_Msg_Insertion_Unit_Name;
elsif C = '{' then
Set_Msg_Insertion_File_Name;
elsif C = '}' then
Set_Msg_Insertion_Type_Reference (Flag);
elsif C = '*' then
Set_Msg_Insertion_Reserved_Name;
elsif C = '&' then
Set_Msg_Insertion_Node;
elsif C = '#' then
Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
elsif C = '\' then
Continuation := True;
elsif C = '@' then
Set_Msg_Insertion_Column;
elsif C = '^' then
Set_Msg_Insertion_Uint;
elsif C = '`' then
Manual_Quote_Mode := not Manual_Quote_Mode;
Set_Msg_Char ('"');
elsif C = '!' then
Is_Unconditional_Msg := True;
elsif C = '?' then
null;
elsif C = ''' then
Set_Msg_Char (Text (P));
P := P + 1;
elsif C in 'A' .. 'Z'
and then P <= Text'Last
and then Text (P) in 'A' .. 'Z'
then
P := P - 1;
Set_Msg_Insertion_Reserved_Word (Text, P);
else
Set_Msg_Char (C);
end if;
end loop;
end Set_Msg_Text;
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;
procedure Set_Posted (N : Node_Id) is
P : Node_Id;
begin
Set_Error_Posted (N);
P := N;
loop
P := Parent (P);
exit when No (P);
Set_Error_Posted (P);
exit when Nkind (P) not in N_Subexpr;
end loop;
end Set_Posted;
procedure Set_Qualification (N : Nat; E : Entity_Id) is
begin
if N /= 0 and then Scope (E) /= Standard_Standard then
Set_Qualification (N - 1, Scope (E));
Set_Msg_Node (Scope (E));
Set_Msg_Char ('.');
end if;
end Set_Qualification;
procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
begin
if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
return;
end if;
if Warnings.Last >= Warnings.First
and then Warnings.Table (Warnings.Last).Start <= Loc
and then Loc <= Warnings.Table (Warnings.Last).Stop
then
return;
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;
procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
begin
if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
return;
end if;
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;
procedure Test_Warning_Msg (Msg : String) is
begin
if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then
Is_Warning_Msg := True;
return;
end if;
for J in Msg'Range loop
if Msg (J) = '?'
and then (J = Msg'First or else Msg (J - 1) /= ''')
then
Is_Warning_Msg := True;
return;
end if;
end loop;
Is_Warning_Msg := False;
end Test_Warning_Msg;
procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
Derived : Boolean := False;
Mchar : Character;
Old_Ent : Entity_Id;
begin
Mchar := Msg_Buffer (Msglen);
if Mchar = '"' then
Msglen := Msglen - 1;
end if;
loop
Old_Ent := Ent;
if Is_Access_Type (Ent) then
Set_Msg_Str ("access to ");
Ent := Directly_Designated_Type (Ent);
elsif Is_Class_Wide_Type (Ent) then
Class_Flag := True;
Ent := Root_Type (Ent);
elsif Ent /= Base_Type (Ent) then
Buffer_Remove ("type ");
if not Buffer_Ends_With ("subtype of ")
and then not Buffer_Ends_With ("derived from ")
then
Set_Msg_Str ("subtype of ");
end if;
Ent := Base_Type (Ent);
elsif Present (Freeze_Node (Ent))
and then Present (First_Subtype_Link (Freeze_Node (Ent)))
and then
not Is_Internal_Name
(Chars (First_Subtype_Link (Freeze_Node (Ent))))
then
Ent := First_Subtype_Link (Freeze_Node (Ent));
else
if not Derived then
Buffer_Remove ("type ");
Buffer_Remove ("subtype of");
if not Buffer_Ends_With ("type derived from ") then
Set_Msg_Str ("type derived from ");
end if;
Derived := True;
end if;
Ent := Etype (Ent);
end if;
if Ent = Old_Ent then
Kill_Message := True;
exit;
end if;
exit when not Is_Internal_Name (Chars (Ent));
end loop;
if Mchar = '"' then
Set_Msg_Char ('"');
end if;
end Unwind_Internal_Type;
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 Errout;