+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.
-- 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 --
-----------------------
-- Start of processing for new message
Sindex := Get_Source_File_Index (Flag_Location);
- Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+ Prescan_Message (Msg);
Orig_Loc := Original_Location (Flag_Location);
-- If the current location is in an instantiation, the issue arises of
-- that style checks are not considered warning messages for this
-- purpose.
- if Is_Warning_Msg
- and then Warnings_Suppressed (Orig_Loc) /= No_String
+ if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
then
return;
-- 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
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
Continuation_New_Line := False;
Suppress_Message := False;
Kill_Message := False;
- Warning_Msg_Char := ' ';
Set_Msg_Text (Msg, Sptr);
-- Kill continuation if parent message killed
Line => Get_Physical_Line_Number (Sptr),
Col => Get_Column_Number (Sptr),
Warn => Is_Warning_Msg,
+ Info => Is_Info_Msg,
Warn_Err => False, -- reset below
Warn_Chr => Warning_Msg_Char,
Style => Is_Style_Msg,
return;
end if;
- Test_Style_Warning_Serious_Unconditional_Msg (Msg);
+ Prescan_Message (Msg);
-- Special handling for warning messages
C : Character; -- Current character
P : Natural; -- Current index;
- procedure Set_Msg_Insertion_Warning (C : Character);
- -- Deal with ? ?? ?x? ?X? insertion sequences (also < << <x< <X<). The
- -- caller has already bumped the pointer past the initial ? or < and C
- -- is set to this initial character (? or <).
+ procedure Skip_Msg_Insertion_Warning (C : Character);
+ -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
+ -- sequences using < instead of ?). The caller has already bumped
+ -- the pointer past the initial ? or < and C is set to this initial
+ -- character (? or <). This procedure skips past the rest of the
+ -- sequence. We do not need to set Msg_Insertion_Char, since this
+ -- was already done during the message prescan.
- -------------------------------
- -- Set_Msg_Insertion_Warning --
- -------------------------------
+ --------------------------------
+ -- Skip_Msg_Insertion_Warning --
+ --------------------------------
- procedure Set_Msg_Insertion_Warning (C : Character) is
+ procedure Skip_Msg_Insertion_Warning (C : Character) is
begin
if P <= Text'Last and then Text (P) = C then
- Warning_Msg_Char := '?';
P := P + 1;
elsif P + 1 <= Text'Last
or else
Text (P) in 'A' .. 'Z'
or else
- Text (P) = '*')
+ Text (P) = '*'
+ or else
+ Text (P) = '$')
and then Text (P + 1) = C
then
- Warning_Msg_Char := Text (P);
P := P + 2;
- else
- Warning_Msg_Char := ' ';
end if;
- end Set_Msg_Insertion_Warning;
+ end Skip_Msg_Insertion_Warning;
-- Start of processing for Set_Msg_Text
Msglen := 0;
Flag_Source := Get_Source_File_Index (Flag);
- P := Text'First;
+ -- Skip info: at start, we have recorded this in Is_Info_Msg, and this
+ -- will be used (Info field in error message object) to put back the
+ -- string when it is printed. We need to do this, or we get confused
+ -- with instantiation continuations.
+
+ if Text'Length > 6
+ and then Text (Text'First .. Text'First + 5) = "info: "
+ then
+ P := Text'First + 6;
+ else
+ P := Text'First;
+ end if;
+
+ -- Loop through characters of message
+
while P <= Text'Last loop
C := Text (P);
P := P + 1;
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
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;
-- 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 --
-- 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.
-- "[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.
-- 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 --
----------------------------------------
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
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);
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');
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);
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 --
--------------------
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
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 --
--------------------------------
-- 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
-- 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
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)")
-- 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.
-- 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,
-- --
-- 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- --
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
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;
-- --
-- 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- --
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;
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
-- --
-- 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- --
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;
-- --
-- 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- --
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;
-
- procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
- function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
-
- 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;
-
- 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);
-
- -----------
- -- Equal --
- -----------
-
- 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;
+ type Hash_Val is mod 2 ** 8;
+ subtype Hash_Idx is Hash_Val range 1 .. 37;
+
+ 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.
+
+ -- Local Subprograms
+
+ generic
+ with procedure Process (T : Exception_Data_Ptr; More : out Boolean);
+ procedure Iterate;
+ -- Iterate over all
+
+ 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;
+
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;
+
+ begin
+ 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;
- function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
begin
- return T.HTable_Ptr;
- end Get_HT_Link;
+ 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 --
(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.
- begin
- Lock_Task.all;
- Last := List'First - 1;
+ procedure Get_All is new Iterate (Get_One);
+ -- Store all registered exceptions in List, updating Last
- while Last < List'Last and then Data /= null loop
- Last := Last + 1;
- List (Last) := Data;
- Data := Exception_HTable.Get_Next;
- end loop;
+ -------------
+ -- Get_One --
+ -------------
- Unlock_Task.all;
- end Get_Registered_Exceptions;
+ 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;
- ----------
- -- Hash --
- ----------
+ else
+ More := False;
+ end if;
+ end Get_One;
- function Hash (F : System.Address) return HTable_Headers is
- type S is mod 2**8;
+ begin
+ -- In this routine the invariant is that List (List'First .. Last)
+ -- contains the registered exceptions retrieved so far.
- Str : constant Big_String_Ptr := To_Ptr (F);
- Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
- Tmp : S := 0;
- J : Positive;
+ Last := List'First - 1;
- 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;
+ Lock_Task.all;
+ Get_All;
+ Unlock_Task.all;
+ end Get_Registered_Exceptions;
------------------------
-- Internal_Exception --
(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',
Foreign_Data => Null_Address,
Raise_Hook => null);
- Register_Exception (Res);
+ Register (Result);
end if;
- return Res;
+ Unlock_Task.all;
+
+ return Result;
end Internal_Exception;
------------------------
procedure Register_Exception (X : Exception_Data_Ptr) is
begin
- Exception_HTable.Set (X);
+ Lock_Task.all;
+ Register (X);
+ Unlock_Task.all;
end Register_Exception;
---------------------------------
function Registered_Exceptions_Count return Natural is
Count : Natural := 0;
- Data : Exception_Data_Ptr := Exception_HTable.Get_First;
- begin
- -- We need to lock the runtime in the meantime, to avoid concurrent
- -- access since we have only one iterator.
-
- Lock_Task.all;
+ procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean);
+ -- Update Count for given Item
- while Data /= null loop
+ procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is
+ pragma Unreferenced (Item);
+ begin
Count := Count + 1;
- Data := Exception_HTable.Get_Next;
- end loop;
+ More := Count < Natural'Last;
+ end Count_Item;
- Unlock_Task.all;
- return Count;
- end Registered_Exceptions_Count;
-
- -----------------
- -- Set_HT_Link --
- -----------------
+ procedure Count_All is new Iterate (Count_Item);
- procedure Set_HT_Link
- (T : Exception_Data_Ptr;
- Next : Exception_Data_Ptr)
- is
begin
- T.HTable_Ptr := Next;
- end Set_HT_Link;
+ Lock_Task.all;
+ Count_All;
+ Unlock_Task.all;
--- Register the standard exceptions at elaboration time
+ return Count;
+ end Registered_Exceptions_Count;
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;
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;
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;
-- 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
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;
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
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
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
elsif Access_Case then
Elab_Warning
- ("", "info: access to& during elaboration?", Ent);
+ ("", "info: access to& during elaboration?$?", Ent);
-- Subprogram call case
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;
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;
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
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;
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);
-- 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
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;
projects / thirdparty / gcc.git / commitdiff
