with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Erroutc; use Erroutc;
with Fname; use Fname;
with Hostparm; use Hostparm;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Nlists; use Nlists;
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;
with Unchecked_Conversion;
package body Errout is
Errors_Must_Be_Ignored : Boolean := False;
Warn_On_Instance : Boolean;
type NIM_Record is record
Msg : String_Ptr;
Loc : Source_Ptr;
end record;
package Non_Instance_Msgs is new Table.Table (
Table_Component_Type => NIM_Record,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 100,
Table_Name => "Non_Instance_Msgs");
procedure Error_Msg_Internal
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
Msg_Cont : Boolean);
function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
function OK_Node (N : Node_Id) return Boolean;
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
Errs : Boolean);
procedure Set_Msg_Insertion_Column;
procedure Set_Msg_Insertion_Node;
procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
procedure Set_Msg_Insertion_Unit_Name;
procedure Set_Msg_Node (Node : Node_Id);
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
procedure Set_Posted (N : Node_Id);
procedure Set_Qualification (N : Nat; E : Entity_Id);
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id) return Boolean;
procedure Unwind_Internal_Type (Ent : in out Entity_Id);
procedure VMS_Convert;
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 Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
Sindex : Source_File_Index;
Orig_Loc : Source_Ptr;
begin
pragma Assert (Sinput.Source /= Internal_Source_Ptr);
if Errors_Must_Be_Ignored then
return;
end if;
if Flag_Location < First_Source_Ptr
and then Total_Errors_Detected > 0
then
return;
end if;
Sindex := Get_Source_File_Index (Flag_Location);
Test_Style_Warning_Serious_Msg (Msg);
Orig_Loc := Original_Location (Flag_Location);
if Flag_Location = Orig_Loc then
Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
Warn_On_Instance := False;
else
if not Debug_Flag_GG then
for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
if Msg = Non_Instance_Msgs.Table (J).Msg.all
and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc
then
return;
end if;
end loop;
end if;
Warn_On_Instance := Is_Warning_Msg;
end if;
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, Flag_Location, False);
return;
end if;
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 (Msg'First) /= '\' then
if Inlined_Body (X) then
if Is_Warning_Msg then
Error_Msg_Internal
("?in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
else
Error_Msg_Internal
("error in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
end if;
else
if Is_Warning_Msg then
Error_Msg_Internal
("?in instantiation #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
else
Error_Msg_Internal
("instantiation error #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
end if;
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, Flag_Location, 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_CRT (Feature : String; N : Node_Id) is
CNRT : constant String := " not allowed in no run time mode";
CCRT : constant String := " not supported by configuration>";
S : String (1 .. Feature'Length + 1 + CCRT'Length);
L : Natural;
begin
S (1) := '|';
S (2 .. Feature'Length + 1) := Feature;
L := Feature'Length + 2;
if No_Run_Time_Mode then
S (L .. L + CNRT'Length - 1) := CNRT;
L := L + CNRT'Length - 1;
else pragma Assert (Configurable_Run_Time_Mode);
S (L .. L + CCRT'Length - 1) := CCRT;
L := L + CCRT'Length - 1;
end if;
Error_Msg_N (S (1 .. L), N);
Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
end Error_Msg_CRT;
procedure Error_Msg_F (Msg : String; N : Node_Id) is
begin
Error_Msg_NEL (Msg, N, N, First_Sloc (N));
end Error_Msg_F;
procedure Error_Msg_FE
(Msg : String;
N : Node_Id;
E : Node_Or_Entity_Id)
is
begin
Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
end Error_Msg_FE;
procedure Error_Msg_Internal
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
Msg_Cont : Boolean)
is
Next_Msg : Error_Msg_Id;
Prev_Msg : Error_Msg_Id;
Temp_Msg : Error_Msg_Id;
procedure Handle_Serious_Error;
procedure Handle_Serious_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 (Sptr));
end if;
end Handle_Serious_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, Sptr);
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 Total_Errors_Detected /= 0
then
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
if Is_Warning_Msg then
if Warnings_Suppressed (Optr)
or else Warnings_Suppressed (Sptr)
then
Cur_Msg := No_Error_Msg;
return;
end if;
if In_Extended_Main_Source_Unit (Sptr) then
null;
elsif In_Extended_Main_Code_Unit (Sptr)
and then Warn_On_Instance
then
null;
elsif Debug_Flag_GG then
null;
else
Cur_Msg := No_Error_Msg;
return;
end if;
end if;
if Ignore_Errors_Enable > 0 then
if Is_Serious_Error then
Handle_Serious_Error;
end if;
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 := Sptr;
Errors.Table (Cur_Msg).Optr := Optr;
Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr);
Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr);
Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr);
Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
Errors.Table (Cur_Msg).Style := Is_Style_Msg;
Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
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
if Last_Error_Msg /= No_Error_Msg
and then Errors.Table (Cur_Msg).Sfile =
Errors.Table (Last_Error_Msg).Sfile
and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
or else
(Sptr = Errors.Table (Last_Error_Msg).Sptr
and then
Optr > Errors.Table (Last_Error_Msg).Optr))
then
Prev_Msg := Last_Error_Msg;
Next_Msg := No_Error_Msg;
else
Prev_Msg := No_Error_Msg;
Next_Msg := First_Error_Msg;
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 Sptr < Errors.Table (Next_Msg).Sptr
or else
(Sptr = Errors.Table (Next_Msg).Sptr
and then
Optr < Errors.Table (Next_Msg).Optr);
end if;
Prev_Msg := Next_Msg;
Next_Msg := Errors.Table (Next_Msg).Next;
end loop;
end if;
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
Errors.Table (Prev_Msg).Style)
or else
(Errors.Table (Cur_Msg).Warn
or
Errors.Table (Cur_Msg).Style)
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
First_Error_Msg := Cur_Msg;
else
Errors.Table (Prev_Msg).Next := Cur_Msg;
end if;
Errors.Table (Cur_Msg).Next := Next_Msg;
if Next_Msg = No_Error_Msg then
Last_Error_Msg := Cur_Msg;
end if;
end if;
if Errors.Table (Cur_Msg).Warn
or else Errors.Table (Cur_Msg).Style
then
Warnings_Detected := Warnings_Detected + 1;
else
Total_Errors_Detected := Total_Errors_Detected + 1;
if Errors.Table (Cur_Msg).Serious then
Serious_Errors_Detected := Serious_Errors_Detected + 1;
Handle_Serious_Error;
end if;
end if;
if Total_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
Error_Msg_NEL (Msg, N, N, Sloc (N));
end Error_Msg_N;
procedure Error_Msg_NE
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
is
begin
Error_Msg_NEL (Msg, N, E, Sloc (N));
end Error_Msg_NE;
procedure Error_Msg_NEL
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id;
Flag_Location : Source_Ptr)
is
begin
if Special_Msg_Delete (Msg, N, E) then
return;
end if;
Test_Style_Warning_Serious_Msg (Msg);
if Is_Warning_Msg then
if No_Warnings (N) or else No_Warnings (E) then
return;
end if;
declare
P : Node_Id;
begin
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Loop_Statement and then Is_Null_Loop (P) then
return;
end if;
P := Parent (P);
end loop;
end;
end if;
if All_Errors_Mode
or else Msg (Msg'Last) = '!'
or else OK_Node (N)
or else (Msg (Msg'First) = '\' and not Last_Killed)
then
Debug_Output (N);
Error_Msg_Node_1 := E;
Error_Msg (Msg, Flag_Location);
else
Last_Killed := True;
end if;
if not Is_Warning_Msg and then not Is_Style_Msg then
Set_Posted (N);
end if;
end Error_Msg_NEL;
procedure Error_Msg_NW
(Eflag : Boolean;
Msg : String;
N : Node_Or_Entity_Id)
is
begin
if Eflag and then In_Extended_Main_Source_Unit (N) then
Error_Msg_NEL (Msg, N, N, Sloc (N));
end if;
end Error_Msg_NW;
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 Main_Source_File = No_Source_File or else
Num_SRef_Pragmas (Main_Source_File) /= 0
then
Current_Error_Source_File := No_Source_File;
end if;
Cur := First_Error_Msg;
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 := First_Error_Msg;
Set_Standard_Error;
while E /= No_Error_Msg loop
if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
if Full_Path_Name_For_Brief_Errors then
Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
else
Write_Name (Reference_Name (Errors.Table (E).Sfile));
end if;
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 := First_Error_Msg;
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 := First_Error_Msg;
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 Total_Errors_Detected + Warnings_Detected > 0
or else Full_List
then
Write_Eol;
end if;
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
and then (Verbose_Mode or Full_List)
then
Set_Standard_Error;
end if;
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 Total_Errors_Detected = 0 then
Write_Str ("No errors");
elsif Total_Errors_Detected = 1 then
Write_Str ("1 error");
else
Write_Int (Total_Errors_Detected);
Write_Str (" errors");
end if;
if Warnings_Detected /= 0 then
Write_Str (", ");
Write_Int (Warnings_Detected);
Write_Str (" warning");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
if 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 Total_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
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
end Finalize;
function First_Node (C : Node_Id) return Node_Id is
L : constant Source_Ptr := Sloc (C);
Sfile : constant Source_File_Index := Get_Source_File_Index (L);
Earliest : Node_Id;
Eloc : Source_Ptr;
Discard : Traverse_Result;
pragma Warnings (Off, Discard);
function Test_Earlier (N : Node_Id) return Traverse_Result;
function Search_Tree_First is new Traverse_Func (Test_Earlier);
function Test_Earlier (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
begin
if Loc < Eloc
and then Get_Source_File_Index (Loc) = Sfile
then
Earliest := N;
Eloc := Loc;
end if;
return OK_Orig;
end Test_Earlier;
begin
Earliest := Original_Node (C);
Eloc := Sloc (Earliest);
Discard := Search_Tree_First (Original_Node (C));
return Earliest;
end First_Node;
function First_Sloc (N : Node_Id) return Source_Ptr is
SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
SF : constant Source_Ptr := Source_First (SI);
F : Node_Id;
S : Source_Ptr;
begin
F := First_Node (N);
S := Sloc (F);
Node_Loop : loop
Paren_Loop : for J in 1 .. Paren_Count (F) loop
Search_Loop : for K in 1 .. 12 loop
exit Search_Loop when S = SF;
if Source_Text (SI) (S - 1) = '(' then
S := S - 1;
exit Search_Loop;
elsif Source_Text (SI) (S - 1) <= ' ' then
S := S - 1;
else
exit Search_Loop;
end if;
end loop Search_Loop;
end loop Paren_Loop;
exit Node_Loop when F = N;
F := Parent (F);
exit Node_Loop when Nkind (F) not in N_Subexpr;
end loop Node_Loop;
return S;
end First_Sloc;
procedure Initialize is
begin
Errors.Init;
First_Error_Msg := No_Error_Msg;
Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_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;
Error_Msg_Node_1 := Empty;
Error_Msg_Node_2 := Empty;
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_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 ");
case Sinput.File_Type (Sfile) is
when Sinput.Src =>
Write_Str ("source");
when Sinput.Config =>
Write_Str ("configuration pragmas");
when Sinput.Def =>
Write_Str ("symbol definition");
when Sinput.Preproc =>
Write_Str ("preprocessing data");
end case;
Write_Str (" 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 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).Optr = Loc
and then (Errors.Table (E).Warn or Errors.Table (E).Style)
then
Warnings_Detected := Warnings_Detected - 1;
return True;
else
return False;
end if;
end To_Be_Removed;
begin
while To_Be_Removed (First_Error_Msg) loop
First_Error_Msg := Errors.Table (First_Error_Msg).Next;
end loop;
if First_Error_Msg = No_Error_Msg then
Last_Error_Msg := No_Error_Msg;
end if;
E := First_Error_Msg;
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;
if Errors.Table (E).Next = No_Error_Msg then
Last_Error_Msg := E;
end if;
end loop;
E := Errors.Table (E).Next;
end loop;
if Nkind (N) = N_Raise_Constraint_Error
and then Original_Node (N) /= N
and then No (Condition (N))
then
declare
Status : Traverse_Result;
begin
if Is_List_Member (N) then
Set_Condition (N, Original_Node (N));
Status := Check_All_Warnings (Condition (N));
else
Rewrite (N, Original_Node (N));
Status := Check_All_Warnings (N);
end if;
return Status;
end;
else
return OK;
end if;
end Check_For_Warning;
begin
if Warnings_Detected /= 0 then
declare
Discard : Traverse_Result;
pragma Warnings (Off, Discard);
begin
Discard := Check_All_Warnings (N);
end;
end if;
end Remove_Warning_Messages;
procedure Remove_Warning_Messages (L : List_Id) is
Stat : Node_Id;
begin
if Is_Non_Empty_List (L) then
Stat := First (L);
while Present (Stat) loop
Remove_Warning_Messages (Stat);
Next (Stat);
end loop;
end if;
end Remove_Warning_Messages;
procedure Set_Identifier_Casing
(Identifier_Name : System.Address;
File_Name : System.Address)
is
type Big_String is array (Positive) of Character;
type Big_String_Ptr is access all Big_String;
function To_Big_String_Ptr is new Unchecked_Conversion
(System.Address, Big_String_Ptr);
Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
Flen : Natural;
Desired_Case : Casing_Type := Mixed_Case;
begin
Flen := 0;
while File (Flen + 1) /= ASCII.NUL loop
Flen := Flen + 1;
end loop;
for J in 1 .. Last_Source_File loop
Get_Name_String (Full_Debug_Name (J));
if Name_Len = Flen
and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
then
Desired_Case := Identifier_Casing (J);
exit;
end if;
end loop;
for J in Name_Buffer'Range loop
Name_Buffer (J) := Ident (J);
if Name_Buffer (J) = ASCII.Nul then
Name_Len := J - 1;
exit;
end if;
end loop;
Set_Casing (Desired_Case);
end Set_Identifier_Casing;
procedure Set_Ignore_Errors (To : Boolean) is
begin
Errors_Must_Be_Ignored := To;
end Set_Ignore_Errors;
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_Node is
K : Node_Kind;
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;
K := Nkind (Error_Msg_Node_1);
if K in N_Op
or else K = N_Operator_Symbol
or else K = N_Defining_Operator_Symbol
or else ((K = N_Identifier or else K = N_Defining_Identifier)
and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
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_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_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_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
or else Sloc (Node) <= No_Location
then
Set_Casing (Mixed_Case);
else
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;
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 if;
end;
Set_Msg_Name_Buffer;
Add_Class;
end Set_Msg_Node;
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;
case C is
when '%' =>
Set_Msg_Insertion_Name;
when '$' =>
Set_Msg_Insertion_Unit_Name;
when '{' =>
Set_Msg_Insertion_File_Name;
when '}' =>
Set_Msg_Insertion_Type_Reference (Flag);
when '*' =>
Set_Msg_Insertion_Reserved_Name;
when '&' =>
Set_Msg_Insertion_Node;
when '#' =>
Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
when '\' =>
Continuation := True;
when '@' =>
Set_Msg_Insertion_Column;
when '>' =>
Set_Msg_Insertion_Run_Time_Name;
when '^' =>
Set_Msg_Insertion_Uint;
when '`' =>
Manual_Quote_Mode := not Manual_Quote_Mode;
Set_Msg_Char ('"');
when '!' =>
Is_Unconditional_Msg := True;
when '?' =>
null;
when '|' =>
null;
when ''' =>
Set_Msg_Char (Text (P));
P := P + 1;
when 'A' .. 'Z' =>
if 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;
when others =>
Set_Msg_Char (C);
end case;
end loop;
VMS_Convert;
end Set_Msg_Text;
procedure Set_Posted (N : Node_Id) is
P : Node_Id;
begin
if Is_Serious_Error then
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;
if Nkind (P) = N_Attribute_Definition_Clause then
if Is_Entity_Name (Name (P)) then
Set_Error_Posted (Entity (Name (P)));
end if;
end if;
end if;
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;
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id) return Boolean
is
begin
if Debug_Flag_OO then
return False;
elsif Msg = "atomic access to & cannot be guaranteed"
and then Is_Type (E)
and then Is_Atomic (E)
and then No (Get_Rep_Pragma (E, Name_Atomic))
then
return True;
elsif Msg = "size for& too small, minimum allowed is ^"
and then Is_Frozen (E)
and then Serious_Errors_Detected > 0
and then Nkind (N) /= N_Component_Clause
and then Nkind (Parent (N)) /= N_Component_Clause
and then
No (Get_Attribute_Definition_Clause (E, Attribute_Size))
and then
No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
and then
No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
then
return True;
else
return False;
end if;
end Special_Msg_Delete;
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;
procedure VMS_Convert is
P : Natural;
L : Natural;
N : Natural;
begin
if not OpenVMS then
return;
end if;
P := Msg_Buffer'First;
loop
if P >= Msglen then
return;
end if;
if Msg_Buffer (P) = '-' then
for G in Gnames'Range loop
L := Gnames (G)'Length;
if P + L + 7 <= Msglen
and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all
and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch"
then
N := Vnames (G)'Length;
Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) :=
Msg_Buffer (P + L + 8 .. Msglen);
Msg_Buffer (P) := '/';
Msg_Buffer (P + 1 .. P + N) := Vnames (G).all;
Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier";
P := P + N + 10;
Msglen := Msglen + N - L + 3;
exit;
end if;
end loop;
end if;
P := P + 1;
end loop;
end VMS_Convert;
end Errout;