From patchwork Tue Aug 20 09:51:21 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1149985 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-507345-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="unmgNwrz"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46CR0j24fdz9sDQ for ; Tue, 20 Aug 2019 19:52:20 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=uu8Je1aNYNxqGL7CNTq3h8AfXC7aBuHgc8kVJ1P9+wBoYNwh6/ O+Tj6Ax6BFoIgkSGcil+g0AvybXBGoKkj2hSfBLGdXIbGZfIkmqszF5+1TadxC7x 5Def0WSDpnW+kNdg8IfT4QcdwcTsm+JMks0QJDG1m1pRqCsLwE5Q+Vmgg= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=MzJIPEHPo7RrCaUc74PrSA2fUYo=; b=unmgNwrz//aHahBhFTOA SXMPXEhW7qaW//BkvZITIg6/0H6ah+SxMkWCdPqGU+iGMwm4rJdRspiFseX2LO5Z LAX7edZloPV8bY74sEzz6AewH5UmWy0YlJ53NRKc0BsIjCvvo+Oh7D7xGikMrjaJ aMIaB0u/k/LW/yzp4ehOZME= Received: (qmail 121510 invoked by alias); 20 Aug 2019 09:51:27 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 121403 invoked by uid 89); 20 Aug 2019 09:51:27 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.7 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=licensed, txt, Reason, Txt X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 20 Aug 2019 09:51:22 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 4015A560BE; Tue, 20 Aug 2019 05:51:21 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id g+O2+fcTr+5P; Tue, 20 Aug 2019 05:51:21 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 2C5A9560BB; Tue, 20 Aug 2019 05:51:21 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 2B38663E; Tue, 20 Aug 2019 05:51:21 -0400 (EDT) Date: Tue, 20 Aug 2019 05:51:21 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [Ada] Pragma Warning_As_Error works for style warnings Message-ID: <20190820095120.GA75410@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes Pragma Warning_As_Error now works for style warnings (messages that start with "(style)", enabled by -gnaty) the same way it works for regular warnings enabled by -gnatw. The following test should fail to build with style checks: gnat.adc: pragma Warning_As_Error ("two spaces required"); style.adb: procedure Style is X : Integer; begin null; --Hello end; gnatmake -q -f -g style.adb -gnaty should get: style.adb:2:04: warning: variable "X" is never read and never assigned style.adb:5:06: error: (style) two spaces required [warning-as-error] style.adb:6:01: (style) "end Style" required gnatmake: "style.adb" compilation error and no executable should be created. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-20 Bob Duff gcc/ada/ * 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. --- gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -7467,18 +7467,21 @@ Syntax: 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 --- gcc/ada/errout.adb +++ gcc/ada/errout.adb @@ -1100,7 +1100,7 @@ package body Errout is -- 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))); --- gcc/ada/erroutc.adb +++ gcc/ada/erroutc.adb @@ -624,155 +624,145 @@ package body Erroutc is 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; - <> - if Start <= Split then - Write_Line (Txt (Start .. Split)); - Write_Spaces (Offs); - end if; + <> + 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; --------------------- --- gcc/ada/erroutc.ads +++ gcc/ada/erroutc.ads @@ -612,7 +612,7 @@ package Erroutc is 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); --- gcc/ada/gnat_rm.texi +++ gcc/ada/gnat_rm.texi @@ -8971,18 +8971,21 @@ pragma Warning_As_Error (static_string_EXPRESSION); @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 --- gcc/ada/opt.ads +++ gcc/ada/opt.ads @@ -1944,10 +1944,6 @@ package Opt is -- 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 @@ -2158,10 +2154,6 @@ package Opt is -- 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 @@ -2268,16 +2260,24 @@ package Opt is --------------------------- -- 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 -- --- gcc/ada/par-prag.adb +++ gcc/ada/par-prag.adb @@ -1088,6 +1088,21 @@ begin 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) -- --------------------- @@ -1519,7 +1534,6 @@ begin | Pragma_Volatile_Components | Pragma_Volatile_Full_Access | Pragma_Volatile_Function - | Pragma_Warning_As_Error | Pragma_Weak_External | Pragma_Validity_Checks => --- gcc/ada/sem_prag.adb +++ gcc/ada/sem_prag.adb @@ -3768,12 +3768,6 @@ package body Sem_Prag is 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 @@ -4400,32 +4394,6 @@ package body Sem_Prag is 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 -- --------------------- @@ -25301,10 +25269,10 @@ package body Sem_Prag is -- 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; -------------- @@ -25609,8 +25577,6 @@ package body Sem_Prag is -- 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 @@ -25630,22 +25596,27 @@ package body Sem_Prag is -- 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; --- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -247,6 +247,39 @@ package body Sem_Util is 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 -- -------------------------------- --- gcc/ada/sem_util.ads +++ gcc/ada/sem_util.ads @@ -42,6 +42,12 @@ package Sem_Util is -- 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. --- gcc/ada/stringt.adb +++ gcc/ada/stringt.adb @@ -350,6 +350,17 @@ package body Stringt is 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 -- --------------- --- gcc/ada/stringt.ads +++ gcc/ada/stringt.ads @@ -127,6 +127,9 @@ package Stringt is -- 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