[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 a170ed5fbafba143835715f1420e70bfe91a6b90..42d837d1df91f38880b578db5ae1b646eb1537c6 100644 (file)
--- 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 8f8682558e3bf11955a466309a3300626d6e5461..32a0ea34b238486bf7c8482fee95b6bd28da0ca3 100644 (file)
--- 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 446e7cf1a2f27029cbdef884930afad82a33c4af..0b5e71fb0b282a3a218afd7f34e2deb685583937 100644 (file)
--- 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 42a1099c8f4f2916d0b6ef9d867415441126a114..16f7aa3a85c6e2c3d43e03ec64cd0ff2730ed774 100644 (file)
--- 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 f7773c37b05e01e9fea4e79280628fcb1510c28a..369427ccf7b9414ed05bbf7bbbadf5aaff7c4599 100644 (file)
--- 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 5384bd9da3f778aeea460432c5d024c189597c8d..827bbeff9c9a79f4f4f62362857be7b46f271c96 100644 (file)
--- 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