-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, 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- --
-- --
------------------------------------------------------------------------------
--- Warning! Error messages can be generated during Gigi processing by direct
+-- Warning: Error messages can be generated during Gigi processing by direct
-- calls to error message routines, so it is essential that the processing
-- in this body be consistent with the requirements for the Gigi processing
-- environment, and that in particular, no disallowed table expansion is
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
-- parameter Suffix, (spec) or (body) is appended after the unit name.
procedure Set_Msg_Node (Node : Node_Id);
- -- Add the sequence of characters for the name associated with the
- -- given node to the current message.
+ -- Add the sequence of characters for the name associated with the given
+ -- node to the current message. For N_Designator, N_Selected_Component,
+ -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is
+ -- included as well.
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
-- Add a sequence of characters to the current message. The characters may
-- be one of the special insertion characters (see documentation in spec).
-- Flag is the location at which the error is to be posted, which is used
-- to determine whether or not the # insertion needs a file name. The
- -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
- -- Is_Unconditional_Msg are set on return.
+ -- 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_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) then
+ if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
+ then
return;
-- For style messages, check too many messages so far
-- 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
- ("?in inlined body #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (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
+ (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
- ("?in instantiation #",
- Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ (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
+ (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_Ada_2012_Feature --
+ --------------------------------
+
+ procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr) is
+ begin
+ if Ada_Version < Ada_2012 then
+ Error_Msg (Feature & " is an Ada 2012 feature", Loc);
+
+ if No (Ada_Version_Pragma) then
+ Error_Msg ("\unit must be compiled with -gnat2012 switch", Loc);
+ else
+ Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
+ Error_Msg ("\incompatible with Ada version set#", Loc);
+ end if;
+ end if;
+ end Error_Msg_Ada_2012_Feature;
+
------------------
-- Error_Msg_AP --
------------------
-- 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 message below needs rewording (remember comma in -gnatj
- -- mode) ???
-
- 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
Temp_Msg : Error_Msg_Id;
+ Warn_Err : Boolean;
+ -- Set if warning to be treated as error
+
procedure Handle_Serious_Error;
-- Internal procedure to do all error message handling for a serious
-- error message, other than bumping the error counts and arranging
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;
if Suppress_Message
and then not All_Errors_Mode
and then not Is_Warning_Msg
- and then Msg (Msg'Last) /= '!'
+ and then not Is_Unconditional_Msg
then
if not Continuation then
Last_Killed := True;
-- Immediate return if warning message and warnings are suppressed
- if Warnings_Suppressed (Optr) or else Warnings_Suppressed (Sptr) then
+ if Warnings_Suppressed (Optr) /= No_String
+ or else
+ Warnings_Suppressed (Sptr) /= No_String
+ then
Cur_Msg := No_Error_Msg;
return;
end if;
elsif Debug_Flag_GG then
null;
- -- Keep warning if message text ends in !!
+ -- Keep warning if message text contains !!
- elsif Msg (Msg'Last) = '!' and then Msg (Msg'Last - 1) = '!' then
+ elsif Has_Double_Exclam then
null;
-- Here is where we delete a warning from a with'ed unit
-- with a comma space separator (eliminating a possible (style) or
-- info prefix).
- if Error_Msg_Line_Length /= 0
- and then Continuation
- then
+ if Error_Msg_Line_Length /= 0 and then Continuation then
Cur_Msg := Errors.Last;
declare
Msg_Buffer (M .. Msglen);
Newl := Newl + Msglen - M + 1;
Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
+
+ -- Update warning msg flag and message doc char if needed
+
+ if Is_Warning_Msg then
+ if not Errors.Table (Cur_Msg).Warn then
+ Errors.Table (Cur_Msg).Warn := True;
+ Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
+
+ elsif Warning_Msg_Char /= ' ' then
+ Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
+ end if;
+ end if;
end;
return;
end if;
- -- Otherwise build error message object for new message
+ -- Here we build a new error object
Errors.Append
((Text => new String'(Msg_Buffer (1 .. Msglen)),
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
+
+ Warn_Err :=
+ Is_Warning_Msg
+ and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
+ or else
+ Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
+
+ -- Propagate Warn_Err to this message and preceding continuations
+
+ for J in reverse 1 .. Errors.Last loop
+ Errors.Table (J).Warn_Err := Warn_Err;
+ exit when not Errors.Table (J).Msg_Cont;
+ end loop;
+
-- If immediate errors mode set, output error message now. Also output
-- now if the -d1 debug flag is set (so node number message comes out
-- just before actual error message)
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_Msg (Msg);
+ Prescan_Message (Msg);
-- Special handling for warning messages
-- Test for message to be output
if All_Errors_Mode
- or else Msg (Msg'Last) = '!'
+ or else Is_Unconditional_Msg
or else Is_Warning_Msg
or else OK_Node (N)
or else (Msg (Msg'First) = '\' and then not Last_Killed)
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
- if not Errors.Table (Cur).Deleted
- and then Warning_Specifically_Suppressed
- (Errors.Table (Cur).Sptr, Errors.Table (Cur).Text)
- then
- Delete_Warning (Cur);
+ declare
+ CE : Error_Msg_Object renames Errors.Table (Cur);
+ Tag : constant String := Get_Warning_Tag (Cur);
- -- If this is a continuation, delete previous messages
+ begin
+ if (CE.Warn and not CE.Deleted)
+ and then
+ (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
+ No_String
+ or else
+ Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
+ No_String)
+ then
+ Delete_Warning (Cur);
- F := Cur;
- while Errors.Table (F).Msg_Cont loop
- F := Errors.Table (F).Prev;
- Delete_Warning (F);
- end loop;
+ -- If this is a continuation, delete previous parts of message
- -- Delete any following continuations
+ 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;
- F := Cur;
- loop
- F := Errors.Table (F).Next;
- exit when F = No_Error_Msg;
- exit when not Errors.Table (F).Msg_Cont;
- Delete_Warning (F);
- end loop;
- end if;
+ -- Delete any following continuations
+
+ F := Cur;
+ loop
+ F := Errors.Table (F).Next;
+ exit when F = No_Error_Msg;
+ exit when not Errors.Table (F).Msg_Cont;
+ Delete_Warning (F);
+ end loop;
+ end if;
+ end;
Cur := Errors.Table (Cur).Next;
end loop;
return S;
end First_Sloc;
+ -----------------------
+ -- Get_Ignore_Errors --
+ -----------------------
+
+ function Get_Ignore_Errors return Boolean is
+ begin
+ return Errors_Must_Be_Ignored;
+ end Get_Ignore_Errors;
+
----------------
-- Initialize --
----------------
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;
- -- Initialize warnings table, if all warnings are suppressed, supply an
- -- initial dummy entry covering all possible source locations.
+ -- Reset counts for warnings
+
+ Reset_Warnings;
+
+ -- Initialize warnings tables
Warnings.Init;
Specific_Warnings.Init;
-
- if Warning_Mode = Suppress then
- Warnings.Append
- ((Start => Source_Ptr'First, Stop => Source_Ptr'Last));
- end if;
end Initialize;
-----------------
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
Set_Standard_Error;
end if;
- -- Message giving total number of lines
+ -- Message giving total number of lines. Don't give this message if
+ -- the Main_Source line is unknown (this happens in error situations,
+ -- e.g. when integrated preprocessing fails).
- Write_Str (" ");
- Write_Int (Num_Source_Lines (Main_Source_File));
+ if Main_Source_File > No_Source_File then
+ 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: ");
+ if Num_Source_Lines (Main_Source_File) = 1 then
+ Write_Str (" line: ");
+ else
+ Write_Str (" lines: ");
+ end if;
end if;
if Total_Errors_Detected = 0 then
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;
Write_Char (')');
+
+ elsif Warnings_Treated_As_Errors /= 0 then
+ Write_Str (" (");
+ Write_Int (Warnings_Treated_As_Errors);
+ Write_Str (" treated as errors)");
+ 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_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);
begin
Write_Eol;
- Write_Header (Sfile);
- Write_Eol;
+
+ -- Only write the header if Sfile is known
+
+ if Sfile > No_Source_File then
+ Write_Header (Sfile);
+ Write_Eol;
+ end if;
-- Normally, we don't want an "error messages from file"
-- message when listing the entire file, so we set the
Current_Error_Source_File := Sfile;
end if;
- for N in 1 .. Last_Source_Line (Sfile) loop
- while E /= No_Error_Msg
- and then Errors.Table (E).Deleted
- loop
- E := Errors.Table (E).Next;
- end loop;
+ -- Only output the listing if Sfile is known, to avoid
+ -- crashing the compiler.
+
+ 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
+ loop
+ E := Errors.Table (E).Next;
+ end loop;
- Err_Flag :=
- E /= No_Error_Msg
- and then Errors.Table (E).Line = N
- and then Errors.Table (E).Sfile = Sfile;
+ Err_Flag :=
+ E /= No_Error_Msg
+ and then Errors.Table (E).Line = N
+ and then Errors.Table (E).Sfile = Sfile;
- Output_Source_Line (N, Sfile, Err_Flag);
+ Output_Source_Line (N, Sfile, Err_Flag);
- if Err_Flag then
- Output_Error_Msgs (E);
+ if Err_Flag then
+ Output_Error_Msgs (E);
- if not Debug_Flag_2 then
- Write_Eol;
+ if not Debug_Flag_2 then
+ Write_Eol;
+ end if;
end if;
- end if;
- end loop;
+ end loop;
+ end if;
end;
end if;
end loop;
and then (not Full_List or else Full_List_File_Name /= null)
then
Write_Eol;
- Write_Header (Main_Source_File);
+
+ -- Output the header only when Main_Source_File is known
+
+ if Main_Source_File > No_Source_File then
+ Write_Header (Main_Source_File);
+ end if;
+
E := First_Error_Msg;
-- Loop through error lines
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));
Set_Msg_Blank;
Set_Msg_Str ("procedure name");
+ elsif Nkind (Error_Msg_Node_1) in N_Entity
+ and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type
+ then
+ Set_Msg_Blank;
+ Set_Msg_Str ("access to subprogram");
+
else
Set_Msg_Blank_Conditional;
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)))
+ and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
then
Set_Msg_Node (Error_Msg_Node_1);
-- 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;
+ Set_Msg_Blank_Conditional;
Set_Msg_Quote;
Set_Casing (Mixed_Case);
Set_Msg_Name_Buffer;
Set_Msg_Node (Ent);
Add_Class;
- -- If Ent is an anonymous subprogram type, there is no name to print,
- -- so remove enclosing quotes.
+ -- If we did not print a name (e.g. in the case of an anonymous
+ -- subprogram type), there is no name to print, so remove quotes.
- if Buffer_Ends_With ("""") then
- Buffer_Remove ("""");
+ if Buffer_Ends_With ('"') then
+ Buffer_Remove ('"');
else
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)))
+ 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);
if Sloc (Error_Msg_Node_1) > Standard_Location then
declare
Iloc : constant Source_Ptr :=
- Instantiation_Location (Sloc (Error_Msg_Node_1));
+ Instantiation_Location (Sloc (Error_Msg_Node_1));
begin
if Iloc /= No_Location
------------------
procedure Set_Msg_Node (Node : Node_Id) is
+ Loc : Source_Ptr;
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;
+ case Nkind (Node) is
+ when N_Designator =>
+ 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;
+ when N_Defining_Program_Unit_Name =>
+ 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;
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
+ Set_Msg_Node (Prefix (Node));
+ Set_Msg_Char ('.');
+ Set_Msg_Node (Selector_Name (Node));
+ return;
+
+ when others =>
+ null;
+ end case;
-- The only remaining possibilities are identifiers, defining
-- identifiers, pragmas, and pragma argument associations.
if Nkind (Node) = N_Pragma then
Nam := Pragma_Name (Node);
+ Loc := Sloc (Node);
- -- 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
+ -- The other cases have Chars fields
+
+ -- 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,
- -- there is no name to provide in the call.
+ -- then there is no name to provide in the call.
if Ekind (Ent) = E_Subprogram_Type then
return;
+
+ -- Otherwise, we will be able to find some kind of name to output
+
else
Unwind_Internal_Type (Ent);
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.
-
- 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;
+ -- If we still have an internal name, kill the message (will only
+ -- work if we already had errors!)
- -- 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 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.
+
+ --------------------------------
+ -- Skip_Msg_Insertion_Warning --
+ --------------------------------
+
+ procedure Skip_Msg_Insertion_Warning (C : Character) is
+ begin
+ if P <= Text'Last and then Text (P) = C then
+ P := P + 1;
+
+ elsif P + 1 <= Text'Last
+ and then (Text (P) in 'a' .. 'z'
+ or else
+ Text (P) in 'A' .. 'Z'
+ or else
+ Text (P) = '*'
+ or else
+ Text (P) = '$')
+ and then Text (P + 1) = C
+ then
+ P := P + 2;
+ end if;
+ end Skip_Msg_Insertion_Warning;
+
+ -- Start of processing for Set_Msg_Text
+
begin
Manual_Quote_Mode := False;
- Is_Unconditional_Msg := False;
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;
Set_Msg_Char ('"');
when '!' =>
- Is_Unconditional_Msg := True;
+ null; -- already dealt with
when '?' =>
- null; -- already dealt with
+ Skip_Msg_Insertion_Warning ('?');
when '<' =>
- null; -- already dealt with
+ Skip_Msg_Insertion_Warning ('<');
when '|' =>
null; -- already dealt with
Set_Msg_Char (C);
end if;
+ -- '[' (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_Str ("would have been raised at run time");
+ end if;
+
+ -- ']' (may be/might have been raised at run time)
+
+ when ']' =>
+ if Is_Warning_Msg then
+ Set_Msg_Str ("may be raised at run time");
+ else
+ Set_Msg_Str ("might have been raised at run time");
+ end if;
+
-- Normal character with no special treatment
when others =>
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
- -- Suppress "size too small" errors in CodePeer mode and ALFA mode,
- -- since pragma Pack is also ignored in these configurations.
+ -- Suppress "size too small" errors in CodePeer mode, since code may
+ -- be analyzed in a different configuration than the one used for
+ -- compilation. Even when the configurations match, this message
+ -- may be issued on correct code, because pragma Pack is ignored
+ -- in CodePeer mode.
- if CodePeer_Mode or ALFA_Mode then
+ if CodePeer_Mode then
return True;
-- When a size is wrong for a frozen type there is no explicit size
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 --
--------------------------
if Buffer_Ends_With ("type ") then
Buffer_Remove ("type ");
end if;
+ end if;
- if Is_Itype (Ent) then
- declare
- Assoc : constant Node_Id :=
- Associated_Node_For_Itype (Ent);
-
- begin
- if Nkind (Assoc) in N_Subprogram_Specification then
-
- -- Anonymous access to subprogram in a signature.
- -- Indicate the enclosing subprogram.
-
- Ent :=
- Defining_Unit_Name
- (Associated_Node_For_Itype (Ent));
- Set_Msg_Str
- ("access to subprogram declared in profile of ");
-
- else
- Set_Msg_Str ("access to subprogram with profile ");
- end if;
- end;
- end if;
-
- elsif Ekind (Ent) = E_Function then
+ if Ekind (Ent) = E_Function then
Set_Msg_Str ("access to function ");
- else
+ elsif Ekind (Ent) = E_Procedure then
Set_Msg_Str ("access to procedure ");
+ else
+ Set_Msg_Str ("access to subprogram");
end if;
exit Find;
-- but it makes too much noise to be accurate and add 'Base in all
-- cases. Note that we only do this is the first named subtype is not
-- itself an internal name. This avoids the obvious loop (subtype ->
- -- basetype -> subtype) which would otherwise occur!)
+ -- basetype -> subtype) which would otherwise occur).
else
declare
-- If we are stuck in a loop, get out and settle for the internal
-- name after all. In this case we set to kill the message if it is
-- not the first error message (we really try hard not to show the
- -- dirty laundry of the implementation to the poor user!)
+ -- dirty laundry of the implementation to the poor user).
if Ent = Old_Ent then
Kill_Message := True;
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;
+ case Warning_Msg_Char is
+ when '?' =>
+ return "??";
- P := Msg_Buffer'First;
- loop
- if P >= Msglen then
- return;
- end if;
+ when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
+ return '?' & Warning_Msg_Char & '?';
- if Msg_Buffer (P) = '-' then
- for G in Gnames'Range loop
- L := Gnames (G)'Length;
+ when ' ' =>
+ return "?";
- -- See if we have "-ggg switch", where ggg is Gnames entry
-
- 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;
-
- P := P + 1;
- end loop;
- end VMS_Convert;
+ when others =>
+ raise Program_Error;
+ end case;
+ end Warn_Insertion;
end Errout;
projects / gcc.git / blobdiff