-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, 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- --
with Debug; use Debug;
with Einfo; use Einfo;
with Erroutc; use Erroutc;
-with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
-with Hostparm; use Hostparm;
with Lib; use Lib;
with Opt; use Opt;
with Nlists; use Nlists;
Finalize_Called : Boolean := False;
-- Set True if the Finalize routine has been called
+ Record_Compilation_Errors : Boolean := False;
+ -- Record that a compilation error was witnessed during a given phase of
+ -- analysis for gnat2why. This is needed as Warning_Mode is modified twice
+ -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable
+ -- value for each phase of analysis separately. This is updated at each
+ -- call to Compilation_Errors.
+
Warn_On_Instance : Boolean;
-- Flag set true for warning message to be posted on instance
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
- Msg_Cont : Boolean);
+ Msg_Cont : Boolean;
+ Node : Node_Id);
-- This is the low level routine used to post messages after dealing with
-- the issue of messages placed on instantiations (which get broken up
-- into separate calls in Error_Msg). Sptr is the location on which the
-- copy. So typically we can see Optr pointing to the template location
-- in an instantiation copy when Sptr points to the source location of
-- the actual instantiation (i.e the line with the new). Msg_Cont is
- -- set true if this is a continuation message.
+ -- set true if this is a continuation message. Node is the relevant
+ -- Node_Id for this message, to be used to compute the enclosing entity if
+ -- Opt.Include_Subprogram_In_Messages is set.
function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
-- Determines if warnings should be suppressed for the given node
-- variables Msg_Buffer are set on return Msglen.
procedure Set_Posted (N : Node_Id);
- -- Sets the Error_Posted flag on the given node, and all its parents
- -- that are subexpressions and then on the parent non-subexpression
- -- construct that contains the original expression (this reduces the
- -- number of cascaded messages). Note that this call only has an effect
- -- for a serious error. For a non-serious error, it has no effect.
+ -- Sets the Error_Posted flag on the given node, and all its parents that
+ -- are subexpressions and then on the parent non-subexpression construct
+ -- that contains the original expression. If that parent is a named
+ -- association, the flag is further propagated to its parent. This is done
+ -- in order to guard against cascaded errors. Note that this call has an
+ -- effect for a serious error only.
procedure Set_Qualification (N : Nat; E : Entity_Id);
-- Outputs up to N levels of qualification for the given entity. For
-- should have 'Class appended to its name (see Add_Class procedure), and
-- is otherwise unchanged.
- procedure VMS_Convert;
- -- This procedure has no effect if called when the host is not OpenVMS. If
- -- the host is indeed OpenVMS, then the error message stored in Msg_Buffer
- -- is scanned for appearances of switch names which need converting to
- -- corresponding VMS qualifier names. See Gnames/Vnames table in Errout
- -- spec for precise definition of the conversion that is performed by this
- -- routine in OpenVMS mode.
+ function Warn_Insertion return String;
+ -- This is called for warning messages only (so Warning_Msg_Char is set)
+ -- and returns a corresponding string to use at the beginning of generated
+ -- auxiliary messages, such as "in instantiation at ...".
+ -- 'a' .. 'z' returns "?x?"
+ -- 'A' .. 'Z' returns "?X?"
+ -- '*' returns "?*?"
+ -- '$' returns "?$?info: "
+ -- ' ' returns " "
+ -- No other settings are valid
-----------------------
-- Change_Error_Text --
begin
if not Finalize_Called then
raise Program_Error;
+
+ -- Record that a compilation error was witnessed during a given phase of
+ -- analysis for gnat2why. This is needed as Warning_Mode is modified
+ -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a
+ -- suitable value for each phase of analysis separately.
+
else
- return Erroutc.Compilation_Errors;
+ Record_Compilation_Errors :=
+ Record_Compilation_Errors or else Erroutc.Compilation_Errors;
+
+ return Record_Compilation_Errors;
end if;
end Compilation_Errors;
+ --------------------------------------
+ -- Delete_Warning_And_Continuations --
+ --------------------------------------
+
+ procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is
+ Id : Error_Msg_Id;
+
+ begin
+ pragma Assert (not Errors.Table (Msg).Msg_Cont);
+
+ Id := Msg;
+ loop
+ declare
+ M : Error_Msg_Object renames Errors.Table (Id);
+
+ begin
+ if not M.Deleted then
+ M.Deleted := True;
+ Warnings_Detected := Warnings_Detected - 1;
+
+ if M.Info then
+ Warning_Info_Messages := Warning_Info_Messages - 1;
+ end if;
+
+ if M.Warn_Err then
+ Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
+ end if;
+ end if;
+
+ Id := M.Next;
+ exit when Id = No_Error_Msg;
+ exit when not Errors.Table (Id).Msg_Cont;
+ end;
+ end loop;
+ end Delete_Warning_And_Continuations;
+
---------------
-- Error_Msg --
---------------
-- referencing the generic declaration.
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
+ begin
+ Error_Msg (Msg, Flag_Location, Current_Node);
+ end Error_Msg;
+
+ procedure Error_Msg
+ (Msg : String;
+ Flag_Location : Source_Ptr;
+ N : Node_Id)
+ is
Sindex : Source_File_Index;
-- Source index for flag location
-- template in instantiation case, otherwise unchanged).
begin
- -- It is a fatal error to issue an error message when scanning from the
- -- internal source buffer (see Sinput for further documentation)
-
- pragma Assert (Sinput.Source /= Internal_Source_Ptr);
-
-- Return if all errors are to be ignored
if Errors_Must_Be_Ignored then
end if;
-- If we already have messages, and we are trying to place a message at
- -- No_Location or in package Standard, then just ignore the attempt
- -- since we assume that what is happening is some cascaded junk. Note
- -- that this is safe in the sense that proceeding will surely bomb.
+ -- No_Location, then just ignore the attempt since we assume that what
+ -- is happening is some cascaded junk. Note that this is safe in the
+ -- sense that proceeding will surely bomb. We will also bomb if the flag
+ -- location is No_Location and we don't have any messages so far, but
+ -- that is a real bug and a legitimate bomb, so we go ahead.
- if Flag_Location < First_Source_Ptr
+ if Flag_Location = No_Location
and then Total_Errors_Detected > 0
then
return;
-- Start of processing for new message
Sindex := Get_Source_File_Index (Flag_Location);
- Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+ Prescan_Message (Msg);
Orig_Loc := Original_Location (Flag_Location);
-- If the current location is in an instantiation, the issue arises of
-- that style checks are not considered warning messages for this
-- purpose.
- if Is_Warning_Msg
- and then Warnings_Suppressed (Orig_Loc) /= No_String
+ if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
then
return;
-- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
- Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
+ Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N);
return;
end if;
-- or
- -- warning: in instantiation at
+ -- warning: in instantiation at ...
-- warning: original warning message
+ -- or
+
+ -- info: in instantiation at ...
+ -- info: original info message
+
-- All these messages are posted at the location of the top level
-- instantiation. If there are nested instantiations, then the
-- instantiation error message can be repeated, pointing to each
-- or
- -- warning: in inlined body at
+ -- warning: in inlined body at ...
-- warning: original warning message
+ -- or
+
+ -- info: in inlined body at ...
+ -- info: original info message
+
-- OK, here we have an instantiation error, and we need to generate the
-- error on the instantiation, rather than on the template.
-- Case of inlined body
if Inlined_Body (X) then
- if Is_Warning_Msg or else Is_Style_Msg then
+ if Is_Info_Msg then
+ Error_Msg_Internal
+ (Msg => "info: in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
+
+ elsif Is_Warning_Msg then
+ Error_Msg_Internal
+ (Msg => Warn_Insertion & "in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
+
+ elsif Is_Style_Msg then
Error_Msg_Internal
- ("?in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "style: in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
+
else
Error_Msg_Internal
- ("error in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "error in inlined body #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
end if;
-- Case of generic instantiation
else
- if Is_Warning_Msg or else Is_Style_Msg then
+ if Is_Info_Msg then
+ Error_Msg_Internal
+ (Msg => "info: in instantiation #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
+
+ elsif Is_Warning_Msg then
+ Error_Msg_Internal
+ (Msg => Warn_Insertion & "in instantiation #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
+
+ elsif Is_Style_Msg then
Error_Msg_Internal
- ("?in instantiation #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "style: in instantiation #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
+
else
Error_Msg_Internal
- ("instantiation error #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => "instantiation error #",
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
end if;
end if;
end if;
-- Here we output the original message on the outer instantiation
Error_Msg_Internal
- (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (Msg => Msg,
+ Sptr => Actual_Error_Loc,
+ Optr => Flag_Location,
+ Msg_Cont => Msg_Cont_Status,
+ Node => N);
end;
end Error_Msg;
-- Error_Msg_PT --
------------------
- procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is
+ procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id) is
begin
- Error_Msg_NE
- ("first formal of & must be of mode `OUT`, `IN OUT` or " &
- "access-to-variable", Typ, Subp);
Error_Msg_N
- ("\in order to be overridden by protected procedure or entry " &
- "(RM 9.4(11.9/2))", Typ);
+ ("illegal overriding of subprogram inherited from interface", E);
+
+ Error_Msg_Sloc := Sloc (Iface_Prim);
+
+ if Ekind (E) = E_Function then
+ Error_Msg_N
+ ("\first formal of & declared # must be of mode `IN` "
+ & "or access-to-constant", E);
+ else
+ Error_Msg_N
+ ("\first formal of & declared # must be of mode `OUT`, `IN OUT` "
+ & "or access-to-variable", E);
+ end if;
end Error_Msg_PT;
-----------------
(Msg : String;
Sptr : Source_Ptr;
Optr : Source_Ptr;
- Msg_Cont : Boolean)
+ Msg_Cont : Boolean;
+ Node : Node_Id)
is
Next_Msg : Error_Msg_Id;
-- Pointer to next message at insertion point
end if;
-- Set the fatal error flag in the unit table unless we are in
- -- Try_Semantics mode. This stops the semantics from being performed
+ -- Try_Semantics mode (in which case we set ignored mode if not
+ -- currently set. This stops the semantics from being performed
-- if we find a serious error. This is skipped if we are currently
-- dealing with the configuration pragma file.
- if not Try_Semantics and then Current_Source_Unit /= No_Unit then
- Set_Fatal_Error (Get_Source_Unit (Sptr));
+ if Current_Source_Unit /= No_Unit then
+ declare
+ U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
+ begin
+ if Try_Semantics then
+ if Fatal_Error (U) = None then
+ Set_Fatal_Error (U, Error_Ignored);
+ end if;
+ else
+ Set_Fatal_Error (U, Error_Detected);
+ end if;
+ end;
end if;
end Handle_Serious_Error;
Continuation_New_Line := False;
Suppress_Message := False;
Kill_Message := False;
- Warning_Msg_Char := ' ';
Set_Msg_Text (Msg, Sptr);
-- Kill continuation if parent message killed
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Warn => Is_Warning_Msg,
+ Info => Is_Info_Msg,
+ Check => Is_Check_Msg,
Warn_Err => False, -- reset below
Warn_Chr => Warning_Msg_Char,
Style => Is_Style_Msg,
Serious => Is_Serious_Error,
Uncond => Is_Unconditional_Msg,
Msg_Cont => Continuation,
- Deleted => False));
+ Deleted => False,
+ Node => Node));
Cur_Msg := Errors.Last;
-- Test if warning to be treated as error
exit when
Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
- if 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);
+ or else (Sptr = Errors.Table (Next_Msg).Sptr
+ and then Optr < Errors.Table (Next_Msg).Optr);
end if;
Prev_Msg := Next_Msg;
end loop;
end if;
- -- Now we insert the new message in the error chain. The insertion
- -- point for the message is after Prev_Msg and before Next_Msg.
+ -- Now we insert the new message in the error chain.
-- The possible insertion point for the new message is after Prev_Msg
-- and before Next_Msg. However, this is where we do a special check
and then not All_Errors_Mode
then
-- Don't delete unconditional messages and at this stage, don't
- -- delete continuation lines (we attempted to delete those earlier
+ -- delete continuation lines; we attempted to delete those earlier
-- if the parent message was deleted.
if not Errors.Table (Cur_Msg).Uncond
-- All tests passed, delete the message by simply returning
-- without any further processing.
- if not Continuation then
- Last_Killed := True;
- end if;
+ pragma Assert (not Continuation);
+ Last_Killed := True;
return;
end if;
end if;
end if;
end if;
- -- Bump appropriate statistics count
+ -- Bump appropriate statistics counts
+
+ if Errors.Table (Cur_Msg).Info then
+
+ -- Could be (usually is) both "info" and "warning"
+
+ if Errors.Table (Cur_Msg).Warn then
+ Warning_Info_Messages := Warning_Info_Messages + 1;
+ Warnings_Detected := Warnings_Detected + 1;
+ else
+ Report_Info_Messages := Report_Info_Messages + 1;
+ end if;
- if Errors.Table (Cur_Msg).Warn or else Errors.Table (Cur_Msg).Style then
+ elsif Errors.Table (Cur_Msg).Warn
+ or else Errors.Table (Cur_Msg).Style
+ then
Warnings_Detected := Warnings_Detected + 1;
+ elsif Errors.Table (Cur_Msg).Check then
+ Check_Messages := Check_Messages + 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;
+
+ -- If not serious error, set Fatal_Error to indicate ignored error
+
+ else
+ declare
+ U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
+ begin
+ if Fatal_Error (U) = None then
+ Set_Fatal_Error (U, Error_Ignored);
+ end if;
+ end;
end if;
end if;
+ -- Record warning message issued
+
+ if Errors.Table (Cur_Msg).Warn
+ and then not Errors.Table (Cur_Msg).Msg_Cont
+ then
+ Warning_Msg := Cur_Msg;
+ end if;
+
-- If too many warnings turn off warnings
if Maximum_Messages /= 0 then
return;
end if;
- Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+ Prescan_Message (Msg);
-- Special handling for warning messages
then
Debug_Output (N);
Error_Msg_Node_1 := E;
- Error_Msg (Msg, Flag_Location);
+ Error_Msg (Msg, Flag_Location, N);
else
Last_Killed := True;
end if;
- if not (Is_Warning_Msg or Is_Style_Msg) then
- Set_Posted (N);
- end if;
+ Set_Posted (N);
end Error_Msg_NEL;
------------------
F : Error_Msg_Id;
procedure Delete_Warning (E : Error_Msg_Id);
- -- Delete a message if not already deleted and adjust warning count
+ -- Delete a warning msg if not already deleted and adjust warning count
--------------------
-- Delete_Warning --
if not Errors.Table (E).Deleted then
Errors.Table (E).Deleted := True;
Warnings_Detected := Warnings_Detected - 1;
+
+ if Errors.Table (E).Info then
+ Warning_Info_Messages := Warning_Info_Messages - 1;
+ end if;
end if;
end Delete_Warning;
- -- Start of message for Finalize
+ -- Start of processing for Finalize
begin
-- Set Prev pointers
Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
declare
- CE : Error_Msg_Object renames Errors.Table (Cur);
+ CE : Error_Msg_Object renames Errors.Table (Cur);
+ Tag : constant String := Get_Warning_Tag (Cur);
begin
if (CE.Warn and not CE.Deleted)
- and then (Warning_Specifically_Suppressed (CE.Sptr, CE.Text) /=
+ and then
+ (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
No_String
- or else
- Warning_Specifically_Suppressed (CE.Optr, CE.Text) /=
+ or else
+ Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
No_String)
then
Delete_Warning (Cur);
- -- If this is a continuation, delete previous messages
+ -- If this is a continuation, delete previous parts of message
F := Cur;
while Errors.Table (F).Msg_Cont loop
F := Errors.Table (F).Prev;
+ exit when F = No_Error_Msg;
Delete_Warning (F);
end loop;
Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_Errors_Detected := 0;
- Warnings_Treated_As_Errors := 0;
- Warnings_Detected := 0;
- Warnings_As_Errors_Count := 0;
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
+ -- Reset counts for warnings
+
+ Reset_Warnings;
+
-- Initialize warnings tables
Warnings.Init;
begin
-- Extra blank line if error messages or source listing were output
- if Total_Errors_Detected + Warnings_Detected > 0
- or else Full_List
+ if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List
then
Write_Eol;
end if;
-- This normally goes to Standard_Output. The exception is when brief
-- mode is not set, verbose mode (or full list mode) is set, and
-- there are errors. In this case we send the message to standard
- -- error to make sure that *something* appears on standard error in
- -- an error situation.
-
- -- Formerly, only the "# errors" suffix was sent to stderr, whereas
- -- "# lines:" appeared on stdout. This caused problems on VMS when
- -- the stdout buffer was flushed, giving an extra line feed after
- -- the prefix.
+ -- error to make sure that *something* appears on standard error
+ -- in an error situation.
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
-- the Main_Source line is unknown (this happens in error situations,
-- e.g. when integrated preprocessing fails).
- if Main_Source_File /= No_Source_File then
+ if Main_Source_File > No_Source_File then
Write_Str (" ");
Write_Int (Num_Source_Lines (Main_Source_File));
Write_Str (" errors");
end if;
- if Warnings_Detected /= 0 then
+ if Warnings_Detected - Warning_Info_Messages /= 0 then
Write_Str (", ");
Write_Int (Warnings_Detected);
Write_Str (" warning");
- if Warnings_Detected /= 1 then
+ if Warnings_Detected - Warning_Info_Messages /= 1 then
Write_Char ('s');
end if;
end if;
end if;
+ if Warning_Info_Messages + Report_Info_Messages /= 0 then
+ Write_Str (", ");
+ Write_Int (Warning_Info_Messages + Report_Info_Messages);
+ Write_Str (" info message");
+
+ if Warning_Info_Messages + Report_Info_Messages > 1 then
+ Write_Char ('s');
+ end if;
+ end if;
+
Write_Eol;
Set_Standard_Output;
end Write_Error_Summary;
Write_Name (Full_File_Name (Sfile));
if not Debug_Flag_7 then
- Write_Str (" (source file time stamp: ");
+ Write_Eol;
+ Write_Str ("Source file time stamp: ");
Write_Time_Stamp (Sfile);
- Write_Char (')');
+ Write_Eol;
+ Write_Str ("Compiled at: " & Compilation_Time);
end if;
Write_Eol;
-- Source_Reference. This ensures outputting the proper name of
-- the source file in this situation.
- if Main_Source_File = No_Source_File
+ if Main_Source_File <= No_Source_File
or else Num_SRef_Pragmas (Main_Source_File) /= 0
then
Current_Error_Source_File := No_Source_File;
and then
(No (Cunit_Entity (U))
- or else Comes_From_Source (Cunit_Entity (U))
- or else not Is_Subprogram (Cunit_Entity (U)))
+ or else Comes_From_Source (Cunit_Entity (U))
+ or else not Is_Subprogram (Cunit_Entity (U)))
+
+ -- If the compilation unit associated with this unit does not
+ -- come from source, it means it is an instantiation that should
+ -- not be included in the source listing.
+
+ and then Comes_From_Source (Cunit (U))
then
declare
Sfile : constant Source_File_Index := Source_Index (U);
-- Only write the header if Sfile is known
- if Sfile /= No_Source_File then
+ if Sfile > No_Source_File then
Write_Header (Sfile);
Write_Eol;
end if;
-- Only output the listing if Sfile is known, to avoid
-- crashing the compiler.
- if Sfile /= No_Source_File then
+ if Sfile > No_Source_File then
for N in 1 .. Last_Source_Line (Sfile) loop
while E /= No_Error_Msg
and then Errors.Table (E).Deleted
Err_Flag :=
E /= No_Error_Msg
- and then Errors.Table (E).Line = N
- and then Errors.Table (E).Sfile = Sfile;
+ and then Errors.Table (E).Line = N
+ and then Errors.Table (E).Sfile = Sfile;
Output_Source_Line (N, Sfile, Err_Flag);
-- Output the header only when Main_Source_File is known
- if Main_Source_File /= No_Source_File then
+ if Main_Source_File > No_Source_File then
Write_Header (Main_Source_File);
end if;
Write_Max_Errors;
+ -- Even though Warning_Info_Messages are a subclass of warnings, they
+ -- must not be treated as errors when -gnatwe is in effect.
+
if Warning_Mode = Treat_As_Error then
- Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
- Warnings_Detected := 0;
+ Total_Errors_Detected :=
+ Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages;
+ Warnings_Detected := Warning_Info_Messages;
end if;
end Output_Messages;
and then not Errors.Table (E).Uncond
then
Warnings_Detected := Warnings_Detected - 1;
+
+ if Errors.Table (E).Info then
+ Warning_Info_Messages := Warning_Info_Messages - 1;
+ end if;
+
return True;
-- No removal required
end loop;
if Nkind (N) = N_Raise_Constraint_Error
- and then Original_Node (N) /= N
+ and then Is_Rewrite_Substitution (N)
and then No (Condition (N))
then
-- Warnings may have been posted on subexpressions of the original
end if;
end Remove_Warning_Messages;
+ --------------------
+ -- Reset_Warnings --
+ --------------------
+
+ procedure Reset_Warnings is
+ begin
+ Warnings_Treated_As_Errors := 0;
+ Warnings_Detected := 0;
+ Warning_Info_Messages := 0;
+ Warnings_As_Errors_Count := 0;
+ end Reset_Warnings;
+
+ ----------------------
+ -- Adjust_Name_Case --
+ ----------------------
+
+ procedure Adjust_Name_Case
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr)
+ is
+ begin
+ -- We have an all lower case name from Namet, and now we want to set
+ -- the appropriate case. If possible we copy the actual casing from
+ -- the source. If not we use standard identifier casing.
+
+ declare
+ Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc);
+ Sbuffer : Source_Buffer_Ptr;
+ Ref_Ptr : Integer;
+ Src_Ptr : Source_Ptr;
+
+ begin
+ Ref_Ptr := 1;
+ Src_Ptr := Loc;
+
+ -- For standard locations, always use mixed case
+
+ if Loc <= No_Location then
+ Set_Casing (Mixed_Case);
+
+ else
+ -- Determine if the reference we are dealing with corresponds to
+ -- text at the point of the error reference. This will often be
+ -- the case for simple identifier references, and is the case
+ -- where we can copy the casing from the source.
+
+ Sbuffer := Source_Text (Src_Ind);
+
+ while Ref_Ptr <= Buf.Length loop
+ exit when
+ Fold_Lower (Sbuffer (Src_Ptr)) /=
+ Fold_Lower (Buf.Chars (Ref_Ptr));
+ Ref_Ptr := Ref_Ptr + 1;
+ Src_Ptr := Src_Ptr + 1;
+ end loop;
+
+ -- If we get through the loop without a mismatch, then output the
+ -- name the way it is cased in the source program
+
+ if Ref_Ptr > Buf.Length then
+ Src_Ptr := Loc;
+
+ for J in 1 .. Buf.Length loop
+ Buf.Chars (J) := Sbuffer (Src_Ptr);
+ Src_Ptr := Src_Ptr + 1;
+ end loop;
+
+ -- Otherwise set the casing using the default identifier casing
+
+ else
+ Set_Casing (Buf, Identifier_Casing (Src_Ind));
+ end if;
+ end if;
+ end;
+ end Adjust_Name_Case;
+
+ procedure Adjust_Name_Case (Loc : Source_Ptr) is
+ begin
+ Adjust_Name_Case (Global_Name_Buffer, Loc);
+ end Adjust_Name_Case;
+
---------------------------
-- Set_Identifier_Casing --
---------------------------
-- Loop through file names to find matching one. This is a bit slow, but
-- we only do it in error situations so it is not so terrible. Note that
-- if the loop does not exit, then the desired case will be left set to
- -- Mixed_Case, this can happen if the name was not in canonical form,
- -- and gets canonicalized on VMS. Possibly we could fix this by
- -- unconditionally canonicalizing these names ???
+ -- Mixed_Case, this can happen if the name was not in canonical form.
for J in 1 .. Last_Source_File loop
Get_Name_String (Full_Debug_Name (J));
-- Types in other language defined units are displayed as
-- "package-name.type-name"
- elsif
- Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent)))
- then
+ elsif Is_Predefined_Unit (Get_Source_Unit (Ent)) then
Get_Unqualified_Decoded_Name_String
(Unit_Name (Get_Source_Unit (Ent)));
Name_Len := Name_Len - 2;
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)))
+ not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1))
then
+ Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)));
Set_Msg_Str (" defined");
Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
------------------
procedure Set_Msg_Node (Node : Node_Id) is
+ Loc : Source_Ptr;
Ent : Entity_Id;
Nam : Name_Id;
Set_Msg_Node (Defining_Identifier (Node));
return;
- when N_Selected_Component | N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Set_Msg_Node (Prefix (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Selector_Name (Node));
if Nkind (Node) = N_Pragma then
Nam := Pragma_Name (Node);
+ Loc := Sloc (Node);
+
+ -- The other cases have Chars fields
- -- The other cases have Chars fields, and we want to test for possible
- -- internal names, which generally represent something gone wrong. An
- -- exception is the case of internal type names, where we try to find a
- -- reasonable external representation for the external name
+ -- First deal with internal names, which generally represent something
+ -- gone wrong. First attempt: if this is a rewritten node that rewrites
+ -- something with a Chars field that is not an internal name, use that.
+
+ elsif Is_Internal_Name (Chars (Node))
+ and then Nkind (Original_Node (Node)) in N_Has_Chars
+ and then not Is_Internal_Name (Chars (Original_Node (Node)))
+ then
+ Nam := Chars (Original_Node (Node));
+ Loc := Sloc (Original_Node (Node));
+
+ -- Another shot for internal names, in the case of internal type names,
+ -- we try to find a reasonable representation for the external name.
elsif 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)))
+ 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);
Ent := Node;
end if;
+ Loc := Sloc (Ent);
+
-- If the type is the designated type of an access_to_subprogram,
-- then there is no name to provide in the call.
Nam := Chars (Ent);
end if;
- -- If not internal name, just use name in Chars field
+ -- If not internal name, or if we could not find a reasonable possible
+ -- substitution for the internal name, just use name in Chars field.
else
Nam := Chars (Node);
+ Loc := Sloc (Node);
end if;
-- At this stage, the name to output is in Nam
Get_Unqualified_Decoded_Name_String (Nam);
-- Remove trailing upper case letters from the name (useful for
- -- dealing with some cases of internal names.
+ -- dealing with some cases of internal names).
while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
Name_Len := Name_Len - 1;
Kill_Message := True;
end if;
- -- Now we have to set the proper case. If we have a source location
- -- then do a check to see if the name in the source is the same name
- -- as the name in the Names table, except for possible differences
- -- in case, which is the case when we can copy from the source.
+ -- If we still have an internal name, kill the message (will only
+ -- work if we already had errors!)
- declare
- Src_Loc : constant Source_Ptr := Sloc (Node);
- Sbuffer : Source_Buffer_Ptr;
- Ref_Ptr : Integer;
- Src_Ptr : Source_Ptr;
-
- begin
- Ref_Ptr := 1;
- Src_Ptr := Src_Loc;
-
- -- For standard locations, always use mixed case
-
- if Src_Loc <= No_Location
- or else Sloc (Node) <= No_Location
- then
- Set_Casing (Mixed_Case);
-
- else
- -- Determine if the reference we are dealing with corresponds to
- -- text at the point of the error reference. This will often be
- -- the case for simple identifier references, and is the case
- -- where we can copy the spelling from the source.
-
- 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 we get through the loop without a mismatch, then output the
- -- name the way it is spelled in the source program
-
- 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;
-
- -- Otherwise set the casing using the default identifier casing
-
- else
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
- end if;
- end if;
- end;
+ if Is_Internal_Name then
+ Kill_Message := True;
+ end if;
+ -- Remaining step is to adjust casing and possibly add 'Class
+ Adjust_Name_Case (Global_Name_Buffer, Loc);
Set_Msg_Name_Buffer;
Add_Class;
end Set_Msg_Node;
C : Character; -- Current character
P : Natural; -- Current index;
- procedure Set_Msg_Insertion_Warning (C : Character);
- -- Deal with ? ?? ?x? ?X? insertion sequences (also < << <x< <X<). The
- -- caller has already bumped the pointer past the initial ? or < and C
- -- is set to this initial character (? or <).
+ procedure Skip_Msg_Insertion_Warning (C : Character);
+ -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
+ -- sequences using < instead of ?). The caller has already bumped
+ -- the pointer past the initial ? or < and C is set to this initial
+ -- character (? or <). This procedure skips past the rest of the
+ -- sequence. We do not need to set Msg_Insertion_Char, since this
+ -- was already done during the message prescan.
- -------------------------------
- -- Set_Msg_Insertion_Warning --
- -------------------------------
+ --------------------------------
+ -- Skip_Msg_Insertion_Warning --
+ --------------------------------
- procedure Set_Msg_Insertion_Warning (C : Character) is
+ procedure Skip_Msg_Insertion_Warning (C : Character) is
begin
if P <= Text'Last and then Text (P) = C then
- Warning_Msg_Char := '?';
P := P + 1;
elsif P + 1 <= Text'Last
or else
Text (P) in 'A' .. 'Z'
or else
- Text (P) = '*')
+ Text (P) = '*'
+ or else
+ Text (P) = '$')
and then Text (P + 1) = C
then
- Warning_Msg_Char := Text (P);
P := P + 2;
- else
- Warning_Msg_Char := ' ';
end if;
- end Set_Msg_Insertion_Warning;
+ end Skip_Msg_Insertion_Warning;
-- Start of processing for Set_Msg_Text
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
- P := Text'First;
+ -- Skip info: at start, we have recorded this in Is_Info_Msg, and this
+ -- will be used (Info field in error message object) to put back the
+ -- string when it is printed. We need to do this, or we get confused
+ -- with instantiation continuations.
+
+ if Text'Length > 6
+ and then Text (Text'First .. Text'First + 5) = "info: "
+ then
+ P := Text'First + 6;
+ else
+ P := Text'First;
+ end if;
+
+ -- Loop through characters of message
+
while P <= Text'Last loop
C := Text (P);
P := P + 1;
when '\' =>
Continuation := True;
- if Text (P) = '\' then
+ if P <= Text'Last and then Text (P) = '\' then
Continuation_New_Line := True;
P := P + 1;
end if;
null; -- already dealt with
when '?' =>
- Set_Msg_Insertion_Warning ('?');
+ Skip_Msg_Insertion_Warning ('?');
when '<' =>
-
- -- Note: the prescan already set Is_Warning_Msg True if and
- -- only if Error_Msg_Warn is set to True. If Error_Msg_Warn
- -- is False, the call to Set_Msg_Insertion_Warning here does
- -- no harm, since Warning_Msg_Char is ignored in that case.
-
- Set_Msg_Insertion_Warning ('<');
+ Skip_Msg_Insertion_Warning ('<');
when '|' =>
null; -- already dealt with
-- '[' (will be/would have been raised at run time)
when '[' =>
+
+ -- Switch the message from a warning to an error if the flag
+ -- -gnatwE is specified to treat run-time exception warnings
+ -- as errors.
+
+ if Is_Warning_Msg
+ and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
+ then
+ Is_Warning_Msg := False;
+ end if;
+
if Is_Warning_Msg then
Set_Msg_Str ("will be raised at run time");
else
Set_Msg_Char (C);
end case;
end loop;
-
- VMS_Convert;
end Set_Msg_Text;
----------------
exit when Nkind (P) not in N_Subexpr;
end loop;
+ if Nkind_In (P, N_Pragma_Argument_Association,
+ N_Component_Association,
+ N_Discriminant_Association,
+ N_Generic_Association,
+ N_Parameter_Association)
+ then
+ Set_Error_Posted (Parent (P));
+ end if;
+
-- A special check, if we just posted an error on an attribute
-- definition clause, then also set the entity involved as posted.
-- For example, this stops complaining about the alignment after
return True;
end if;
+ -- Similar processing for "volatile full access cannot be guaranteed"
+
+ elsif Msg = "volatile full access to & cannot be guaranteed" then
+ if Is_Type (E)
+ and then Is_Volatile_Full_Access (E)
+ and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access))
+ then
+ return True;
+ end if;
+
-- Processing for "Size too small" messages
elsif Msg = "size for& too small, minimum allowed is ^" then
return False;
end Special_Msg_Delete;
+ -----------------
+ -- SPARK_Msg_N --
+ -----------------
+
+ procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
+ begin
+ if SPARK_Mode /= Off then
+ Error_Msg_N (Msg, N);
+ end if;
+ end SPARK_Msg_N;
+
+ ------------------
+ -- SPARK_Msg_NE --
+ ------------------
+
+ procedure SPARK_Msg_NE
+ (Msg : String;
+ N : Node_Or_Entity_Id;
+ E : Node_Or_Entity_Id)
+ is
+ begin
+ if SPARK_Mode /= Off then
+ Error_Msg_NE (Msg, N, E);
+ end if;
+ end SPARK_Msg_NE;
+
--------------------------
-- Unwind_Internal_Type --
--------------------------
end if;
end Unwind_Internal_Type;
- -----------------
- -- VMS_Convert --
- -----------------
-
- procedure VMS_Convert is
- P : Natural;
- L : Natural;
- N : Natural;
+ --------------------
+ -- Warn_Insertion --
+ --------------------
+ function Warn_Insertion return String is
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;
+ case Warning_Msg_Char is
+ when '?' =>
+ return "??";
- -- See if we have "-ggg switch", where ggg is Gnames entry
+ when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
+ return '?' & Warning_Msg_Char & '?';
- 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
- -- Replace by "/vvv qualifier", where vvv is Vnames entry
-
- 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;
+ when ' ' =>
+ return "?";
- P := P + 1;
- end loop;
- end VMS_Convert;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Warn_Insertion;
end Errout;
projects / gcc.git / blobdiff