[multiple changes]
2014-06-11 Geert Bosch <bosch@adacore.com> * s-exctab.adb: avoid race conditions in exception registration. 2014-06-11 Robert Dewar <dewar@adacore.com> * errout.adb (Warn_Insertion): New function. (Error_Msg): Use Warn_Insertion and Prescan_Message. (Error_Msg_Internal): Set Info field of error object. (Error_Msg_NEL): Use Prescan_Message. (Set_Msg_Text): Don't store info: at start of message. (Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning. (Skip_Msg_Insertion_Warning): Now just skips warning insertion. * errout.ads: Document new ?$? and >$> insertion sequences Document use of "(style)" and "info: " * erroutc.adb (dmsg): Print several missing fields (Get_Warning_Tag): Handle -gnatel case (?$?) (Output_Msg_Text): Deal with new tagging of info messages * erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object): Add field Info (Prescan_Message): New procedure, this procedure replaces the old Test_Style_Warning_Serious_Unconditional_Msg * errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb, sem_elab.adb: Follow new rules for info message (info belongs only at the start of a message, and only in the first message, not in any of the continuations). * gnat_ugn.texi: Document full set of warning tags. From-SVN: r211447
This commit is contained in:
Arnaud Charlet
parent
c230ed0b7e
commit
2e57f88b77
13 changed files with 586 additions and 296 deletions
|
|
@ -1,3 +1,30 @@
|
|||
2014-06-11 Geert Bosch <bosch@adacore.com>
|
||||
|
||||
* s-exctab.adb: avoid race conditions in exception registration.
|
||||
|
||||
2014-06-11 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* errout.adb (Warn_Insertion): New function.
|
||||
(Error_Msg): Use Warn_Insertion and Prescan_Message.
|
||||
(Error_Msg_Internal): Set Info field of error object.
|
||||
(Error_Msg_NEL): Use Prescan_Message.
|
||||
(Set_Msg_Text): Don't store info: at start of message.
|
||||
(Skip_Msg_Insertion_Warning): New name for Set_Msg_Insertion_Warning.
|
||||
(Skip_Msg_Insertion_Warning): Now just skips warning insertion.
|
||||
* errout.ads: Document new ?$? and >$> insertion sequences
|
||||
Document use of "(style)" and "info: "
|
||||
* erroutc.adb (dmsg): Print several missing fields
|
||||
(Get_Warning_Tag): Handle -gnatel case (?$?) (Output_Msg_Text):
|
||||
Deal with new tagging of info messages
|
||||
* erroutc.ads: Is_Info_Msg: New global (Error_Msg_Object):
|
||||
Add field Info (Prescan_Message): New procedure, this procedure
|
||||
replaces the old Test_Style_Warning_Serious_Unconditional_Msg
|
||||
* errutil.adb, exp_util.adb, par-ch7.adb, sem_ch13.adb, sem_ch7.adb,
|
||||
sem_elab.adb: Follow new rules for info message (info belongs
|
||||
only at the start of a message, and only in the first message,
|
||||
not in any of the continuations).
|
||||
* gnat_ugn.texi: Document full set of warning tags.
|
||||
|
||||
2014-06-11 Gary Dismukes <dismukes@adacore.com>
|
||||
|
||||
* sem_util.adb: Minor typo fix.
|
||||
|
|
|
|||
|
|
@ -197,6 +197,17 @@ package body Errout is
|
|||
-- 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 --
|
||||
-----------------------
|
||||
|
|
@ -282,7 +293,7 @@ package body Errout is
|
|||
-- 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
|
||||
|
|
@ -332,8 +343,7 @@ package body Errout is
|
|||
-- 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;
|
||||
|
||||
|
|
@ -438,9 +448,9 @@ package body Errout is
|
|||
-- Case of inlined body
|
||||
|
||||
if Inlined_Body (X) then
|
||||
if Is_Warning_Msg or else Is_Style_Msg then
|
||||
if Is_Warning_Msg or Is_Style_Msg then
|
||||
Error_Msg_Internal
|
||||
("?in inlined body #",
|
||||
(Warn_Insertion & "in inlined body #",
|
||||
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
|
||||
else
|
||||
Error_Msg_Internal
|
||||
|
|
@ -453,7 +463,7 @@ package body Errout is
|
|||
else
|
||||
if Is_Warning_Msg or else Is_Style_Msg then
|
||||
Error_Msg_Internal
|
||||
("?in instantiation #",
|
||||
(Warn_Insertion & "in instantiation #",
|
||||
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
|
||||
else
|
||||
Error_Msg_Internal
|
||||
|
|
@ -732,7 +742,6 @@ package body Errout is
|
|||
Continuation_New_Line := False;
|
||||
Suppress_Message := False;
|
||||
Kill_Message := False;
|
||||
Warning_Msg_Char := ' ';
|
||||
Set_Msg_Text (Msg, Sptr);
|
||||
|
||||
-- Kill continuation if parent message killed
|
||||
|
|
@ -944,6 +953,7 @@ package body Errout is
|
|||
Line => Get_Physical_Line_Number (Sptr),
|
||||
Col => Get_Column_Number (Sptr),
|
||||
Warn => Is_Warning_Msg,
|
||||
Info => Is_Info_Msg,
|
||||
Warn_Err => False, -- reset below
|
||||
Warn_Chr => Warning_Msg_Char,
|
||||
Style => Is_Style_Msg,
|
||||
|
|
@ -1159,7 +1169,7 @@ package body Errout is
|
|||
return;
|
||||
end if;
|
||||
|
||||
Test_Style_Warning_Serious_Unconditional_Msg (Msg);
|
||||
Prescan_Message (Msg);
|
||||
|
||||
-- Special handling for warning messages
|
||||
|
||||
|
|
@ -2745,19 +2755,21 @@ package body Errout is
|
|||
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
|
||||
|
|
@ -2765,15 +2777,14 @@ package body Errout is
|
|||
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
|
||||
|
||||
|
|
@ -2782,7 +2793,21 @@ package body Errout is
|
|||
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;
|
||||
|
|
@ -2846,16 +2871,10 @@ package body Errout is
|
|||
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
|
||||
|
|
@ -3233,4 +3252,22 @@ package body Errout is
|
|||
end loop;
|
||||
end VMS_Convert;
|
||||
|
||||
--------------------
|
||||
-- Warn_Insertion --
|
||||
--------------------
|
||||
|
||||
function Warn_Insertion return String is
|
||||
begin
|
||||
case Warning_Msg_Char is
|
||||
when '?' =>
|
||||
return "??";
|
||||
when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
|
||||
return '?' & Warning_Msg_Char & '?';
|
||||
when ' ' =>
|
||||
return "?";
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
end Warn_Insertion;
|
||||
|
||||
end Errout;
|
||||
|
|
|
|||
|
|
@ -60,12 +60,13 @@ package Errout is
|
|||
-- Exception raised if Raise_Exception_On_Error is true
|
||||
|
||||
Warning_Doc_Switch : Boolean renames Err_Vars.Warning_Doc_Switch;
|
||||
-- If this is set True, then the ??/?*?/?x?/?X? sequences in error messages
|
||||
-- generate appropriate tags for the output error messages. If this switch
|
||||
-- is False, then these sequences are still recognized (for the purposes
|
||||
-- of implementing pragmas Warnings (Off,..) and Warning_As_Pragma(...) but
|
||||
-- do not result in adding the error message tag. The -gnatw.d switch sets
|
||||
-- this flag True, -gnatw.D sets this flag False.
|
||||
-- If this is set True, then the ??/?*?/?$?/?x?/?X? insertion sequences in
|
||||
-- error messages generate appropriate tags for the output error messages.
|
||||
-- If this switch is False, then these sequences are still recognized (for
|
||||
-- the purposes of implementing the pattern matching in pragmas Warnings
|
||||
-- (Off,..) and Warning_As_Pragma(...) but do not result in adding the
|
||||
-- error message tag. The -gnatw.d switch sets this flag True, -gnatw.D
|
||||
-- sets this flag False.
|
||||
|
||||
-----------------------------------
|
||||
-- Suppression of Error Messages --
|
||||
|
|
@ -283,7 +284,7 @@ package Errout is
|
|||
-- messages, and the usual style is to include it, since it makes it
|
||||
-- clear that the continuation is part of a warning message.
|
||||
--
|
||||
-- Note: this usage is obsolete, use ?? ?*? ?x? ?X? instead to specify
|
||||
-- Note: this usage is obsolete, use ?? ?*? ?$? ?x? ?X? to specify
|
||||
-- the string to be added when Warn_Doc_Switch is set to True. If this
|
||||
-- switch is True, then for simple ? messages it has no effect. This
|
||||
-- simple form is to ease transition and will be removed later.
|
||||
|
|
@ -309,11 +310,17 @@ package Errout is
|
|||
-- "[restriction warning]" at the end of the warning message. For
|
||||
-- continuations, use this on each continuation message.
|
||||
|
||||
-- Insertion character ?$? (elaboration information messages)
|
||||
-- Like ?, but if the flag Warn_Doc_Switch is True, adds the string
|
||||
-- "[-gnatel]" at the end of the info message. This is used for the
|
||||
-- messages generated by the switch -gnatel. For continuations, use
|
||||
-- this on each continuation message.
|
||||
|
||||
-- Insertion character < (Less Than: conditional warning message)
|
||||
-- The character < appearing anywhere in a message is used for a
|
||||
-- conditional error message. If Error_Msg_Warn is True, then the
|
||||
-- effect is the same as ? described above, and in particular <<
|
||||
-- <X< and <*< have the effect of ?? ?X? and ?*? respectively. If
|
||||
-- effect is the same as ? described above, and in particular << <X<
|
||||
-- <x< <$< <*< have the effect of ?? ?X? ?x? ?$? ?*? respectively. If
|
||||
-- Error_Msg_Warn is False, then the < << or <X< sequence is ignored
|
||||
-- and the message is treated as a error rather than a warning.
|
||||
|
||||
|
|
@ -392,6 +399,19 @@ package Errout is
|
|||
-- This is like [ except that the insertion messages say may/might,
|
||||
-- instead of will/would.
|
||||
|
||||
-- Insertion sequence "(style)" (style message)
|
||||
-- This appears only at the start of the message (and not any of its
|
||||
-- continuations, if any), and indicates that the message is a style
|
||||
-- message. Style messages are also considered to be warnings, but
|
||||
-- they do not get a tag.
|
||||
|
||||
-- Insertion sequence "info: " (information message)
|
||||
-- This appears only at the start of the message (and not any of its
|
||||
-- continuations, if any), and indicates that the message is an info
|
||||
-- message. The message will be output with this prefix, and if there
|
||||
-- are continuations that are not printed using the -gnatj switch they
|
||||
-- will also have this prefix.
|
||||
|
||||
----------------------------------------
|
||||
-- Specialization of Messages for VMS --
|
||||
----------------------------------------
|
||||
|
|
|
|||
|
|
@ -257,6 +257,7 @@ package body Erroutc is
|
|||
w ("Dumping error message, Id = ", Int (Id));
|
||||
w (" Text = ", E.Text.all);
|
||||
w (" Next = ", Int (E.Next));
|
||||
w (" Prev = ", Int (E.Prev));
|
||||
w (" Sfile = ", Int (E.Sfile));
|
||||
|
||||
Write_Str
|
||||
|
|
@ -272,6 +273,8 @@ package body Erroutc is
|
|||
w (" Line = ", Int (E.Line));
|
||||
w (" Col = ", Int (E.Col));
|
||||
w (" Warn = ", E.Warn);
|
||||
w (" Warn_Err = ", E.Warn_Err);
|
||||
w (" Warn_Chr = '" & E.Warn_Chr & ''');
|
||||
w (" Style = ", E.Style);
|
||||
w (" Serious = ", E.Serious);
|
||||
w (" Uncond = ", E.Uncond);
|
||||
|
|
@ -312,6 +315,8 @@ package body Erroutc is
|
|||
return "[enabled by default]";
|
||||
elsif Warn_Chr = '*' then
|
||||
return "[restriction warning]";
|
||||
elsif Warn_Chr = '$' then
|
||||
return "[-gnatel]";
|
||||
elsif Warn_Chr in 'a' .. 'z' then
|
||||
return "[-gnatw" & Warn_Chr & ']';
|
||||
else pragma Assert (Warn_Chr in 'A' .. 'Z');
|
||||
|
|
@ -574,24 +579,22 @@ package body Erroutc is
|
|||
|
||||
if Errors.Table (E).Warn then
|
||||
|
||||
-- Nothing to do with info messages, "info " already set
|
||||
-- For info messages, prefix message with "info: "
|
||||
|
||||
if Txt'Length >= 6
|
||||
and then Txt (Txt'First .. Txt'First + 5) = "info: "
|
||||
then
|
||||
null;
|
||||
if Errors.Table (E).Info then
|
||||
Txt := new String'("info: " & Txt.all);
|
||||
|
||||
-- Warning treated as error
|
||||
|
||||
elsif Errors.Table (E).Warn_Err then
|
||||
|
||||
-- We prefix the tag error: rather than warning: and postfix
|
||||
-- We prefix with "error:" rather than warning: and postfix
|
||||
-- [warning-as-error] at the end.
|
||||
|
||||
Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
|
||||
Txt := new String'("error: " & Txt.all & " [warning-as-error]");
|
||||
|
||||
-- Normal case, prefix
|
||||
-- Normal case, prefix with "warning: "
|
||||
|
||||
else
|
||||
Txt := new String'("warning: " & Txt.all);
|
||||
|
|
@ -683,6 +686,103 @@ package body Erroutc is
|
|||
end;
|
||||
end Output_Msg_Text;
|
||||
|
||||
---------------------
|
||||
-- Prescan_Message --
|
||||
---------------------
|
||||
|
||||
procedure Prescan_Message (Msg : String) is
|
||||
J : Natural;
|
||||
|
||||
begin
|
||||
-- Nothing to do for continuation line
|
||||
|
||||
if Msg (Msg'First) = '\' then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Set initial values of globals (may be changed during scan)
|
||||
|
||||
Is_Serious_Error := True;
|
||||
Is_Unconditional_Msg := False;
|
||||
Is_Warning_Msg := False;
|
||||
Has_Double_Exclam := False;
|
||||
|
||||
-- Check style message
|
||||
|
||||
Is_Style_Msg :=
|
||||
Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)";
|
||||
|
||||
-- Check info message
|
||||
|
||||
Is_Info_Msg :=
|
||||
Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: ";
|
||||
|
||||
-- Loop through message looking for relevant insertion sequences
|
||||
|
||||
J := Msg'First;
|
||||
while J <= Msg'Last loop
|
||||
|
||||
-- If we have a quote, don't look at following character
|
||||
|
||||
if Msg (J) = ''' then
|
||||
J := J + 2;
|
||||
|
||||
-- Warning message (? or < insertion sequence)
|
||||
|
||||
elsif Msg (J) = '?' or else Msg (J) = '<' then
|
||||
Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn;
|
||||
Warning_Msg_Char := ' ';
|
||||
J := J + 1;
|
||||
|
||||
if Is_Warning_Msg then
|
||||
declare
|
||||
C : constant Character := Msg (J - 1);
|
||||
begin
|
||||
if J <= Msg'Last then
|
||||
if Msg (J) = C then
|
||||
Warning_Msg_Char := '?';
|
||||
J := J + 1;
|
||||
|
||||
elsif J < Msg'Last and then Msg (J + 1) = C
|
||||
and then (Msg (J) in 'a' .. 'z' or else
|
||||
Msg (J) in 'A' .. 'Z' or else
|
||||
Msg (J) = '*' or else
|
||||
Msg (J) = '$')
|
||||
then
|
||||
Warning_Msg_Char := Msg (J);
|
||||
J := J + 2;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Unconditional message (! insertion)
|
||||
|
||||
elsif Msg (J) = '!' then
|
||||
Is_Unconditional_Msg := True;
|
||||
J := J + 1;
|
||||
|
||||
if J <= Msg'Last and then Msg (J) = '!' then
|
||||
Has_Double_Exclam := True;
|
||||
J := J + 1;
|
||||
end if;
|
||||
|
||||
-- Non-serious error (| insertion)
|
||||
|
||||
elsif Msg (J) = '|' then
|
||||
Is_Serious_Error := False;
|
||||
J := J + 1;
|
||||
|
||||
else
|
||||
J := J + 1;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Is_Warning_Msg or Is_Style_Msg then
|
||||
Is_Serious_Error := False;
|
||||
end if;
|
||||
end Prescan_Message;
|
||||
|
||||
--------------------
|
||||
-- Purge_Messages --
|
||||
--------------------
|
||||
|
|
@ -1251,6 +1351,7 @@ package body Erroutc is
|
|||
for J in 1 .. Specific_Warnings.Last loop
|
||||
declare
|
||||
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
|
||||
|
||||
begin
|
||||
if Msg = SWE.Msg.all
|
||||
and then Loc > SWE.Start
|
||||
|
|
@ -1352,63 +1453,6 @@ package body Erroutc is
|
|||
end if;
|
||||
end Set_Warnings_Mode_On;
|
||||
|
||||
------------------------------------
|
||||
-- Test_Style_Warning_Serious_Msg --
|
||||
------------------------------------
|
||||
|
||||
procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
|
||||
begin
|
||||
-- Nothing to do for continuation line
|
||||
|
||||
if Msg (Msg'First) = '\' then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Set initial values of globals (may be changed during scan)
|
||||
|
||||
Is_Serious_Error := True;
|
||||
Is_Unconditional_Msg := False;
|
||||
Is_Warning_Msg := False;
|
||||
Has_Double_Exclam := False;
|
||||
|
||||
Is_Style_Msg :=
|
||||
(Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
|
||||
|
||||
for J in Msg'Range loop
|
||||
if Msg (J) = '?'
|
||||
and then (J = Msg'First or else Msg (J - 1) /= ''')
|
||||
then
|
||||
Is_Warning_Msg := True;
|
||||
Warning_Msg_Char := ' ';
|
||||
|
||||
elsif Msg (J) = '!'
|
||||
and then (J = Msg'First or else Msg (J - 1) /= ''')
|
||||
then
|
||||
Is_Unconditional_Msg := True;
|
||||
Warning_Msg_Char := ' ';
|
||||
|
||||
if J < Msg'Last and then Msg (J + 1) = '!' then
|
||||
Has_Double_Exclam := True;
|
||||
end if;
|
||||
|
||||
elsif Msg (J) = '<'
|
||||
and then (J = Msg'First or else Msg (J - 1) /= ''')
|
||||
then
|
||||
Is_Warning_Msg := Error_Msg_Warn;
|
||||
Warning_Msg_Char := ' ';
|
||||
|
||||
elsif Msg (J) = '|'
|
||||
and then (J = Msg'First or else Msg (J - 1) /= ''')
|
||||
then
|
||||
Is_Serious_Error := False;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Is_Warning_Msg or Is_Style_Msg then
|
||||
Is_Serious_Error := False;
|
||||
end if;
|
||||
end Test_Style_Warning_Serious_Unconditional_Msg;
|
||||
|
||||
--------------------------------
|
||||
-- Validate_Specific_Warnings --
|
||||
--------------------------------
|
||||
|
|
|
|||
|
|
@ -60,15 +60,24 @@ package Erroutc is
|
|||
-- character ! and is thus to be treated as an unconditional message.
|
||||
|
||||
Is_Warning_Msg : Boolean := False;
|
||||
-- Set True to indicate if current message is warning message (contains ?)
|
||||
-- Set True to indicate if current message is warning message (contains ?
|
||||
-- or contains < and Error_Msg_Warn is True.
|
||||
|
||||
Is_Info_Msg : Boolean := False;
|
||||
-- Set True to indicate that the current message starts with the characters
|
||||
-- "info: " and is to be treated as an information message. This string
|
||||
-- will be prepended to the message and all its continuations.
|
||||
|
||||
Warning_Msg_Char : Character;
|
||||
-- Warning character, valid only if Is_Warning_Msg is True
|
||||
-- ' ' -- ? appeared on its own in message
|
||||
-- '?' -- ?? appeared in message
|
||||
-- 'x' -- ?x? appeared in message (x = a .. z)
|
||||
-- 'X' -- ?X? appeared in message (X = A .. Z)
|
||||
-- '*' -- ?*? appeared in message
|
||||
-- ' ' -- ? or < appeared on its own in message
|
||||
-- '?' -- ?? or << appeared in message
|
||||
-- 'x' -- ?x? or <x< appeared in message (x = a .. z)
|
||||
-- 'X' -- ?X? or <X< appeared in message (X = A .. Z)
|
||||
-- '*' -- ?*? or <*< appeared in message
|
||||
-- '$' -- ?$? or <$< appeared in message
|
||||
-- In the case of the < sequences, this is set only if the message is
|
||||
-- actually a warning, i.e. if Error_Msg_Warn is True
|
||||
|
||||
Is_Style_Msg : Boolean := False;
|
||||
-- Set True to indicate if the current message is a style message
|
||||
|
|
@ -194,7 +203,10 @@ package Erroutc is
|
|||
-- Column number for error message
|
||||
|
||||
Warn : Boolean;
|
||||
-- True if warning message (i.e. insertion character ? appeared)
|
||||
-- True if warning message
|
||||
|
||||
Info : Boolean;
|
||||
-- True if info message
|
||||
|
||||
Warn_Err : Boolean;
|
||||
-- True if this is a warning message which is to be treated as an error
|
||||
|
|
@ -202,11 +214,14 @@ package Erroutc is
|
|||
|
||||
Warn_Chr : Character;
|
||||
-- Warning character (note: set even if Warning_Doc_Switch is False)
|
||||
-- ' ' -- ? appeared on its own in message
|
||||
-- '?' -- ?? appeared in message
|
||||
-- 'x' -- ?x? appeared in message (x = a .. z)
|
||||
-- 'X' -- ?X? appeared in message (X = A .. Z)
|
||||
-- '*' -- ?*? appeared in message
|
||||
-- ' ' -- ? or < appeared on its own in message
|
||||
-- '?' -- ?? or << appeared in message
|
||||
-- 'x' -- ?x? or <x< appeared in message (x = a .. z)
|
||||
-- 'X' -- ?X? or <X< appeared in message (X = A .. Z)
|
||||
-- '*' -- ?*? or <*< appeared in message
|
||||
-- '$' -- ?$? or <$< appeared in message
|
||||
-- In the case of the < sequences, this is set only if the message is
|
||||
-- actually a warning, i.e. if Error_Msg_Warn is True
|
||||
|
||||
Style : Boolean;
|
||||
-- True if style message (starts with "(style)")
|
||||
|
|
@ -404,6 +419,34 @@ package Erroutc is
|
|||
-- splits the line generating multiple lines of output, and in this case
|
||||
-- the last line has no terminating end of line character.
|
||||
|
||||
procedure Prescan_Message (Msg : String);
|
||||
-- Scans message text and sets the following variables:
|
||||
--
|
||||
-- Is_Warning_Msg is set True if Msg is a warning message (contains a
|
||||
-- question mark character), and False otherwise.
|
||||
--
|
||||
-- Is_Style_Msg is set True if Msg is a style message (starts with
|
||||
-- "(style)") and False otherwise.
|
||||
--
|
||||
-- Is_Info_Msg is set True if Msg is an information message (starts
|
||||
-- with "info: ". Such messages must contain a ? sequence since they
|
||||
-- are also considered to be warning messages, and get a tag.
|
||||
--
|
||||
-- Is_Serious_Error is set to True unless the message is a warning or
|
||||
-- style message or contains the character | (non-serious error).
|
||||
--
|
||||
-- Is_Unconditional_Msg is set True if the message contains the character
|
||||
-- ! and is otherwise set False.
|
||||
--
|
||||
-- Has_Double_Exclam is set True if the message contains the sequence !!
|
||||
-- and is otherwise set False.
|
||||
--
|
||||
-- We need to know right away these aspects of a message, since we will
|
||||
-- test these values before doing the full error scan.
|
||||
--
|
||||
-- Note that the call has no effect for continuation messages (those whose
|
||||
-- first character is '\'), and all variables are left unchanged.
|
||||
|
||||
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
|
||||
-- All error messages whose location is in the range From .. To (not
|
||||
-- including the end points) will be deleted from the error listing.
|
||||
|
|
@ -523,27 +566,6 @@ package Erroutc is
|
|||
-- Called in response to a pragma Warnings (On) to record the source
|
||||
-- location from which warnings are to be turned back on.
|
||||
|
||||
procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String);
|
||||
-- Scans message text and sets the following variables:
|
||||
--
|
||||
-- Is_Warning_Msg is set True if Msg is a warning message (contains a
|
||||
-- question mark character), and False otherwise.
|
||||
--
|
||||
-- Is_Style_Msg is set True if Msg is a style message (starts with
|
||||
-- "(style)") and False otherwise.
|
||||
--
|
||||
-- Is_Serious_Error is set to True unless the message is a warning or
|
||||
-- style message or contains the character | (non-serious error).
|
||||
--
|
||||
-- Is_Unconditional_Msg is set True if the message contains the character
|
||||
-- ! and is otherwise set False.
|
||||
--
|
||||
-- Has_Double_Exclam is set True if the message contains the sequence !!
|
||||
-- and is otherwise set False.
|
||||
--
|
||||
-- Note that the call has no effect for continuation messages (those whose
|
||||
-- first character is '\'), and all variables are left unchanged.
|
||||
|
||||
function Warnings_Suppressed (Loc : Source_Ptr) return String_Id;
|
||||
-- Determines if given location is covered by a warnings off suppression
|
||||
-- range in the warnings table (or is suppressed by compilation option,
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2013, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1991-2014, 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- --
|
||||
|
|
@ -177,7 +177,7 @@ package body Errutil is
|
|||
raise Error_Msg_Exception;
|
||||
end if;
|
||||
|
||||
Test_Style_Warning_Serious_Unconditional_Msg (Msg);
|
||||
Prescan_Message (Msg);
|
||||
Set_Msg_Text (Msg, Sptr);
|
||||
|
||||
-- Kill continuation if parent message killed
|
||||
|
|
@ -212,6 +212,7 @@ package body Errutil is
|
|||
Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr);
|
||||
Errors.Table (Cur_Msg).Style := Is_Style_Msg;
|
||||
Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
|
||||
Errors.Table (Cur_Msg).Info := Is_Info_Msg;
|
||||
Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
|
||||
Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
|
||||
Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2014, 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- --
|
||||
|
|
@ -228,10 +228,10 @@ package body Exp_Util is
|
|||
|
||||
if Present (Msg_Node) then
|
||||
Error_Msg_N
|
||||
("?N?info: atomic synchronization set for &", Msg_Node);
|
||||
("info: atomic synchronization set for &?N?", Msg_Node);
|
||||
else
|
||||
Error_Msg_N
|
||||
("?N?info: atomic synchronization set", N);
|
||||
("info: atomic synchronization set?N?", N);
|
||||
end if;
|
||||
end if;
|
||||
end Activate_Atomic_Synchronization;
|
||||
|
|
|
|||
|
|
@ -5096,19 +5096,46 @@ This switch suppresses warnings for implicit dereferences in
|
|||
indexed components, slices, and selected components.
|
||||
|
||||
@item -gnatw.d
|
||||
@emph{Activate tagging of warning messages.}
|
||||
@emph{Activate tagging of warning and info messages.}
|
||||
@cindex @option{-gnatw.d} (@command{gcc})
|
||||
If this switch is set, then warning messages are tagged, either with
|
||||
the string ``@option{-gnatw?}'' showing which switch controls the warning,
|
||||
or with ``[enabled by default]'' if the warning is not under control of a
|
||||
specific @option{-gnatw?} switch. This mode is off by default, and is not
|
||||
affected by the use of @code{-gnatwa}.
|
||||
If this switch is set, then warning messages are tagged, with one of the
|
||||
following strings:
|
||||
|
||||
@table @option
|
||||
|
||||
@item [-gnatw?]
|
||||
Used to tag warnings controlled by the switch @option{-gnatwx} where x
|
||||
is a letter a-z.
|
||||
|
||||
@item [-gnatw.?]
|
||||
Used to tag warnings controlled by the switch @option{-gnatw.x} where x
|
||||
is a letter a-z.
|
||||
|
||||
@item [-gnatel]
|
||||
Used to tag elaboration information (info) messages generated when the
|
||||
static model of elaboration is used and the @option{-gnatel} switch is set.
|
||||
|
||||
@item [restriction warning]
|
||||
Used to tag warning messages for restriction violations, activated by use
|
||||
of the pragma @option{Restriction_Warnings}.
|
||||
|
||||
@item [warning-as-error]
|
||||
Used to tag warning messages that have been converted to error messages by
|
||||
use of the pragma Warning_As_Error. Note that such warnings are prefixed by
|
||||
the string "error: " rather than "warning: ".
|
||||
|
||||
@item [enabled by default]
|
||||
Used to tag all other warnings that are always given by default, unless
|
||||
warnings are completely suppressed using pragma @option{Warnings(Off)} or
|
||||
the switch @option{-gnatws}.
|
||||
|
||||
@end table
|
||||
|
||||
@item -gnatw.D
|
||||
@emph{Deactivate tagging of warning messages.}
|
||||
@emph{Deactivate tagging of warning and info messages messages.}
|
||||
@cindex @option{-gnatw.d} (@command{gcc})
|
||||
If this switch is set, then warning messages return to the default
|
||||
mode in which warnings are not tagged as described above for
|
||||
mode in which warnings and info messages are not tagged as described above for
|
||||
@code{-gnatw.d}.
|
||||
|
||||
@item -gnatwe
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2014, 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- --
|
||||
|
|
@ -270,7 +270,7 @@ package body Ch7 is
|
|||
if Aspect_Sloc /= No_Location
|
||||
and then not Aspect_Specifications_Present
|
||||
then
|
||||
Error_Msg_SC ("\info: aspect specifications belong here");
|
||||
Error_Msg_SC ("info: aspect specifications belong here??");
|
||||
Move_Aspects (From => Dummy_Node, To => Package_Node);
|
||||
end if;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1996-2013, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1996-2014, 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- --
|
||||
|
|
@ -31,71 +31,167 @@
|
|||
|
||||
pragma Compiler_Unit_Warning;
|
||||
|
||||
with System.HTable;
|
||||
with System.Soft_Links; use System.Soft_Links;
|
||||
with System.Soft_Links; use System.Soft_Links;
|
||||
|
||||
package body System.Exception_Table is
|
||||
|
||||
use System.Standard_Library;
|
||||
|
||||
type HTable_Headers is range 1 .. 37;
|
||||
type Hash_Val is mod 2 ** 8;
|
||||
subtype Hash_Idx is Hash_Val range 1 .. 37;
|
||||
|
||||
procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
|
||||
function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
|
||||
HTable : array (Hash_Idx) of aliased Exception_Data_Ptr;
|
||||
-- Actual hash table containing all registered exceptions
|
||||
--
|
||||
-- The table is very small and the hash function weak, as looking up
|
||||
-- registered exceptions is rare and minimizing space and time overhead
|
||||
-- of registration is more important. In addition, it is expected that the
|
||||
-- exceptions that need to be looked up are registered dynamically, and
|
||||
-- therefore will be at the begin of the hash chains.
|
||||
--
|
||||
-- The table differs from System.HTable.Static_HTable in that the final
|
||||
-- element of each chain is not marked by null, but by a pointer to self.
|
||||
-- This way it is possible to defend against the same entry being inserted
|
||||
-- twice, without having to do a lookup which is relatively expensive for
|
||||
-- programs with large number
|
||||
--
|
||||
-- All non-local subprograms use the global Task_Lock to protect against
|
||||
-- concurrent use of the exception table. This is needed as local
|
||||
-- exceptions may be declared concurrently with those declared at the
|
||||
-- library level.
|
||||
|
||||
function Hash (F : System.Address) return HTable_Headers;
|
||||
function Equal (A, B : System.Address) return Boolean;
|
||||
function Get_Key (T : Exception_Data_Ptr) return System.Address;
|
||||
-- Local Subprograms
|
||||
|
||||
package Exception_HTable is new System.HTable.Static_HTable (
|
||||
Header_Num => HTable_Headers,
|
||||
Element => Exception_Data,
|
||||
Elmt_Ptr => Exception_Data_Ptr,
|
||||
Null_Ptr => null,
|
||||
Set_Next => Set_HT_Link,
|
||||
Next => Get_HT_Link,
|
||||
Key => System.Address,
|
||||
Get_Key => Get_Key,
|
||||
Hash => Hash,
|
||||
Equal => Equal);
|
||||
generic
|
||||
with procedure Process (T : Exception_Data_Ptr; More : out Boolean);
|
||||
procedure Iterate;
|
||||
-- Iterate over all
|
||||
|
||||
-----------
|
||||
-- Equal --
|
||||
-----------
|
||||
function Lookup (Name : String) return Exception_Data_Ptr;
|
||||
-- Find and return the Exception_Data of the exception with the given Name
|
||||
-- (which must be in all uppercase), or null if none was registered.
|
||||
|
||||
procedure Register (Item : Exception_Data_Ptr);
|
||||
-- Register an exception with the given Exception_Data in the table.
|
||||
|
||||
function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean;
|
||||
-- Return True iff Item.Full_Name and Name are equal. Both names are
|
||||
-- assumed to be in all uppercase and end with ASCII.NUL.
|
||||
|
||||
function Hash (S : String) return Hash_Idx;
|
||||
-- Return the index in the hash table for S, which is assumed to be all
|
||||
-- uppercase and end with ASCII.NUL.
|
||||
|
||||
--------------
|
||||
-- Has_Name --
|
||||
--------------
|
||||
|
||||
function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean
|
||||
is
|
||||
S : constant Big_String_Ptr := To_Ptr (Item.Full_Name);
|
||||
J : Integer := S'First;
|
||||
|
||||
function Equal (A, B : System.Address) return Boolean is
|
||||
S1 : constant Big_String_Ptr := To_Ptr (A);
|
||||
S2 : constant Big_String_Ptr := To_Ptr (B);
|
||||
J : Integer := 1;
|
||||
begin
|
||||
loop
|
||||
if S1 (J) /= S2 (J) then
|
||||
for K in Name'Range loop
|
||||
|
||||
-- Note that as both items are terminated with ASCII.NUL, the
|
||||
-- comparison below must fail for strings of different lengths.
|
||||
|
||||
if S (J) /= Name (K) then
|
||||
return False;
|
||||
elsif S1 (J) = ASCII.NUL then
|
||||
return True;
|
||||
else
|
||||
J := J + 1;
|
||||
end if;
|
||||
|
||||
J := J + 1;
|
||||
end loop;
|
||||
end Equal;
|
||||
|
||||
-----------------
|
||||
-- Get_HT_Link --
|
||||
-----------------
|
||||
return True;
|
||||
end Has_Name;
|
||||
|
||||
------------
|
||||
-- Lookup --
|
||||
------------
|
||||
|
||||
function Lookup (Name : String) return Exception_Data_Ptr is
|
||||
Prev : Exception_Data_Ptr;
|
||||
Curr : Exception_Data_Ptr;
|
||||
|
||||
function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
|
||||
begin
|
||||
return T.HTable_Ptr;
|
||||
end Get_HT_Link;
|
||||
Curr := HTable (Hash (Name));
|
||||
Prev := null;
|
||||
while Curr /= Prev loop
|
||||
if Has_Name (Curr, Name) then
|
||||
return Curr;
|
||||
end if;
|
||||
|
||||
Prev := Curr;
|
||||
Curr := Curr.HTable_Ptr;
|
||||
end loop;
|
||||
|
||||
return null;
|
||||
end Lookup;
|
||||
|
||||
----------
|
||||
-- Hash --
|
||||
----------
|
||||
|
||||
function Hash (S : String) return Hash_Idx is
|
||||
Hash : Hash_Val := 0;
|
||||
|
||||
begin
|
||||
for J in S'Range loop
|
||||
exit when S (J) = ASCII.NUL;
|
||||
Hash := Hash xor Character'Pos (S (J));
|
||||
end loop;
|
||||
|
||||
return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1);
|
||||
end Hash;
|
||||
|
||||
-------------
|
||||
-- Get_Key --
|
||||
-- Iterate --
|
||||
-------------
|
||||
|
||||
function Get_Key (T : Exception_Data_Ptr) return System.Address is
|
||||
procedure Iterate is
|
||||
More : Boolean;
|
||||
Prev, Curr : Exception_Data_Ptr;
|
||||
|
||||
begin
|
||||
return T.Full_Name;
|
||||
end Get_Key;
|
||||
Outer : for Idx in HTable'Range loop
|
||||
Prev := null;
|
||||
Curr := HTable (Idx);
|
||||
|
||||
while Curr /= Prev loop
|
||||
Process (Curr, More);
|
||||
|
||||
exit Outer when not More;
|
||||
|
||||
Prev := Curr;
|
||||
Curr := Curr.HTable_Ptr;
|
||||
end loop;
|
||||
end loop Outer;
|
||||
end Iterate;
|
||||
|
||||
--------------
|
||||
-- Register --
|
||||
--------------
|
||||
|
||||
procedure Register (Item : Exception_Data_Ptr) is
|
||||
begin
|
||||
if Item.HTable_Ptr = null then
|
||||
Prepend_To_Chain : declare
|
||||
Chain : Exception_Data_Ptr
|
||||
renames HTable (Hash (To_Ptr (Item.Full_Name).all));
|
||||
|
||||
begin
|
||||
if Chain = null then
|
||||
Item.HTable_Ptr := Item;
|
||||
else
|
||||
Item.HTable_Ptr := Chain;
|
||||
end if;
|
||||
|
||||
Chain := Item;
|
||||
end Prepend_To_Chain;
|
||||
end if;
|
||||
end Register;
|
||||
|
||||
-------------------------------
|
||||
-- Get_Registered_Exceptions --
|
||||
|
|
@ -105,45 +201,41 @@ package body System.Exception_Table is
|
|||
(List : out Exception_Data_Array;
|
||||
Last : out Integer)
|
||||
is
|
||||
Data : Exception_Data_Ptr := Exception_HTable.Get_First;
|
||||
procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean);
|
||||
-- Add Item to List (List'First .. Last) by first incrementing Last
|
||||
-- and storing Item in List (Last). Last should be in List'First - 1
|
||||
-- and List'Last.
|
||||
|
||||
procedure Get_All is new Iterate (Get_One);
|
||||
-- Store all registered exceptions in List, updating Last
|
||||
|
||||
-------------
|
||||
-- Get_One --
|
||||
-------------
|
||||
|
||||
procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is
|
||||
begin
|
||||
if Last < List'Last then
|
||||
Last := Last + 1;
|
||||
List (Last) := Item;
|
||||
More := True;
|
||||
|
||||
else
|
||||
More := False;
|
||||
end if;
|
||||
end Get_One;
|
||||
|
||||
begin
|
||||
Lock_Task.all;
|
||||
-- In this routine the invariant is that List (List'First .. Last)
|
||||
-- contains the registered exceptions retrieved so far.
|
||||
|
||||
Last := List'First - 1;
|
||||
|
||||
while Last < List'Last and then Data /= null loop
|
||||
Last := Last + 1;
|
||||
List (Last) := Data;
|
||||
Data := Exception_HTable.Get_Next;
|
||||
end loop;
|
||||
|
||||
Lock_Task.all;
|
||||
Get_All;
|
||||
Unlock_Task.all;
|
||||
end Get_Registered_Exceptions;
|
||||
|
||||
----------
|
||||
-- Hash --
|
||||
----------
|
||||
|
||||
function Hash (F : System.Address) return HTable_Headers is
|
||||
type S is mod 2**8;
|
||||
|
||||
Str : constant Big_String_Ptr := To_Ptr (F);
|
||||
Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
|
||||
Tmp : S := 0;
|
||||
J : Positive;
|
||||
|
||||
begin
|
||||
J := 1;
|
||||
loop
|
||||
if Str (J) = ASCII.NUL then
|
||||
return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
|
||||
else
|
||||
Tmp := Tmp xor S (Character'Pos (Str (J)));
|
||||
end if;
|
||||
J := J + 1;
|
||||
end loop;
|
||||
end Hash;
|
||||
|
||||
------------------------
|
||||
-- Internal_Exception --
|
||||
------------------------
|
||||
|
|
@ -152,25 +244,30 @@ package body System.Exception_Table is
|
|||
(X : String;
|
||||
Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
|
||||
is
|
||||
-- If X was not yet registered and Create_if_Not_Exist is True,
|
||||
-- dynamically allocate and register a new exception.
|
||||
|
||||
type String_Ptr is access all String;
|
||||
|
||||
Copy : aliased String (X'First .. X'Last + 1);
|
||||
Res : Exception_Data_Ptr;
|
||||
Dyn_Copy : String_Ptr;
|
||||
Copy : aliased String (X'First .. X'Last + 1);
|
||||
Result : Exception_Data_Ptr;
|
||||
|
||||
begin
|
||||
Lock_Task.all;
|
||||
|
||||
Copy (X'Range) := X;
|
||||
Copy (Copy'Last) := ASCII.NUL;
|
||||
Res := Exception_HTable.Get (Copy'Address);
|
||||
Result := Lookup (Copy);
|
||||
|
||||
-- If unknown exception, create it on the heap. This is a legitimate
|
||||
-- situation in the distributed case when an exception is defined only
|
||||
-- in a partition
|
||||
-- situation in the distributed case when an exception is defined
|
||||
-- only in a partition
|
||||
|
||||
if Res = null and then Create_If_Not_Exist then
|
||||
if Result = null and then Create_If_Not_Exist then
|
||||
Dyn_Copy := new String'(Copy);
|
||||
|
||||
Res :=
|
||||
Result :=
|
||||
new Exception_Data'
|
||||
(Not_Handled_By_Others => False,
|
||||
Lang => 'A',
|
||||
|
|
@ -180,10 +277,12 @@ package body System.Exception_Table is
|
|||
Foreign_Data => Null_Address,
|
||||
Raise_Hook => null);
|
||||
|
||||
Register_Exception (Res);
|
||||
Register (Result);
|
||||
end if;
|
||||
|
||||
return Res;
|
||||
Unlock_Task.all;
|
||||
|
||||
return Result;
|
||||
end Internal_Exception;
|
||||
|
||||
------------------------
|
||||
|
|
@ -192,7 +291,9 @@ package body System.Exception_Table is
|
|||
|
||||
procedure Register_Exception (X : Exception_Data_Ptr) is
|
||||
begin
|
||||
Exception_HTable.Set (X);
|
||||
Lock_Task.all;
|
||||
Register (X);
|
||||
Unlock_Task.all;
|
||||
end Register_Exception;
|
||||
|
||||
---------------------------------
|
||||
|
|
@ -201,43 +302,38 @@ package body System.Exception_Table is
|
|||
|
||||
function Registered_Exceptions_Count return Natural is
|
||||
Count : Natural := 0;
|
||||
Data : Exception_Data_Ptr := Exception_HTable.Get_First;
|
||||
|
||||
procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean);
|
||||
-- Update Count for given Item
|
||||
|
||||
procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is
|
||||
pragma Unreferenced (Item);
|
||||
begin
|
||||
Count := Count + 1;
|
||||
More := Count < Natural'Last;
|
||||
end Count_Item;
|
||||
|
||||
procedure Count_All is new Iterate (Count_Item);
|
||||
|
||||
begin
|
||||
-- We need to lock the runtime in the meantime, to avoid concurrent
|
||||
-- access since we have only one iterator.
|
||||
|
||||
Lock_Task.all;
|
||||
|
||||
while Data /= null loop
|
||||
Count := Count + 1;
|
||||
Data := Exception_HTable.Get_Next;
|
||||
end loop;
|
||||
|
||||
Count_All;
|
||||
Unlock_Task.all;
|
||||
|
||||
return Count;
|
||||
end Registered_Exceptions_Count;
|
||||
|
||||
-----------------
|
||||
-- Set_HT_Link --
|
||||
-----------------
|
||||
|
||||
procedure Set_HT_Link
|
||||
(T : Exception_Data_Ptr;
|
||||
Next : Exception_Data_Ptr)
|
||||
is
|
||||
begin
|
||||
T.HTable_Ptr := Next;
|
||||
end Set_HT_Link;
|
||||
|
||||
-- Register the standard exceptions at elaboration time
|
||||
|
||||
begin
|
||||
Register_Exception (Abort_Signal_Def'Access);
|
||||
Register_Exception (Tasking_Error_Def'Access);
|
||||
Register_Exception (Storage_Error_Def'Access);
|
||||
Register_Exception (Program_Error_Def'Access);
|
||||
Register_Exception (Numeric_Error_Def'Access);
|
||||
Register_Exception (Constraint_Error_Def'Access);
|
||||
-- Register the standard exceptions at elaboration time
|
||||
|
||||
-- We don't need to use the locking version here as the elaboration
|
||||
-- will not be concurrent and no tasks can call any subprograms of this
|
||||
-- unit before it has been elaborated.
|
||||
|
||||
Register (Abort_Signal_Def'Access);
|
||||
Register (Tasking_Error_Def'Access);
|
||||
Register (Storage_Error_Def'Access);
|
||||
Register (Program_Error_Def'Access);
|
||||
Register (Numeric_Error_Def'Access);
|
||||
Register (Constraint_Error_Def'Access);
|
||||
end System.Exception_Table;
|
||||
|
|
|
|||
|
|
@ -661,12 +661,12 @@ package body Sem_Ch13 is
|
|||
|
||||
if Bytes_Big_Endian then
|
||||
Error_Msg_NE
|
||||
("\info: big-endian range for "
|
||||
("\big-endian range for "
|
||||
& "component & is ^ .. ^?V?",
|
||||
First_Bit (CC), Comp);
|
||||
else
|
||||
Error_Msg_NE
|
||||
("\info: little-endian range "
|
||||
("\little-endian range "
|
||||
& "for component & is ^ .. ^?V?",
|
||||
First_Bit (CC), Comp);
|
||||
end if;
|
||||
|
|
@ -6324,7 +6324,7 @@ package body Sem_Ch13 is
|
|||
if Inherit and Opt.List_Inherited_Aspects then
|
||||
Error_Msg_Sloc := Sloc (Ritem);
|
||||
Error_Msg_N
|
||||
("?L?info: & inherits `Invariant''Class` aspect from #",
|
||||
("info: & inherits `Invariant''Class` aspect from #?L?",
|
||||
Typ);
|
||||
end if;
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -2885,13 +2885,12 @@ package body Sem_Ch7 is
|
|||
-- Body required if library package with pragma Elaborate_Body
|
||||
|
||||
elsif Has_Pragma_Elaborate_Body (P) then
|
||||
Error_Msg_N
|
||||
("?Y?info: & requires body (Elaborate_Body)", P);
|
||||
Error_Msg_N ("info: & requires body (Elaborate_Body)?Y?", P);
|
||||
|
||||
-- Body required if subprogram
|
||||
|
||||
elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
|
||||
Error_Msg_N ("?Y?info: & requires body (subprogram case)", P);
|
||||
Error_Msg_N ("info: & requires body (subprogram case)?Y?", P);
|
||||
|
||||
-- Body required if generic parent has Elaborate_Body
|
||||
|
||||
|
|
@ -2904,7 +2903,7 @@ package body Sem_Ch7 is
|
|||
begin
|
||||
if Has_Pragma_Elaborate_Body (G_P) then
|
||||
Error_Msg_N
|
||||
("?Y?info: & requires body (generic parent Elaborate_Body)",
|
||||
("info: & requires body (generic parent Elaborate_Body)?Y?",
|
||||
P);
|
||||
end if;
|
||||
end;
|
||||
|
|
@ -2922,7 +2921,7 @@ package body Sem_Ch7 is
|
|||
not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
|
||||
then
|
||||
Error_Msg_N
|
||||
("?Y?info: & requires body (non-null abstract state aspect)", P);
|
||||
("info: & requires body (non-null abstract state aspect)?Y?", P);
|
||||
end if;
|
||||
|
||||
-- Otherwise search entity chain for entity requiring completion
|
||||
|
|
@ -2985,7 +2984,7 @@ package body Sem_Ch7 is
|
|||
then
|
||||
Error_Msg_Node_2 := E;
|
||||
Error_Msg_NE
|
||||
("?Y?info: & requires body (& requires completion)",
|
||||
("info: & requires body (& requires completion)?Y?",
|
||||
E, P);
|
||||
|
||||
-- Entity that does not require completion
|
||||
|
|
|
|||
|
|
@ -942,7 +942,7 @@ package body Sem_Elab is
|
|||
if Inst_Case then
|
||||
Elab_Warning
|
||||
("instantiation of& may raise Program_Error?l?",
|
||||
"info: instantiation of& during elaboration?", Ent);
|
||||
"info: instantiation of& during elaboration?$?", Ent);
|
||||
|
||||
-- Indirect call case, info message only in static elaboration
|
||||
-- case, because the attribute reference itself cannot raise
|
||||
|
|
@ -950,7 +950,7 @@ package body Sem_Elab is
|
|||
|
||||
elsif Access_Case then
|
||||
Elab_Warning
|
||||
("", "info: access to& during elaboration?", Ent);
|
||||
("", "info: access to& during elaboration?$?", Ent);
|
||||
|
||||
-- Subprogram call case
|
||||
|
||||
|
|
@ -961,13 +961,13 @@ package body Sem_Elab is
|
|||
then
|
||||
Elab_Warning
|
||||
("implicit call to & may raise Program_Error?l?",
|
||||
"info: implicit call to & during elaboration?",
|
||||
"info: implicit call to & during elaboration?$?",
|
||||
Ent);
|
||||
|
||||
else
|
||||
Elab_Warning
|
||||
("call to & may raise Program_Error?l?",
|
||||
"info: call to & during elaboration?",
|
||||
"info: call to & during elaboration?$?",
|
||||
Ent);
|
||||
end if;
|
||||
end if;
|
||||
|
|
@ -977,13 +977,13 @@ package body Sem_Elab is
|
|||
if Nkind (N) in N_Subprogram_Instantiation then
|
||||
Elab_Warning
|
||||
("\missing pragma Elaborate for&?l?",
|
||||
"\info: implicit pragma Elaborate for& generated?",
|
||||
"\implicit pragma Elaborate for& generated?$?",
|
||||
W_Scope);
|
||||
|
||||
else
|
||||
Elab_Warning
|
||||
("\missing pragma Elaborate_All for&?l?",
|
||||
"\info: implicit pragma Elaborate_All for & generated?",
|
||||
"\implicit pragma Elaborate_All for & generated?$?",
|
||||
W_Scope);
|
||||
end if;
|
||||
end Generate_Elab_Warnings;
|
||||
|
|
@ -1063,7 +1063,7 @@ package body Sem_Elab is
|
|||
Error_Msg_Node_2 := W_Scope;
|
||||
Error_Msg_NE
|
||||
("info: call to& in elaboration code " &
|
||||
"requires pragma Elaborate_All on&?", N, E);
|
||||
"requires pragma Elaborate_All on&?$?", N, E);
|
||||
end if;
|
||||
|
||||
-- Set indication for binder to generate Elaborate_All
|
||||
|
|
@ -2320,15 +2320,14 @@ package body Sem_Elab is
|
|||
|
||||
if Inst_Case then
|
||||
Error_Msg_NE
|
||||
("instantiation of& may occur before body is seen<<",
|
||||
("instantiation of& may occur before body is seen<l<",
|
||||
N, Orig_Ent);
|
||||
else
|
||||
Error_Msg_NE
|
||||
("call to& may occur before body is seen<<", N, Orig_Ent);
|
||||
("call to& may occur before body is seen<l<", N, Orig_Ent);
|
||||
end if;
|
||||
|
||||
Error_Msg_N
|
||||
("\Program_Error ]<<", N);
|
||||
Error_Msg_N ("\Program_Error ]<l<", N);
|
||||
|
||||
Output_Calls (N);
|
||||
end if;
|
||||
|
|
@ -2570,7 +2569,7 @@ package body Sem_Elab is
|
|||
Error_Msg_Node_2 := Task_Scope;
|
||||
Error_Msg_NE
|
||||
("info: activation of an instance of task type&" &
|
||||
" requires pragma Elaborate_All on &?", N, Ent);
|
||||
" requires pragma Elaborate_All on &?$?", N, Ent);
|
||||
end if;
|
||||
|
||||
Activate_Elaborate_All_Desirable (N, Task_Scope);
|
||||
|
|
@ -3056,6 +3055,10 @@ package body Sem_Elab is
|
|||
-- by the error message circuits (i.e. it has a single upper
|
||||
-- case letter at the end).
|
||||
|
||||
-----------------------------
|
||||
-- Is_Printable_Error_Name --
|
||||
-----------------------------
|
||||
|
||||
function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
|
||||
begin
|
||||
if not Is_Internal_Name (Nm) then
|
||||
|
|
@ -3078,17 +3081,31 @@ package body Sem_Elab is
|
|||
|
||||
Ent := Elab_Call.Table (J).Ent;
|
||||
|
||||
if Is_Generic_Unit (Ent) then
|
||||
Error_Msg_NE ("\??& instantiated #", N, Ent);
|
||||
-- Dynamic elaboration model, warnings controlled by -gnatwl
|
||||
|
||||
elsif Is_Init_Proc (Ent) then
|
||||
Error_Msg_N ("\??initialization procedure called #", N);
|
||||
if Dynamic_Elaboration_Checks then
|
||||
if Is_Generic_Unit (Ent) then
|
||||
Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
|
||||
elsif Is_Init_Proc (Ent) then
|
||||
Error_Msg_N ("\\?l?initialization procedure called #", N);
|
||||
elsif Is_Printable_Error_Name (Chars (Ent)) then
|
||||
Error_Msg_NE ("\\?l?& called #", N, Ent);
|
||||
else
|
||||
Error_Msg_N ("\\?l?called #", N);
|
||||
end if;
|
||||
|
||||
elsif Is_Printable_Error_Name (Chars (Ent)) then
|
||||
Error_Msg_NE ("\??& called #", N, Ent);
|
||||
-- Static elaboration model, info messages controlled by -gnatel
|
||||
|
||||
else
|
||||
Error_Msg_N ("\?? called #", N);
|
||||
if Is_Generic_Unit (Ent) then
|
||||
Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
|
||||
elsif Is_Init_Proc (Ent) then
|
||||
Error_Msg_N ("\\?$?initialization procedure called #", N);
|
||||
elsif Is_Printable_Error_Name (Chars (Ent)) then
|
||||
Error_Msg_NE ("\\?$?& called #", N, Ent);
|
||||
else
|
||||
Error_Msg_N ("\\?$?called #", N);
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
end Output_Calls;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue