+2019-08-20 Bob Duff <duff@adacore.com>
+
+ * errout.adb (Error_Msg_Internal): Set Warn_Err in case of
+ Is_Style_Msg.
+ * erroutc.adb (Output_Msg_Text): Do Warnings_Treated_As_Errors
+ processing and [warning-as-error] modification for style
+ messages. Clean up code, simplify, remove unnecessary block
+ statement, add renaming of table entry.
+ * erroutc.ads (Warning_Treated_As_Error): Fix comment: no such
+ thing as Set_Warning_As_Error.
+ * opt.ads: Clean up comments and move related declarations near
+ each other.
+ * par-prag.adb: Process Warning_As_Error. This is necessary
+ because many style warning happen during parsing.
+ * sem_prag.adb: Use new Acquire_Warning_Match_String.
+ * sem_util.ads, sem_util.adb (Acquire_Warning_Match_String): New
+ function shared by par-prag.adb and sem_prag.adb. Replaces the
+ procedure in sem_prag.adb. Avoid use of global variables.
+ * stringt.ads, stringt.adb (To_String): New function to convert
+ String_Id to String.
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Document the
+ new feature.
+ * gnat_rm.texi: Regenerate.
+
2019-08-20 Eric Botcazou <ebotcazou@adacore.com>
* lib.ads: Add with clause for GNAT.HTable.
This configuration pragma allows the programmer to specify a set
-of warnings that will be treated as errors. Any warning which
+of warnings that will be treated as errors. Any warning that
matches the pattern given by the pragma argument will be treated
-as an error. This gives much more precise control that -gnatwe
-which treats all warnings as errors.
-
-The pattern may contain asterisks, which match zero or more characters in
-the message. For example, you can use
-``pragma Warning_As_Error ("bits of*unused")`` to treat the warning
-message ``warning: 960 bits of "a" unused`` as an error. No other regular
-expression notations are permitted. All characters other than asterisk in
-these three specific cases are treated as literal characters in the match.
-The match is case insensitive, for example XYZ matches xyz.
+as an error. This gives more precise control than -gnatwe,
+which treats warnings as errors.
+
+This pragma can apply to regular warnings (messages enabled by -gnatw)
+and to style warnings (messages that start with "(style)",
+enabled by -gnaty).
+
+The pattern may contain asterisks, which match zero or more characters
+in the message. For example, you can use ``pragma Warning_As_Error
+("bits of*unused")`` to treat the warning message ``warning: 960 bits of
+"a" unused`` as an error. All characters other than asterisk are treated
+as literal characters in the match. The match is case insensitive; for
+example XYZ matches xyz.
Note that the pattern matches if it occurs anywhere within the warning
message string (it is not necessary to put an asterisk at the start and
-- Test if warning to be treated as error
Warn_Err :=
- Is_Warning_Msg
+ (Is_Warning_Msg or Is_Style_Msg)
and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
or else
Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
Length : Nat;
-- Maximum total length of lines
- Text : constant String_Ptr := Errors.Table (E).Text;
+ E_Msg : Error_Msg_Object renames Errors.Table (E);
+ Text : constant String_Ptr := E_Msg.Text;
Ptr : Natural;
Split : Natural;
Start : Natural;
+ Tag : constant String := Get_Warning_Tag (E);
+ Txt : String_Ptr;
+ Len : Natural;
begin
- declare
- Tag : constant String := Get_Warning_Tag (E);
- Txt : String_Ptr;
- Len : Natural;
+ -- Postfix warning tag to message if needed
- begin
- -- Postfix warning tag to message if needed
-
- if Tag /= "" and then Warning_Doc_Switch then
- if Include_Subprogram_In_Messages then
- Txt :=
- new String'
- (Subprogram_Name_Ptr (Errors.Table (E).Node) &
- ": " & Text.all & ' ' & Tag);
- else
- Txt := new String'(Text.all & ' ' & Tag);
- end if;
-
- elsif Include_Subprogram_In_Messages
- and then (Errors.Table (E).Warn or else Errors.Table (E).Style)
- then
+ if Tag /= "" and then Warning_Doc_Switch then
+ if Include_Subprogram_In_Messages then
Txt :=
new String'
- (Subprogram_Name_Ptr (Errors.Table (E).Node) &
- ": " & Text.all);
+ (Subprogram_Name_Ptr (E_Msg.Node) &
+ ": " & Text.all & ' ' & Tag);
else
- Txt := Text;
+ Txt := new String'(Text.all & ' ' & Tag);
end if;
- -- Deal with warning case
-
- if Errors.Table (E).Warn or else Errors.Table (E).Info then
+ elsif Include_Subprogram_In_Messages
+ and then (E_Msg.Warn or else E_Msg.Style)
+ then
+ Txt :=
+ new String'(Subprogram_Name_Ptr (E_Msg.Node) & ": " & Text.all);
+ else
+ Txt := Text;
+ end if;
- -- For info messages, prefix message with "info: "
+ -- For info messages, prefix message with "info: "
- if Errors.Table (E).Info then
- Txt := new String'("info: " & Txt.all);
+ if E_Msg.Info then
+ Txt := new String'("info: " & Txt.all);
- -- Warning treated as error
+ -- Warning treated as error
- elsif Errors.Table (E).Warn_Err then
+ elsif E_Msg.Warn_Err then
- -- We prefix with "error:" rather than warning: and postfix
- -- [warning-as-error] at the end.
+ -- 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]");
+ Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1;
+ Txt := new String'("error: " & Txt.all & " [warning-as-error]");
- -- Normal case, prefix with "warning: "
+ -- Normal warning, prefix with "warning: "
- else
- Txt := new String'("warning: " & Txt.all);
- end if;
+ elsif E_Msg.Warn then
+ Txt := new String'("warning: " & Txt.all);
- -- No prefix needed for style message, "(style)" is there already
+ -- No prefix needed for style message, "(style)" is there already
- elsif Errors.Table (E).Style then
- null;
+ elsif E_Msg.Style then
+ null;
- -- No prefix needed for check message, severity is there already
+ -- No prefix needed for check message, severity is there already
- elsif Errors.Table (E).Check then
- null;
+ elsif E_Msg.Check then
+ null;
- -- All other cases, add "error: " if unique error tag set
+ -- All other cases, add "error: " if unique error tag set
- elsif Opt.Unique_Error_Tag then
- Txt := new String'("error: " & Txt.all);
- end if;
+ elsif Opt.Unique_Error_Tag then
+ Txt := new String'("error: " & Txt.all);
+ end if;
- -- Set error message line length and length of message
+ -- Set error message line length and length of message
- if Error_Msg_Line_Length = 0 then
- Length := Nat'Last;
- else
- Length := Error_Msg_Line_Length;
- end if;
+ if Error_Msg_Line_Length = 0 then
+ Length := Nat'Last;
+ else
+ Length := Error_Msg_Line_Length;
+ end if;
- Max := Integer (Length - Column + 1);
- Len := Txt'Length;
+ Max := Integer (Length - Column + 1);
+ Len := Txt'Length;
- -- Here we have to split the message up into multiple lines
+ -- Here we have to split the message up into multiple lines
- Ptr := 1;
- loop
- -- Make sure we do not have ludicrously small line
+ Ptr := 1;
+ loop
+ -- Make sure we do not have ludicrously small line
- Max := Integer'Max (Max, 20);
+ Max := Integer'Max (Max, 20);
- -- If remaining text fits, output it respecting LF and we are done
+ -- If remaining text fits, output it respecting LF and we are done
- if Len - Ptr < Max then
- for J in Ptr .. Len loop
- if Txt (J) = ASCII.LF then
- Write_Eol;
- Write_Spaces (Offs);
- else
- Write_Char (Txt (J));
- end if;
- end loop;
+ if Len - Ptr < Max then
+ for J in Ptr .. Len loop
+ if Txt (J) = ASCII.LF then
+ Write_Eol;
+ Write_Spaces (Offs);
+ else
+ Write_Char (Txt (J));
+ end if;
+ end loop;
- return;
+ return;
- -- Line does not fit
+ -- Line does not fit
- else
- Start := Ptr;
+ else
+ Start := Ptr;
- -- First scan forward looking for a hard end of line
+ -- First scan forward looking for a hard end of line
- for Scan in Ptr .. Ptr + Max - 1 loop
- if Txt (Scan) = ASCII.LF then
- Split := Scan - 1;
- Ptr := Scan + 1;
- goto Continue;
- end if;
- end loop;
+ for Scan in Ptr .. Ptr + Max - 1 loop
+ if Txt (Scan) = ASCII.LF then
+ Split := Scan - 1;
+ Ptr := Scan + 1;
+ goto Continue;
+ end if;
+ end loop;
- -- Otherwise scan backwards looking for a space
+ -- Otherwise scan backwards looking for a space
- for Scan in reverse Ptr .. Ptr + Max - 1 loop
- if Txt (Scan) = ' ' then
- Split := Scan - 1;
- Ptr := Scan + 1;
- goto Continue;
- end if;
- end loop;
+ for Scan in reverse Ptr .. Ptr + Max - 1 loop
+ if Txt (Scan) = ' ' then
+ Split := Scan - 1;
+ Ptr := Scan + 1;
+ goto Continue;
+ end if;
+ end loop;
- -- If we fall through, no space, so split line arbitrarily
+ -- If we fall through, no space, so split line arbitrarily
- Split := Ptr + Max - 1;
- Ptr := Split + 1;
- end if;
+ Split := Ptr + Max - 1;
+ Ptr := Split + 1;
+ end if;
- <<Continue>>
- if Start <= Split then
- Write_Line (Txt (Start .. Split));
- Write_Spaces (Offs);
- end if;
+ <<Continue>>
+ if Start <= Split then
+ Write_Line (Txt (Start .. Split));
+ Write_Spaces (Offs);
+ end if;
- Max := Integer (Length - Column + 1);
- end loop;
- end;
+ Max := Integer (Length - Column + 1);
+ end loop;
end Output_Msg_Text;
---------------------
function Warning_Treated_As_Error (Msg : String) return Boolean;
-- Returns True if the warning message Msg matches any of the strings
-- given by Warning_As_Error pragmas, as stored in the Warnings_As_Errors
- -- table by Set_Warning_As_Error.
+ -- table.
type Error_Msg_Proc is
access procedure (Msg : String; Flag_Location : Source_Ptr);
@end example
This configuration pragma allows the programmer to specify a set
-of warnings that will be treated as errors. Any warning which
+of warnings that will be treated as errors. Any warning that
matches the pattern given by the pragma argument will be treated
-as an error. This gives much more precise control that -gnatwe
-which treats all warnings as errors.
-
-The pattern may contain asterisks, which match zero or more characters in
-the message. For example, you can use
-@code{pragma Warning_As_Error ("bits of*unused")} to treat the warning
-message @code{warning: 960 bits of "a" unused} as an error. No other regular
-expression notations are permitted. All characters other than asterisk in
-these three specific cases are treated as literal characters in the match.
-The match is case insensitive, for example XYZ matches xyz.
+as an error. This gives more precise control than -gnatwe,
+which treats warnings as errors.
+
+This pragma can apply to regular warnings (messages enabled by -gnatw)
+and to style warnings (messages that start with "(style)",
+enabled by -gnaty).
+
+The pattern may contain asterisks, which match zero or more characters
+in the message. For example, you can use @code{pragma Warning_As_Error
+("bits of*unused")} to treat the warning message @code{warning: 960 bits of
+"a" unused} as an error. All characters other than asterisk are treated
+as literal characters in the match. The match is case insensitive; for
+example XYZ matches xyz.
Note that the pattern matches if it occurs anywhere within the warning
message string (it is not necessary to put an asterisk at the start and
-- which requires pragma Warnings to be stored for the formal verification
-- backend.
- Warnings_As_Errors_Count : Natural;
- -- GNAT
- -- Number of entries stored in Warnings_As_Errors table
-
Wide_Character_Encoding_Method : WC_Encoding_Method := WCEM_Brackets;
-- GNAT, GNATBIND
-- Method used for encoding wide characters in the source program. See
-- is ignored for internal and predefined units (which are always compiled
-- with the standard Size semantics).
- Warnings_As_Errors_Count_Config : Natural;
- -- GNAT
- -- Count of pattern strings stored from Warning_As_Error pragmas
-
type Config_Switches_Type is private;
-- Type used to save values of the switches set from Config values
---------------------------
-- The following array would more reasonably be located in Err_Vars or
- -- Errour, but we put them here to deal with licensing issues (we need
+ -- Errout, but we put them here to deal with licensing issues (we need
-- this to have the GPL exception licensing, since these variables and
-- subprograms are accessed from units with this licensing).
Warnings_As_Errors : array (1 .. 10_000) of String_Ptr;
- -- Table for recording Warning_As_Error pragmas as they are processed.
- -- It would be nicer to use Table, but there are circular elaboration
- -- problems if we try to do this, and an attempt to find some other
- -- appropriately licensed unit to declare this as a Table failed with
- -- various elaboration circularities. Memory is getting cheap these days!
+ -- Table for recording Warning_As_Error pragmas as they are processed. It
+ -- would be nicer to use Table, but there are circular elaboration problems
+ -- if we try to do this, and an attempt to find some other appropriately
+ -- licensed unit to declare this as a Table failed with various elaboration
+ -- circularities.
+
+ Warnings_As_Errors_Count : Natural;
+ -- GNAT
+ -- Number of entries stored in Warnings_As_Errors table
+
+ Warnings_As_Errors_Count_Config : Natural;
+ -- GNAT
+ -- Count of pattern strings stored from Warning_As_Error pragmas
---------------
-- GNAT_Mode --
when Pragma_Suppress_All =>
Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit));
+ ----------------------
+ -- Warning_As_Error --
+ ----------------------
+
+ -- pragma Warning_As_Error (static_string_EXPRESSION);
+
+ -- Further processing is done in Sem_Prag
+
+ when Pragma_Warning_As_Error =>
+ Check_Arg_Count (1);
+ Check_Arg_Is_String_Literal (Arg1);
+ Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
+ Warnings_As_Errors (Warnings_As_Errors_Count) :=
+ new String'(Acquire_Warning_Match_String (Get_Pragma_Arg (Arg1)));
+
---------------------
-- Warnings (GNAT) --
---------------------
| Pragma_Volatile_Components
| Pragma_Volatile_Full_Access
| Pragma_Volatile_Function
- | Pragma_Warning_As_Error
| Pragma_Weak_External
| Pragma_Validity_Checks
=>
function Acc_Next (N : Node_Id) return Node_Id;
-- Helper function to iterate over arguments given to OpenAcc pragmas
- procedure Acquire_Warning_Match_String (Arg : Node_Id);
- -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
- -- get the given string argument, and place it in Name_Buffer, adding
- -- leading and trailing asterisks if they are not already present. The
- -- caller has already checked that Arg is a static string expression.
-
procedure Ada_2005_Pragma;
-- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
-- Ada 95 mode, these are implementation defined pragmas, so should be
end if;
end Acc_Next;
- ----------------------------------
- -- Acquire_Warning_Match_String --
- ----------------------------------
-
- procedure Acquire_Warning_Match_String (Arg : Node_Id) is
- begin
- String_To_Name_Buffer
- (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
-
- -- Add asterisk at start if not already there
-
- if Name_Len > 0 and then Name_Buffer (1) /= '*' then
- Name_Buffer (2 .. Name_Len + 1) :=
- Name_Buffer (1 .. Name_Len);
- Name_Buffer (1) := '*';
- Name_Len := Name_Len + 1;
- end if;
-
- -- Add asterisk at end if not already there
-
- if Name_Buffer (Name_Len) /= '*' then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := '*';
- end if;
- end Acquire_Warning_Match_String;
-
---------------------
-- Ada_2005_Pragma --
---------------------
-- OK static string expression
else
- Acquire_Warning_Match_String (Arg1);
Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
Warnings_As_Errors (Warnings_As_Errors_Count) :=
- new String'(Name_Buffer (1 .. Name_Len));
+ new String'(Acquire_Warning_Match_String
+ (Expr_Value_S (Get_Pragma_Arg (Arg1))));
end if;
--------------
-- Static string expression case
else
- Acquire_Warning_Match_String (Arg2);
-
-- Note on configuration pragma case: If this is a
-- configuration pragma, then for an OFF pragma, we
-- just set Config True in the call, which is all
-- generic unit we are inside is public, but for now
-- we don't bother with that refinement.
- if Chars (Argx) = Name_Off then
- Set_Specific_Warning_Off
- (Loc, Name_Buffer (1 .. Name_Len), Reason,
- Config => Is_Configuration_Pragma,
- Used => Inside_A_Generic or else In_Instance);
-
- elsif Chars (Argx) = Name_On then
- Set_Specific_Warning_On
- (Loc, Name_Buffer (1 .. Name_Len), Err);
-
- if Err then
- Error_Msg
- ("??pragma Warnings On with no matching "
- & "Warnings Off", Loc);
+ declare
+ Message : constant String :=
+ Acquire_Warning_Match_String
+ (Expr_Value_S (Get_Pragma_Arg (Arg2)));
+ begin
+ if Chars (Argx) = Name_Off then
+ Set_Specific_Warning_Off
+ (Loc, Message, Reason,
+ Config => Is_Configuration_Pragma,
+ Used => Inside_A_Generic or else In_Instance);
+
+ elsif Chars (Argx) = Name_On then
+ Set_Specific_Warning_On (Loc, Message, Err);
+
+ if Err then
+ Error_Msg
+ ("??pragma Warnings On with no matching "
+ & "Warnings Off", Loc);
+ end if;
end if;
- end if;
+ end;
end if;
end;
end if;
return Interface_List (Nod);
end Abstract_Interface_List;
+ ----------------------------------
+ -- Acquire_Warning_Match_String --
+ ----------------------------------
+
+ function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String is
+ S : constant String := To_String (Strval (Str_Lit));
+ begin
+ if S = "" then
+ return "";
+ else
+ -- Put "*" before or after or both, if it's not already there
+
+ declare
+ F : constant Boolean := S (S'First) = '*';
+ L : constant Boolean := S (S'Last) = '*';
+ begin
+ if F then
+ if L then
+ return S;
+ else
+ return S & "*";
+ end if;
+ else
+ if L then
+ return "*" & S;
+ else
+ return "*" & S & "*";
+ end if;
+ end if;
+ end;
+ end if;
+ end Acquire_Warning_Match_String;
+
--------------------------------
-- Add_Access_Type_To_Process --
--------------------------------
-- including the cases where there can't be any because e.g. the type is
-- not tagged.
+ function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String;
+ -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get
+ -- the given string argument, adding leading and trailing asterisks if they
+ -- are not already present. Str_Lit is the static value of the pragma
+ -- argument.
+
procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id);
-- Add A to the list of access types to process when expanding the
-- freeze node of E.
return Strings.Table (First_String_Id)'Address;
end Strings_Address;
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (S : String_Id) return String is
+ Buf : Bounded_String;
+ begin
+ Append (Buf, S);
+ return To_String (Buf);
+ end To_String;
+
---------------
-- Tree_Read --
---------------
-- out of Character range. Does not attempt to do any encoding of
-- characters.
+ function To_String (S : String_Id) return String;
+ -- Return S as a String
+
procedure String_To_Name_Buffer (S : String_Id);
-- Place characters of given string in Name_Buffer, setting Name_Len.
-- Error if any characters are out of Character range. Does not attempt
projects / gcc.git / commitdiff