From 6d13d38e28cf50b9ad29ab2cae058e18afbc457e Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Thu, 5 Feb 2015 13:51:44 +0000 Subject: [PATCH] par-prag.adb (Pragma_Warnings): Update for extended form of pragma Warnings. 2015-02-05 Yannick Moy * par-prag.adb (Pragma_Warnings): Update for extended form of pragma Warnings. The "one" argument case may now have 2 or 3 arguments. * sem_prag.adb (Analyze_Pragma/Pragma_Warnings): Update for extended form of pragma Warnings. Pragma with tool name is either rewritten as null or as an equivalent form without tool name, before reanalysis. * snames.ads-tmpl (Name_Gnatprove): New name. From-SVN: r220447 --- gcc/ada/ChangeLog | 11 +++ gcc/ada/par-prag.adb | 167 ++++++++++++++++++++++++++++++---------- gcc/ada/sem_prag.adb | 79 +++++++++++++++++-- gcc/ada/snames.ads-tmpl | 3 +- 4 files changed, 210 insertions(+), 50 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bd6f02ad88d..12820727269 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2015-02-05 Yannick Moy + + * par-prag.adb (Pragma_Warnings): Update for extended form + of pragma Warnings. The "one" argument case may now have 2 or + 3 arguments. + * sem_prag.adb (Analyze_Pragma/Pragma_Warnings): Update for + extended form of pragma Warnings. Pragma with tool name is either + rewritten as null or as an equivalent form without tool name, + before reanalysis. + * snames.ads-tmpl (Name_Gnatprove): New name. + 2015-02-05 Robert Dewar * sem_ch13.adb (Add_Invariants): Don't assume invariant is diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 93cbf94cadb..1b72a29f939 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1047,10 +1047,13 @@ begin -- Warnings (GNAT) -- --------------------- - -- pragma Warnings (On | Off [,REASON]); - -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]); - -- pragma Warnings (static_string_EXPRESSION [,REASON]); - -- pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]); + -- pragma Warnings ([TOOL_NAME,] On | Off [,REASON]); + -- pragma Warnings ([TOOL_NAME,] On | Off, LOCAL_NAME [,REASON]); + -- pragma Warnings ([TOOL_NAME,] static_string_EXPRESSION [,REASON]); + -- pragma Warnings ([TOOL_NAME,] On | Off, + -- static_string_EXPRESSION [,REASON]); + + -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} -- The one argument ON/OFF case is processed by the parser, since it may -- control parser warnings as well as semantic warnings, and in any case @@ -1058,50 +1061,132 @@ begin -- set well before any semantic analysis is performed. Note that we -- ignore this pragma if debug flag -gnatd.i is set. - -- Also note that the "one argument" case may have two arguments if the - -- second one is a reason argument. + -- Also note that the "one argument" case may have two or three + -- arguments if the first one is a tool name, and/or the last one is a + -- reason argument. - when Pragma_Warnings => - if not Debug_Flag_Dot_I - and then (Arg_Count = 1 - or else (Arg_Count = 2 - and then Chars (Arg2) = Name_Reason)) - then - Check_No_Identifier (Arg1); + -- Need documentation and syntax for TOOL_NAME ??? - declare - Argx : constant Node_Id := Expression (Arg1); + when Pragma_Warnings => Warnings : declare + function First_Arg_Is_Matching_Tool_Name return Boolean; + -- Returns True if the first argument is a tool name matching the + -- current tool being run. - function Get_Reason return String_Id; - -- Analyzes Reason argument and returns corresponding String_Id - -- value, or null if there is no Reason argument, or if the - -- argument is not of the required form. + function Last_Arg return Node_Id; + -- Returns the last argument - ---------------- - -- Get_Reason -- - ---------------- + function Last_Arg_Is_Reason return Boolean; + -- Returns True if the last argument is a reason argument - function Get_Reason return String_Id is - begin - if Arg_Count = 1 then - return Null_String_Id; - else - Start_String; - Get_Reason_String (Expression (Arg2)); - return End_String; - end if; - end Get_Reason; + function Get_Reason return String_Id; + -- Analyzes Reason argument and returns corresponding String_Id + -- value, or null if there is no Reason argument, or if the + -- argument is not of the required form. - begin - if Nkind (Argx) = N_Identifier then - if Chars (Argx) = Name_On then - Set_Warnings_Mode_On (Pragma_Sloc); - elsif Chars (Argx) = Name_Off then - Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); - end if; + ------------------------------------- + -- First_Arg_Is_Matching_Tool_Name -- + ------------------------------------- + + -- Comments needed for these complex conditionals ??? + + function First_Arg_Is_Matching_Tool_Name return Boolean is + begin + return Nkind (Arg1) = N_Identifier + and then ((Chars (Arg1) = Name_Gnat + and then not + (CodePeer_Mode or GNATprove_Mode or ASIS_Mode)) + or else + (Chars (Arg1) = Name_Gnatprove + and then GNATprove_Mode)); + end First_Arg_Is_Matching_Tool_Name; + + ---------------- + -- Get_Reason -- + ---------------- + + function Get_Reason return String_Id is + Arg : constant Node_Id := Last_Arg; + begin + if Last_Arg_Is_Reason then + Start_String; + Get_Reason_String (Expression (Arg)); + return End_String; + else + return Null_String_Id; + end if; + end Get_Reason; + + -------------- + -- Last_Arg -- + -------------- + + function Last_Arg return Node_Id is + Last_Arg : Node_Id; + + begin + if Arg_Count = 1 then + Last_Arg := Arg1; + elsif Arg_Count = 2 then + Last_Arg := Arg2; + elsif Arg_Count = 3 then + Last_Arg := Arg3; + elsif Arg_Count = 4 then + Last_Arg := Next (Arg3); + + -- Illegal case, error issued in semantic analysis + + else + Last_Arg := Empty; + end if; + + return Last_Arg; + end Last_Arg; + + ------------------------ + -- Last_Arg_Is_Reason -- + ------------------------ + + function Last_Arg_Is_Reason return Boolean is + Arg : constant Node_Id := Last_Arg; + begin + return Nkind (Arg) in N_Has_Chars + and then Chars (Arg) = Name_Reason; + end Last_Arg_Is_Reason; + + The_Arg : Node_Id; -- On/Off argument + Argx : Node_Id; + + -- Start of processing for Warnings + + begin + if not Debug_Flag_Dot_I + and then (Arg_Count = 1 + or else (Arg_Count = 2 + and then (First_Arg_Is_Matching_Tool_Name + or else + Last_Arg_Is_Reason)) + or else (Arg_Count = 3 + and then First_Arg_Is_Matching_Tool_Name + and then Last_Arg_Is_Reason)) + then + if First_Arg_Is_Matching_Tool_Name then + The_Arg := Arg2; + else + The_Arg := Arg1; + end if; + + Check_No_Identifier (The_Arg); + Argx := Expression (The_Arg); + + if Nkind (Argx) = N_Identifier then + if Chars (Argx) = Name_On then + Set_Warnings_Mode_On (Pragma_Sloc); + elsif Chars (Argx) = Name_Off then + Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); end if; - end; + end if; end if; + end Warnings; ----------------------------- -- Wide_Character_Encoding -- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0567c176b9a..ab72e0d6514 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -21323,12 +21323,18 @@ package body Sem_Prag is -- Warnings -- -------------- - -- pragma Warnings (On | Off [,REASON]); - -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]); - -- pragma Warnings (static_string_EXPRESSION [,REASON]); - -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]); + -- pragma Warnings ([TOOL_NAME,] On | Off [,REASON]); + -- pragma Warnings ([TOOL_NAME,] On | Off, LOCAL_NAME [,REASON]); + -- pragma Warnings ([TOOL_NAME,] static_string_EXPRESSION [,REASON]); + -- pragma Warnings ([TOOL_NAME,] On | Off, + -- static_string_EXPRESSION [,REASON]); - -- REASON ::= Reason => Static_String_Expression + -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} + + -- If present, TOOL_NAME refers to a tool, currently either GNAT + -- or GNATprove. If an identifier is a static string expression, + -- the form of pragma Warnings that starts with a static string + -- expression is used. when Pragma_Warnings => Warnings : declare Reason : String_Id; @@ -21338,9 +21344,10 @@ package body Sem_Prag is Check_At_Least_N_Arguments (1); -- See if last argument is labeled Reason. If so, make sure we - -- have a static string expression, and acquire the REASON string. - -- Then remove the REASON argument by decreasing Num_Args by one; - -- Remaining processing looks only at first Num_Args arguments). + -- have a string literal or a concatenation of string literals, + -- and acquire the REASON string. Then remove the REASON argument + -- by decreasing Num_Args by one; Remaining processing looks only + -- at first Num_Args arguments). declare Last_Arg : constant Node_Id := @@ -21380,8 +21387,64 @@ package body Sem_Prag is declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + Shifted_Args : List_Id; begin + -- See if first argument is a tool name, currently either + -- GNAT or GNATprove. If so, either ignore the pragma if the + -- tool used does not match, or continue as if no tool name + -- was given otherwise, by shifting the arguments. + + if Nkind (Argx) = N_Identifier + and then not Nam_In (Chars (Argx), Name_On, Name_Off) + and then not Is_Static_String_Expression (Arg1) + -- How can this possibly work e.g. for GNATprove??? + then + if Chars (Argx) = Name_Gnat then + if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + raise Pragma_Exit; + end if; + + elsif Chars (Argx) = Name_Gnatprove then + if not GNATprove_Mode then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + raise Pragma_Exit; + end if; + + else + Error_Pragma_Arg + ("argument of pragma% must be On/Off or tool name " + & "or static string expression", Arg1); + end if; + + -- At this point, the pragma Warnings applies to the tool, + -- so continue with shifted arguments. + + Arg_Count := Arg_Count - 1; + + if Arg_Count = 1 then + Shifted_Args := New_List (New_Copy (Arg2)); + elsif Arg_Count = 2 then + Shifted_Args := New_List (New_Copy (Arg2), + New_Copy (Arg3)); + elsif Arg_Count = 3 then + Shifted_Args := New_List (New_Copy (Arg2), + New_Copy (Arg3), + New_Copy (Arg4)); + else + raise Program_Error; + end if; + + Rewrite (N, Make_Pragma (Loc, + Chars => Name_Warnings, + Pragma_Argument_Associations => Shifted_Args)); + Analyze (N); + raise Pragma_Exit; + end if; + -- One argument case if Arg_Count = 1 then diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index fec0545ad98..47a8ccd07e2 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -713,6 +713,7 @@ package Snames is Name_Gcc : constant Name_Id := N + $; Name_General : constant Name_Id := N + $; Name_Gnat : constant Name_Id := N + $; + Name_Gnatprove : constant Name_Id := N + $; Name_GPL : constant Name_Id := N + $; Name_High_Order_First : constant Name_Id := N + $; Name_IEEE_Float : constant Name_Id := N + $; -- 2.30.2