From: Ghjuvan Lacambre Date: Wed, 27 Jan 2021 08:53:26 +0000 (+0100) Subject: [Ada] Implement basic support for -fdiagnostics-format=json X-Git-Tag: basepoints/gcc-13~6699 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=26373979deab7481b0503d86e80390ab65c65381;p=thirdparty%2Fgcc.git [Ada] Implement basic support for -fdiagnostics-format=json gcc/ada/ * back_end.adb (Scan_Back_End_Switches): Set Opt.JSON_Output to True if -fdiagnostics-format=json option is found. * back_end.ads (Scan_Compiler_Arguments): Mention Opt.JSON_Output. * errout.adb (Output_JSON_Message): New procedure. (Output_Messages): If Opt.JSON_Output is True, print messages with new Output_JSON_Message procedure. * opt.ads: Declare JSON_Output variable. * doc/gnat_ugn/building_executable_programs_with_gnat.rst: Mention new -fdiagnostics-format option. * gnat_ugn.texi: Regenerate. --- diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index a170ed5fbafb..42d837d1df91 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -281,6 +281,14 @@ package body Back_End is elsif Switch_Chars (First .. Last) = "fpreserve-control-flow" then Opt.Suppress_Control_Flow_Optimizations := True; + -- Back end switch -fdiagnostics-format=json tells the frontend to + -- output its error and warning messages in the same format GCC + -- uses when passed -fdiagnostics-format=json. + + elsif Switch_Chars (First .. Last) = "fdiagnostics-format=json" + then + Opt.JSON_Output := True; + -- Back end switch -fdump-scos, which exists primarily for C, is -- also accepted for Ada as a synonym of -gnateS. diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads index 8f8682558e3b..32a0ea34b238 100644 --- a/gcc/ada/back_end.ads +++ b/gcc/ada/back_end.ads @@ -70,6 +70,7 @@ package Back_End is -- Opt.Suppress_Control_Float_Optimizations -- Opt.Generate_SCO -- Opt.Generate_SCO_Instance_Table + -- Opt.JSON_Output -- Opt.Stack_Checking_Enabled -- Opt.No_Stdinc -- Opt.No_Stdlib diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 446e7cf1a2f2..0b5e71fb0b28 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -1233,6 +1233,13 @@ Alphabetical List of All Switches marker is specified, the callgraph is decorated with information about dynamically allocated objects. +.. index:: -fdiagnostics-format (gcc) + +:switch:`-fdiagnostics-format=json` + Makes GNAT emit warning and error messages as JSON. Inhibits printing of + text warning and errors messages except if :switch:`-gnatv` or + :switch:`-gnatl` are present. + .. index:: -fdump-scos (gcc) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 42a1099c8f4f..16f7aa3a85c6 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -130,6 +130,11 @@ package body Errout is -- or if it refers to an Etype that has an error posted on it, or if -- it references an Entity that has an error posted on it. + procedure Output_JSON_Message (Error_Id : Error_Msg_Id); + -- Output error message Error_Id and any subsequent continuation message + -- using a JSON format similar to the one GCC uses when passed + -- -fdiagnostics-format=json. + procedure Output_Source_Line (L : Physical_Line_Number; Sfile : Source_File_Index; @@ -2055,6 +2060,133 @@ package body Errout is end if; end OK_Node; + ------------------------- + -- Output_JSON_Message -- + ------------------------- + + procedure Output_JSON_Message (Error_Id : Error_Msg_Id) is + + procedure Write_JSON_Escaped_String (Str : String_Ptr); + -- Write each character of Str, taking care of preceding each quote and + -- backslash with a backslash. Note that this escaping differs from what + -- GCC does. + -- + -- Indeed, the JSON specification mandates encoding wide characters + -- either as their direct UTF-8 representation or as their escaped + -- UTF-16 surrogate pairs representation. GCC seems to prefer escaping - + -- we choose to use the UTF-8 representation instead. + + procedure Write_JSON_Location (Sptr : Source_Ptr); + -- Write Sptr as a JSON location, an object containing a file attribute, + -- a line number and a column number. + + procedure Write_JSON_Span (Span : Source_Span); + -- Write Span as a JSON span, an object containing a "caret" attribute + -- whose value is the JSON location of Span.Ptr. If Span.First and + -- Span.Last are different from Span.Ptr, they will be printed as JSON + -- locations under the names "start" and "finish". + + ------------------------------- + -- Write_JSON_Escaped_String -- + ------------------------------- + + procedure Write_JSON_Escaped_String (Str : String_Ptr) is + begin + for C of Str.all loop + if C = '"' or else C = '\' then + Write_Char ('\'); + end if; + + Write_Char (C); + end loop; + end Write_JSON_Escaped_String; + + ------------------------- + -- Write_JSON_Location -- + ------------------------- + + procedure Write_JSON_Location (Sptr : Source_Ptr) is + begin + Write_Str ("{""file"":"""); + Write_Name (Full_Ref_Name (Get_Source_File_Index (Sptr))); + Write_Str (""",""line"":"); + Write_Int (Pos (Get_Physical_Line_Number (Sptr))); + Write_Str (", ""column"":"); + Write_Int (Nat (Get_Column_Number (Sptr))); + Write_Str ("}"); + end Write_JSON_Location; + + --------------------- + -- Write_JSON_Span -- + --------------------- + + procedure Write_JSON_Span (Span : Source_Span) is + begin + Write_Str ("{""caret"":"); + Write_JSON_Location (Span.Ptr); + + if Span.Ptr /= Span.First then + Write_Str (",""start"":"); + Write_JSON_Location (Span.First); + end if; + + if Span.Ptr /= Span.Last then + Write_Str (",""finish"":"); + Write_JSON_Location (Span.Last); + end if; + + Write_Str ("}"); + end Write_JSON_Span; + + -- Local Variables + + E : Error_Msg_Id := Error_Id; + + -- Start of processing for Output_JSON_Message + + begin + + -- Print message kind + + Write_Str ("{""kind"":"); + + if Errors.Table (E).Warn and then not Errors.Table (E).Warn_Err then + Write_Str ("""warning"""); + elsif Errors.Table (E).Info or else Errors.Table (E).Check then + Write_Str ("""note"""); + else + Write_Str ("""error"""); + end if; + + -- Print message location + + Write_Str (",""locations"":["); + Write_JSON_Span (Errors.Table (E).Sptr); + + if Errors.Table (E).Optr /= Errors.Table (E).Sptr.Ptr then + Write_Str (",{""caret"":"); + Write_JSON_Location (Errors.Table (E).Optr); + Write_Str ("}"); + end if; + + -- Print message content + + Write_Str ("],""message"":"""); + Write_JSON_Escaped_String (Errors.Table (E).Text); + + -- Print message continuations if present + + E := E + 1; + + while E <= Last_Error_Msg and then Errors.Table (E).Msg_Cont loop + Write_Str (", "); + Write_JSON_Escaped_String (Errors.Table (E).Text); + E := E + 1; + end loop; + + Write_Str ("""}"); + end Output_JSON_Message; + --------------------- -- Output_Messages -- --------------------- @@ -2615,9 +2747,46 @@ package body Errout is Current_Error_Source_File := No_Source_File; end if; + if Opt.JSON_Output then + Set_Standard_Error; + + E := First_Error_Msg; + + -- Find first printable message + + while E /= No_Error_Msg and then Errors.Table (E).Deleted loop + E := Errors.Table (E).Next; + end loop; + + Write_Char ('['); + + if E /= No_Error_Msg then + + Output_JSON_Message (E); + + E := Errors.Table (E).Next; + + -- Skip deleted messages. + -- Also skip continuation messages, as they have already been + -- printed along the message they're attached to. + + while E /= No_Error_Msg + and then not Errors.Table (E).Deleted + and then not Errors.Table (E).Msg_Cont + loop + Write_Char (','); + Output_JSON_Message (E); + E := Errors.Table (E).Next; + end loop; + end if; + + Write_Char (']'); + + Set_Standard_Output; + -- Brief Error mode - if Brief_Output or (not Full_List and not Verbose_Mode) then + elsif Brief_Output or (not Full_List and not Verbose_Mode) then Set_Standard_Error; E := First_Error_Msg; @@ -2899,7 +3068,9 @@ package body Errout is Write_Error_Summary; end if; - Write_Max_Errors; + if not Opt.JSON_Output then + Write_Max_Errors; + end if; -- Even though Warning_Info_Messages are a subclass of warnings, they -- must not be treated as errors when -gnatwe is in effect. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index f7773c37b05e..369427ccf7b9 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -8581,6 +8581,18 @@ marker is specified, the callgraph is decorated with information about dynamically allocated objects. @end table +@geindex -fdiagnostics-format (gcc) + + +@table @asis + +@item @code{-fdiagnostics-format=json} + +Makes GNAT emit warning and error messages as JSON. Inhibits printing of +text warning and errors messages except if @code{-gnatv} or +@code{-gnatl} are present. +@end table + @geindex -fdump-scos (gcc) diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 5384bd9da3f7..827bbeff9c9a 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -915,6 +915,11 @@ package Opt is -- directory if these files already exist or in the source directory -- if not. + JSON_Output : Boolean := False; + -- GNAT + -- Output error and warning messages in JSON format. Set to true when the + -- backend option "-fdiagnostics-format=json" is found on the command line. + Keep_Going : Boolean := False; -- GNATMAKE, GPRBUILD -- When True signals to ignore compilation errors and keep processing