ada: Use absolute paths in SARIF reports

gcc/ada/ChangeLog:

	* diagnostics-json_utils.adb: Add new method To_File_Uri to
	convert any path to the URI standard.
	* diagnostics-json_utils.ads: Likewise.
	* diagnostics-sarif_emitter.adb: Converted Artifact_Change
	types to use the Source_File_Index instead of the file name
	to store the source file.
	Removed the body from Destroy (Elem : in out Artifact_Change)
	since it no longer contained elements with dynamic memory.
	Updated the implementation of Equals (L, R : Artifact_Change)
	to take into account the changes for Artifact_Change.
	Print_Artifact_Location: Use the Source_File_Index as an
	input argument. Now prints the uriBaseId attribute and a
	relative path from the uriBaseId to the file in question as
	the value of the uri attribute.
	New method Print_Original_Uri_Base_Ids to print the
	originalUriBaseIds node.
	Print_Run no prints the originalUriBaseIds node.
	Use constants instead of strings for all the SARIF attributes.
	* osint.adb: Add new method Relative_Path to calculate the
	relative path from a base directory.
	Add new method Root to calculate the root of each directory.
	Add new method Get_Current_Dir to get the current working
	directory for the execution environment.
	* osint.ads: Likewise.
	* clean.adb: Use full names for calls to Get_Current_Dir.
	* gnatls.adb: Likewise.

diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index f28cf691cf9d3903003952d5e241ff798a079b77..dcbeffe1b8e98e05f86bf8469bc603e7a7ba7683 100644 (file)
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -319,7 +319,9 @@ package body Clean is
                   Delete ("", Executable);
                end if;
 
-               Delete_Binder_Generated_Files (Get_Current_Dir, Source);
+               Delete_Binder_Generated_Files
+                 (GNAT.Directory_Operations.Get_Current_Dir,
+                  Source);
             end;
          end if;
       end loop;
@@ -405,7 +407,8 @@ package body Clean is
       Source : File_Name_Type)
    is
       Source_Name : constant String   := Get_Name_String (Source);
-      Current     : constant String   := Get_Current_Dir;
+      Current : constant String :=
+        GNAT.Directory_Operations.Get_Current_Dir;
       Last        : constant Positive := B_Start'Length + Source_Name'Length;
       File_Name   : String (1 .. Last + 4);
 

diff --git a/gcc/ada/diagnostics-json_utils.adb b/gcc/ada/diagnostics-json_utils.adb
index 072cab4a4928cca595d20c6ef248bf038903222b..8ce04c4631f6cfb361f97392f53a1793f20008dd 100644 (file)
--- a/gcc/ada/diagnostics-json_utils.adb
+++ b/gcc/ada/diagnostics-json_utils.adb
@@ -22,7 +22,11 @@
 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
 --                                                                          --
 ------------------------------------------------------------------------------
+
+with Namet; use Namet;
+with Osint;
 with Output; use Output;
+with System.OS_Lib;
 
 package body Diagnostics.JSON_Utils is
 
@@ -64,6 +68,141 @@ package body Diagnostics.JSON_Utils is
       end if;
    end NL_And_Indent;
 
+   -----------------
+   -- To_File_Uri --
+   -----------------
+
+   function To_File_Uri (Path : String) return String is
+
+      function Normalize_Uri (Path : String) return String;
+      --  Construct a normalized URI from the path name by replacing reserved
+      --  URI characters that can appear in paths with their escape character
+      --  combinations.
+      --
+      --  According to the URI standard reserved charcthers within the paths
+      --  should be percent encoded:
+      --
+      --  https://www.rfc-editor.org/info/rfc3986
+      --
+      --  Reserved charcters are defined as:
+      --
+      --  reserved = gen-delims / sub-delims
+      --  gen-delims = ":" / "/" / "?" / "#" / "[" / "]" / "@"
+      --  sub-delims = "!" / "$" / "&" / "’" / "(" / ")"
+      --  / "*" / "+" / "," / ";" / "="
+
+      -------------------
+      -- Normalize_Uri --
+      -------------------
+
+      function Normalize_Uri (Path : String) return String is
+         Buf : Bounded_String;
+      begin
+         for C of Path loop
+            case C is
+               when '\' =>
+
+                  --  Use forward slashes instead of backward slashes as
+                  --  separators on Windows and on Linux simply encode the
+                  --  symbol if part of a directory name.
+
+                  if Osint.On_Windows then
+                     Append (Buf, '/');
+                  else
+                     Append (Buf, "%5C");
+                  end if;
+
+               when ' ' =>
+                  Append (Buf, "%20");
+
+               when '!' =>
+                  Append (Buf, "%21");
+
+               when '#' =>
+                  Append (Buf, "%23");
+
+               when '$' =>
+                  Append (Buf, "%24");
+
+               when '&' =>
+                  Append (Buf, "%26");
+
+               when ''' =>
+                  Append (Buf, "%27");
+
+               when '(' =>
+                  Append (Buf, "%28");
+
+               when ')' =>
+                  Append (Buf, "%29");
+
+               when '*' =>
+                  Append (Buf, "%2A");
+
+               when '+' =>
+                  Append (Buf, "%2A");
+
+               when ',' =>
+                  Append (Buf, "%2A");
+
+               when '/' =>
+                  --  Forward slash is a valid file separator on both Unix and
+                  --  Windows based machines and should be treated as such
+                  --  within a path.
+                  Append (Buf, '/');
+
+               when ':' =>
+                  Append (Buf, "%3A");
+
+               when ';' =>
+                  Append (Buf, "%3B");
+
+               when '=' =>
+                  Append (Buf, "%3D");
+
+               when '?' =>
+                  Append (Buf, "%3F");
+
+               when '@' =>
+                  Append (Buf, "%40");
+
+               when '[' =>
+                  Append (Buf, "%5B");
+
+               when ']' =>
+                  Append (Buf, "%5D");
+
+               when others =>
+                  Append (Buf, C);
+            end case;
+         end loop;
+
+         return To_String (Buf);
+      end Normalize_Uri;
+
+      Norm_Uri : constant String := Normalize_Uri (Path);
+
+   --  Start of processing for To_File_Uri
+
+   begin
+      if System.OS_Lib.Is_Absolute_Path (Path) then
+         --  URI-s using the file scheme should start with the following
+         --  prefix:
+         --
+         --  "file:///"
+
+         if Osint.On_Windows then
+            return "file:///" & Norm_Uri;
+         else
+            --  Full paths on linux based systems already start with '/'
+
+            return "file://" & Norm_Uri;
+         end if;
+      else
+         return Norm_Uri;
+      end if;
+   end To_File_Uri;
+
    -----------------------------
    -- Write_Boolean_Attribute --
    -----------------------------

diff --git a/gcc/ada/diagnostics-json_utils.ads b/gcc/ada/diagnostics-json_utils.ads
index 526e09e49cd68da1c64c5e06aed58f6766d0eeba..75adc08b40b9a0642393452fdc8b938c2b404e85 100644 (file)
--- a/gcc/ada/diagnostics-json_utils.ads
+++ b/gcc/ada/diagnostics-json_utils.ads
@@ -49,6 +49,11 @@ package Diagnostics.JSON_Utils is
    procedure NL_And_Indent;
    --  Print a new line
 
+   function To_File_Uri (Path : String) return String;
+   --  Converts an absolute Path into a file URI string by adding the file
+   --  schema prefix "file:///" and replacing all of the URI reserved
+   --  characters in the absolute path.
+
    procedure Write_Boolean_Attribute (Name : String; Value : Boolean);
    --  Write a JSON attribute with a boolean value.
    --

diff --git a/gcc/ada/diagnostics-sarif_emitter.adb b/gcc/ada/diagnostics-sarif_emitter.adb
index 31b3154d5a349b93474de8ba385c3e848f1a49ea..bae2dc0a88e6aebe5139d6a8c07fd3899038a436 100644 (file)
--- a/gcc/ada/diagnostics-sarif_emitter.adb
+++ b/gcc/ada/diagnostics-sarif_emitter.adb
@@ -23,18 +23,56 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Diagnostics.Utils;      use Diagnostics.Utils;
-with Diagnostics.JSON_Utils; use Diagnostics.JSON_Utils;
-with Gnatvsn;                use Gnatvsn;
-with Output;                 use Output;
-with Sinput;                 use Sinput;
-with Lib;                    use Lib;
-with Namet;                  use Namet;
-with Osint;                  use Osint;
-with Errout;                 use Errout;
+with Errout;                    use Errout;
+with Diagnostics.JSON_Utils;    use Diagnostics.JSON_Utils;
+with Diagnostics.Utils;         use Diagnostics.Utils;
+with Gnatvsn;                   use Gnatvsn;
+with Lib;                       use Lib;
+with Namet;                     use Namet;
+with Osint;                     use Osint;
+with Output;                    use Output;
+with Sinput;                    use Sinput;
+with System.OS_Lib;
 
 package body Diagnostics.SARIF_Emitter is
 
+   --  SARIF attribute names
+
+   N_ARTIFACT_CHANGES      : constant String := "artifactChanges";
+   N_ARTIFACT_LOCATION     : constant String := "artifactLocation";
+   N_COMMAND_LINE          : constant String := "commandLine";
+   N_DELETED_REGION        : constant String := "deletedRegion";
+   N_DESCRIPTION           : constant String := "description";
+   N_DRIVER                : constant String := "driver";
+   N_END_COLUMN            : constant String := "endColumn";
+   N_END_LINE              : constant String := "endLine";
+   N_EXECUTION_SUCCESSFUL  : constant String := "executionSuccessful";
+   N_FIXES                 : constant String := "fixes";
+   N_ID                    : constant String := "id";
+   N_INSERTED_CONTENT      : constant String := "insertedContent";
+   N_INVOCATIONS           : constant String := "invocations";
+   N_LOCATIONS             : constant String := "locations";
+   N_LEVEL                 : constant String := "level";
+   N_MESSAGE               : constant String := "message";
+   N_NAME                  : constant String := "name";
+   N_ORIGINAL_URI_BASE_IDS : constant String := "originalUriBaseIds";
+   N_PHYSICAL_LOCATION     : constant String := "physicalLocation";
+   N_REGION                : constant String := "region";
+   N_RELATED_LOCATIONS     : constant String := "relatedLocations";
+   N_REPLACEMENTS          : constant String := "replacements";
+   N_RESULTS               : constant String := "results";
+   N_RULES                 : constant String := "rules";
+   N_RULE_ID               : constant String := "ruleId";
+   N_RUNS                  : constant String := "runs";
+   N_SCHEMA                : constant String := "$schema";
+   N_START_COLUMN          : constant String := "startColumn";
+   N_START_LINE            : constant String := "strartLine";
+   N_TEXT                  : constant String := "text";
+   N_TOOL                  : constant String := "tool";
+   N_URI                   : constant String := "uri";
+   N_URI_BASE_ID           : constant String := "uriBaseId";
+   N_VERSION               : constant String := "version";
+
    --  We are currently using SARIF 2.1.0
 
    SARIF_Version : constant String := "2.1.0";
@@ -43,21 +81,28 @@ package body Diagnostics.SARIF_Emitter is
      "https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json";
    pragma Style_Checks ("M79");
 
+   URI_Base_Id_Name : constant String := "PWD";
+   --  We use the pwd as the originalUriBaseIds when providing absolute paths
+   --  in locations.
+
+   Current_Dir : constant String := Get_Current_Dir;
+   --  Cached value of the current directory that is used in the URI_Base_Id
+   --  and it is also the path that all other Uri attributes will be created
+   --  relative to.
+
    type Artifact_Change is record
-      File  : String_Ptr;
-      --  Name of the file
+      File_Index  : Source_File_Index;
+      --  Index for the source file
 
       Replacements : Edit_List;
       --  Regions of texts to be edited
    end record;
 
-   procedure Destroy (Elem : in out Artifact_Change);
+   procedure Destroy (Elem : in out Artifact_Change) is null;
    pragma Inline (Destroy);
 
    function Equals (L, R : Artifact_Change) return Boolean is
-     (L.File /= null
-      and then R.File /= null
-      and then L.File.all = R.File.all);
+     (L.File_Index = R.File_Index);
 
    package Artifact_Change_Lists is new Doubly_Linked_Lists
      (Element_Type    => Artifact_Change,
@@ -119,11 +164,12 @@ package body Diagnostics.SARIF_Emitter is
    --    replacements: [<Replacements>]
    --  }
 
-   procedure Print_Artifact_Location (File_Name : String);
+   procedure Print_Artifact_Location (Sfile : Source_File_Index);
    --  Print an artifactLocation node
    --
    --   "artifactLocation": {
-   --     "URI": <File_Name>
+   --     "uri": <File_Name>,
+   --     "uriBaseId": "PWD"
    --   }
 
    procedure Print_Location (Loc : Labeled_Span_Type;
@@ -140,7 +186,7 @@ package body Diagnostics.SARIF_Emitter is
    --    },
    --    "physicalLocation": {
    --      "artifactLocation": {
-   --        "URI": <File_Name (Loc)>
+   --        "uri": <File_Name (Loc)>
    --      },
    --      "region": {
    --        "startLine": <Line(Loc.Fst)>,
@@ -159,13 +205,25 @@ package body Diagnostics.SARIF_Emitter is
    --      <Location (Primary_Span (Diag))>
    --   ],
 
-   procedure Print_Message (Text : String; Name : String := "message");
-   --  Print a SARIF message node
+   procedure Print_Message (Text : String; Name : String := N_MESSAGE);
+   --  Print a SARIF message node.
+   --
+   --  There are many message type nodes in the SARIF report however they can
+   --  have a different node <Name>.
    --
-   --  "message": {
+   --  <Name>: {
    --    "text": <text>
    --  },
 
+   procedure Print_Original_Uri_Base_Ids;
+   --  Print the originalUriBaseIds that holds the PWD value
+   --
+   --  "originalUriBaseIds": {
+   --    "PWD": {
+   --      "uri": "<current_working_directory>"
+   --    }
+   --  },
+
    procedure Print_Related_Locations (Diag : Diagnostic_Type);
    --  Print a relatedLocations node that consists of multiple location nodes.
    --  Related locations are the non-primary spans of the diagnostic and the
@@ -179,7 +237,7 @@ package body Diagnostics.SARIF_Emitter is
                            Start_Col  : Int;
                            End_Line   : Int;
                            End_Col    : Int;
-                           Name       : String := "region");
+                           Name       : String := N_REGION);
    --  Print a region node.
    --
    --  More specifically a text region node that specifies the textual
@@ -271,17 +329,6 @@ package body Diagnostics.SARIF_Emitter is
    --    }
    --  }
 
-   -------------
-   -- Destroy --
-   -------------
-
-   procedure Destroy (Elem : in out Artifact_Change)
-   is
-
-   begin
-      Free (Elem.File);
-   end Destroy;
-
    --------------------------
    -- Get_Artifact_Changes --
    --------------------------
@@ -304,7 +351,7 @@ package body Diagnostics.SARIF_Emitter is
          while Artifact_Change_Lists.Has_Next (It) loop
             Artifact_Change_Lists.Next (It, A);
 
-            if A.File.all = To_File_Name (E.Span.Ptr) then
+            if A.File_Index = Get_Source_File_Index (E.Span.Ptr) then
                Edit_Lists.Append (A.Replacements, E);
                return;
             end if;
@@ -316,7 +363,7 @@ package body Diagnostics.SARIF_Emitter is
             Edit_Lists.Append (Replacements, E);
             Artifact_Change_Lists.Append
               (Changes,
-               (File  => new String'(To_File_Name (E.Span.Ptr)),
+               (File_Index   => Get_Source_File_Index (E.Span.Ptr),
                 Replacements => Replacements));
          end;
       end Insert;
@@ -402,12 +449,12 @@ package body Diagnostics.SARIF_Emitter is
 
       --  Print artifactLocation
 
-      Print_Artifact_Location (A.File.all);
+      Print_Artifact_Location (A.File_Index);
 
       Write_Char (',');
       NL_And_Indent;
 
-      Write_Str ("""" & "replacements" & """" & ": " & "[");
+      Write_Str ("""" & N_REPLACEMENTS & """" & ": " & "[");
       Begin_Block;
       NL_And_Indent;
 
@@ -443,14 +490,53 @@ package body Diagnostics.SARIF_Emitter is
    -- Print_Artifact_Location --
    -----------------------------
 
-   procedure Print_Artifact_Location (File_Name : String) is
-
+   procedure Print_Artifact_Location (Sfile : Source_File_Index) is
+      Full_Name : constant String := Get_Name_String (Full_Ref_Name (Sfile));
    begin
-      Write_Str ("""" & "artifactLocation" & """" & ": " & "{");
+      Write_Str ("""" & N_ARTIFACT_LOCATION & """" & ": " & "{");
       Begin_Block;
       NL_And_Indent;
 
-      Write_String_Attribute ("uri", File_Name);
+      if System.OS_Lib.Is_Absolute_Path (Full_Name) then
+         declare
+            Abs_Name : constant String :=
+              System.OS_Lib.Normalize_Pathname
+                (Name => Full_Name, Resolve_Links => False);
+         begin
+            --  We cannot create relative paths between different drives on
+            --  Windows. If the path is on a different drive than the PWD print
+            --  the absolute path in the URI and omit the baseUriId attribute.
+
+            if Osint.On_Windows
+              and then Abs_Name (Abs_Name'First) =
+                Current_Dir (Current_Dir'First)
+            then
+               Write_String_Attribute
+                 (N_URI, To_File_Uri (Abs_Name));
+            else
+               Write_String_Attribute
+                 (N_URI,
+                  To_File_Uri
+                    (Relative_Path (Abs_Name, Current_Dir)));
+
+               Write_Char (',');
+               NL_And_Indent;
+
+               Write_String_Attribute
+                 (N_URI_BASE_ID, URI_Base_Id_Name);
+            end if;
+         end;
+      else
+         --  If the path was not absolute it was given relative to the
+         --  uriBaseId.
+
+         Write_String_Attribute (N_URI, To_File_Uri (Full_Name));
+
+         Write_Char (',');
+         NL_And_Indent;
+
+         Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name);
+      end if;
 
       End_Block;
       NL_And_Indent;
@@ -482,13 +568,13 @@ package body Diagnostics.SARIF_Emitter is
                     Start_Col  => Col_Fst,
                     End_Line   => Line_Lst,
                     End_Col    => Col_Lst,
-                    Name       => "deletedRegion");
+                    Name       => N_DELETED_REGION);
 
       if Replacement.Text /= null then
          Write_Char (',');
          NL_And_Indent;
 
-         Print_Message (Replacement.Text.all, "insertedContent");
+         Print_Message (Replacement.Text.all, N_INSERTED_CONTENT);
       end if;
 
       --  End replacement
@@ -512,7 +598,7 @@ package body Diagnostics.SARIF_Emitter is
       --  Print the message if the location has one
 
       if Fix.Description /= null then
-         Print_Message (Fix.Description.all, "description");
+         Print_Message (Fix.Description.all, N_DESCRIPTION);
 
          Write_Char (',');
          NL_And_Indent;
@@ -524,7 +610,7 @@ package body Diagnostics.SARIF_Emitter is
          A       : Artifact_Change;
          A_It    : Iterator := Iterate (Changes);
       begin
-         Write_Str ("""" & "artifactChanges" & """" & ": " & "[");
+         Write_Str ("""" & N_ARTIFACT_CHANGES & """" & ": " & "[");
          Begin_Block;
 
          while Has_Next (A_It) loop
@@ -564,7 +650,7 @@ package body Diagnostics.SARIF_Emitter is
 
       First : Boolean := True;
    begin
-      Write_Str ("""" & "fixes" & """" & ": " & "[");
+      Write_Str ("""" & N_FIXES & """" & ": " & "[");
       Begin_Block;
 
       if Present (Diag.Fixes) then
@@ -616,7 +702,7 @@ package body Diagnostics.SARIF_Emitter is
       end Compose_Command_Line;
 
    begin
-      Write_Str ("""" & "invocations" & """" & ": " & "[");
+      Write_Str ("""" & N_INVOCATIONS & """" & ": " & "[");
       Begin_Block;
       NL_And_Indent;
 
@@ -626,13 +712,13 @@ package body Diagnostics.SARIF_Emitter is
 
       --  Print commandLine
 
-      Write_String_Attribute ("commandLine", Compose_Command_Line);
+      Write_String_Attribute (N_COMMAND_LINE, Compose_Command_Line);
       Write_Char (',');
       NL_And_Indent;
 
       --  Print executionSuccessful
 
-      Write_Boolean_Attribute ("executionSuccessful", Compilation_Errors);
+      Write_Boolean_Attribute (N_EXECUTION_SUCCESSFUL, Compilation_Errors);
 
       End_Block;
       NL_And_Indent;
@@ -651,7 +737,7 @@ package body Diagnostics.SARIF_Emitter is
                            Start_Col  : Int;
                            End_Line   : Int;
                            End_Col    : Int;
-                           Name       : String := "region")
+                           Name       : String := N_REGION)
    is
 
    begin
@@ -659,22 +745,22 @@ package body Diagnostics.SARIF_Emitter is
       Begin_Block;
       NL_And_Indent;
 
-      Write_Int_Attribute ("startLine", Start_Line);
+      Write_Int_Attribute (N_START_LINE, Start_Line);
       Write_Char (',');
       NL_And_Indent;
 
-      Write_Int_Attribute ("startColumn", Start_Col);
+      Write_Int_Attribute (N_START_COLUMN, Start_Col);
       Write_Char (',');
       NL_And_Indent;
 
-      Write_Int_Attribute ("endLine", End_Line);
+      Write_Int_Attribute (N_END_LINE, End_Line);
       Write_Char (',');
       NL_And_Indent;
 
       --  Convert the end of the span to the definition of the endColumn
       --  for a SARIF region.
 
-      Write_Int_Attribute ("endColumn", End_Col + 1);
+      Write_Int_Attribute (N_END_COLUMN, End_Col + 1);
 
       End_Block;
       NL_And_Indent;
@@ -713,13 +799,13 @@ package body Diagnostics.SARIF_Emitter is
          NL_And_Indent;
       end if;
 
-      Write_Str ("""" & "physicalLocation" & """" & ": " & "{");
+      Write_Str ("""" & N_PHYSICAL_LOCATION & """" & ": " & "{");
       Begin_Block;
       NL_And_Indent;
 
       --  Print artifactLocation
 
-      Print_Artifact_Location (To_File_Name (Loc.Span.Ptr));
+      Print_Artifact_Location (Get_Source_File_Index (Loc.Span.Ptr));
 
       Write_Char (',');
       NL_And_Indent;
@@ -751,7 +837,7 @@ package body Diagnostics.SARIF_Emitter is
 
       First : Boolean := True;
    begin
-      Write_Str ("""" & "locations" & """" & ": " & "[");
+      Write_Str ("""" & N_LOCATIONS & """" & ": " & "[");
       Begin_Block;
 
       while Has_Next (It) loop
@@ -782,18 +868,43 @@ package body Diagnostics.SARIF_Emitter is
    -- Print_Message --
    -------------------
 
-   procedure Print_Message (Text : String; Name : String := "message") is
+   procedure Print_Message (Text : String; Name : String := N_MESSAGE) is
 
    begin
       Write_Str ("""" & Name & """" & ": " & "{");
       Begin_Block;
       NL_And_Indent;
-      Write_String_Attribute ("text", Text);
+      Write_String_Attribute (N_TEXT, Text);
       End_Block;
       NL_And_Indent;
       Write_Char ('}');
    end Print_Message;
 
+   ---------------------------------
+   -- Print_Original_Uri_Base_Ids --
+   ---------------------------------
+
+   procedure Print_Original_Uri_Base_Ids is
+   begin
+      Write_Str ("""" & N_ORIGINAL_URI_BASE_IDS & """" & ": " & "{");
+      Begin_Block;
+      NL_And_Indent;
+
+      Write_Str ("""" & URI_Base_Id_Name & """" & ": " & "{");
+      Begin_Block;
+      NL_And_Indent;
+
+      Write_String_Attribute (N_URI, To_File_Uri (Current_Dir));
+
+      End_Block;
+      NL_And_Indent;
+      Write_Char ('}');
+
+      End_Block;
+      NL_And_Indent;
+      Write_Char ('}');
+   end Print_Original_Uri_Base_Ids;
+
    -----------------------------
    -- Print_Related_Locations --
    -----------------------------
@@ -808,7 +919,7 @@ package body Diagnostics.SARIF_Emitter is
 
       First : Boolean := True;
    begin
-      Write_Str ("""" & "relatedLocations" & """" & ": " & "[");
+      Write_Str ("""" & N_RELATED_LOCATIONS & """" & ": " & "[");
       Begin_Block;
 
       --  Related locations are the non-primary spans of the diagnostic
@@ -908,14 +1019,14 @@ package body Diagnostics.SARIF_Emitter is
 
       --  Print ruleId
 
-      Write_String_Attribute ("ruleId", "[" & To_String (Diag.Id) & "]");
+      Write_String_Attribute (N_RULE_ID, "[" & To_String (Diag.Id) & "]");
 
       Write_Char (',');
       NL_And_Indent;
 
       --  Print level
 
-      Write_String_Attribute ("level", Kind_To_String (Diag));
+      Write_String_Attribute (N_LEVEL, Kind_To_String (Diag));
 
       Write_Char (',');
       NL_And_Indent;
@@ -964,7 +1075,7 @@ package body Diagnostics.SARIF_Emitter is
 
       First : Boolean := True;
    begin
-      Write_Str ("""" & "results" & """" & ": " & "[");
+      Write_Str ("""" & N_RESULTS & """" & ": " & "[");
       Begin_Block;
 
       if Present (Diags) then
@@ -998,14 +1109,14 @@ package body Diagnostics.SARIF_Emitter is
       Begin_Block;
       NL_And_Indent;
 
-      Write_String_Attribute ("id", "[" & To_String (Diag.Id) & "]");
+      Write_String_Attribute (N_ID, "[" & To_String (Diag.Id) & "]");
       Write_Char (',');
       NL_And_Indent;
 
       if Human_Id = null then
-         Write_String_Attribute ("name", "Uncategorized_Diagnostic");
+         Write_String_Attribute (N_NAME, "Uncategorized_Diagnostic");
       else
-         Write_String_Attribute ("name", Human_Id.all);
+         Write_String_Attribute (N_NAME, Human_Id.all);
       end if;
 
       End_Block;
@@ -1027,7 +1138,7 @@ package body Diagnostics.SARIF_Emitter is
 
       First : Boolean := True;
    begin
-      Write_Str ("""" & "rules" & """" & ": " & "[");
+      Write_Str ("""" & N_RULES & """" & ": " & "[");
       Begin_Block;
 
       while Has_Next (It) loop
@@ -1056,23 +1167,23 @@ package body Diagnostics.SARIF_Emitter is
    procedure Print_Tool (Diags : Diagnostic_List) is
 
    begin
-      Write_Str ("""" & "tool" & """" & ": " & "{");
+      Write_Str ("""" & N_TOOL & """" & ": " & "{");
       Begin_Block;
       NL_And_Indent;
 
       --  --  Attributes of tool
 
-      Write_Str ("""" & "driver" & """" & ": " & "{");
+      Write_Str ("""" & N_DRIVER & """" & ": " & "{");
       Begin_Block;
       NL_And_Indent;
 
       --  Attributes of tool.driver
 
-      Write_String_Attribute ("name", "GNAT");
+      Write_String_Attribute (N_NAME, "GNAT");
       Write_Char (',');
       NL_And_Indent;
 
-      Write_String_Attribute ("version", Gnat_Version_String);
+      Write_String_Attribute (N_VERSION, Gnat_Version_String);
       Write_Char (',');
       NL_And_Indent;
 
@@ -1100,7 +1211,7 @@ package body Diagnostics.SARIF_Emitter is
    procedure Print_Runs (Diags : Diagnostic_List) is
 
    begin
-      Write_Str ("""" & "runs" & """" & ": " & "[");
+      Write_Str ("""" & N_RUNS & """" & ": " & "[");
       Begin_Block;
       NL_And_Indent;
 
@@ -1124,6 +1235,10 @@ package body Diagnostics.SARIF_Emitter is
       Write_Char (',');
       NL_And_Indent;
 
+      Print_Original_Uri_Base_Ids;
+      Write_Char (',');
+      NL_And_Indent;
+
       --  A run consists of results
 
       Print_Results (Diags);
@@ -1153,11 +1268,11 @@ package body Diagnostics.SARIF_Emitter is
       Begin_Block;
       NL_And_Indent;
 
-      Write_String_Attribute ("$schema", SARIF_Schema);
+      Write_String_Attribute (N_SCHEMA, SARIF_Schema);
       Write_Char (',');
       NL_And_Indent;
 
-      Write_String_Attribute ("version", SARIF_Version);
+      Write_String_Attribute (N_VERSION, SARIF_Version);
       Write_Char (',');
       NL_And_Indent;
 

diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 4e549a98c29718eb63a89ceb90f4d400e39ed1be..6fa2327e724469b230df9f039599c62ac0c3feee 100644 (file)
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -1605,7 +1605,9 @@ procedure Gnatls is
                Name_Len := 0;
 
                if not Is_Absolute_Path (Self (First .. Last)) then
-                  Add_Str_To_Name_Buffer (Get_Current_Dir);  -- ??? System call
+                  Add_Str_To_Name_Buffer
+                    (GNAT.Directory_Operations.Get_Current_Dir);
+
                   Add_Char_To_Name_Buffer (Directory_Separator);
                end if;
 

diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index bf2affed70f718393a4b1ea9fe4bebad3bb919cb..46334aa97af1ca8dda211e62f4e5a2815a228362 100644 (file)
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -64,6 +64,14 @@ package body Osint is
    --  Used in Locate_File as a fake directory when Name is already an
    --  absolute path.
 
+   procedure Get_Current_Dir
+     (Dir : System.Address; Length : System.Address);
+   pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
+
+   Max_Path : Integer;
+   pragma Import (C, Max_Path, "__gnat_max_path_len");
+   --  Maximum length of a path name
+
    -------------------------------------
    -- Use of Name_Find and Name_Enter --
    -------------------------------------
@@ -1426,6 +1434,18 @@ package body Osint is
       Smart_Find_File (N, Source, Full_File, Attr.all);
    end Full_Source_Name;
 
+   ---------------------
+   -- Get_Current_Dir --
+   ---------------------
+
+   function Get_Current_Dir return String is
+      Current_Dir : String (1 .. Max_Path + 1);
+      Last        : Natural;
+   begin
+      Get_Current_Dir (Current_Dir'Address, Last'Address);
+      return Current_Dir (1 .. Last);
+   end Get_Current_Dir;
+
    -------------------
    -- Get_Directory --
    -------------------
@@ -1517,15 +1537,6 @@ package body Osint is
      (Search_Dir : String;
       File_Type  : Search_File_Type) return String_Ptr
    is
-      procedure Get_Current_Dir
-        (Dir    : System.Address;
-         Length : System.Address);
-      pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
-
-      Max_Path : Integer;
-      pragma Import (C, Max_Path, "__gnat_max_path_len");
-      --  Maximum length of a path name
-
       Current_Dir        : String_Ptr;
       Default_Search_Dir : String_Access;
       Default_Suffix_Dir : String_Access;
@@ -2731,6 +2742,76 @@ package body Osint is
       pragma Assert (Hi = Src'Last);
    end Read_Source_File;
 
+   -------------------
+   -- Relative_Path --
+   -------------------
+
+   function Relative_Path (Path : String; Ref : String) return String is
+      Norm_Path : constant String :=
+        Normalize_Pathname (Name => Path, Resolve_Links => False);
+      Norm_Ref  : constant String :=
+        Normalize_Pathname (Name => Ref, Resolve_Links => False);
+      Rel_Path : Bounded_String;
+      Last     : Natural := Norm_Ref'Last;
+      Old      : Natural;
+      Depth    : Natural := 0;
+
+   begin
+      pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Path));
+      pragma Assert (System.OS_Lib.Is_Absolute_Path (Norm_Ref));
+      pragma Assert (System.OS_Lib.Is_Directory (Norm_Ref));
+
+      --  If the root drives are different on Windows then we cannot create a
+      --  relative path.
+
+      if Root (Norm_Path) /= Root (Norm_Ref) then
+         return Norm_Path;
+      end if;
+
+      if Norm_Path = Norm_Ref then
+         return ".";
+      end if;
+
+      loop
+         exit when Last - Norm_Ref'First + 1 <= Norm_Path'Length
+           and then
+             Norm_Path
+               (Norm_Path'First ..
+                    Norm_Path'First + Last - Norm_Ref'First) =
+             Norm_Ref (Norm_Ref'First .. Last);
+
+         Old := Last;
+         for J in reverse Norm_Ref'First .. Last - 1 loop
+            if Is_Directory_Separator (Norm_Ref (J)) then
+               Depth := Depth + 1;
+               Last  := J;
+               exit;
+            end if;
+         end loop;
+
+         if Old = Last then
+            --  No Dir_Separator in Ref... Let's return Path
+            return Norm_Path;
+         end if;
+      end loop;
+
+      --  Move up the directory chain to the common point
+
+      for I in 1 .. Depth loop
+         Append (Rel_Path, ".." & System.OS_Lib.Directory_Separator);
+      end loop;
+
+      --  Add the rest of the path from the common point
+
+      Append
+        (Rel_Path,
+         Norm_Path
+           (Norm_Path'First + Last - Norm_Ref'First + 1 ..
+                Norm_Path'Last));
+
+      return To_String (Rel_Path);
+   end Relative_Path;
+
    -------------------
    -- Relocate_Path --
    -------------------
@@ -2788,6 +2869,25 @@ package body Osint is
       return new String'(Path);
    end Relocate_Path;
 
+   ----------
+   -- Root --
+   ----------
+
+   function Root (Path : String) return String is
+      Last : Natural := Path'First;
+   begin
+      pragma Assert (System.OS_Lib.Is_Absolute_Path (Path));
+
+      for I in Path'Range loop
+         if Is_Directory_Separator (Path (I)) then
+            Last := I;
+            exit;
+         end if;
+      end loop;
+
+      return Path (Path'First .. Last);
+   end Root;
+
    -----------------
    -- Set_Program --
    -----------------

diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index 041af4101dd8223c70d1efdb34a8562dfc152f65..5dbbfd8fd7ff1feb9f3be284d23365c8dbaa3986 100644 (file)
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -166,6 +166,9 @@ package Osint is
    function Is_Directory_Separator (C : Character) return Boolean;
    --  Returns True if C is a directory separator
 
+   function Get_Current_Dir return String;
+   --  Returns the current working directory for the execution environment
+
    function Get_Directory (Name : File_Name_Type) return File_Name_Type;
    --  Get the prefix directory name (if any) from Name. The last separator
    --  is preserved. Return the normalized current directory if there is no
@@ -230,6 +233,10 @@ package Osint is
      (Canonical_File : String) return String_Access;
    --  Convert a canonical syntax file specification to host syntax
 
+   function Relative_Path (Path : String; Ref : String) return String;
+   --  Given an absolute path Path calculate its relative path from a reference
+   --  directory Ref.
+
    function Relocate_Path
      (Prefix : String;
       Path   : String) return String_Ptr;
@@ -243,6 +250,9 @@ package Osint is
    --  If the above computation fails, return Path. This function assumes
    --  Prefix'First = Path'First.
 
+   function Root (Path : String) return String;
+   --  Return the root of an absolute Path.
+
    function Shared_Lib (Name : String) return String;
    --  Returns the runtime shared library in the form -l<name>-<version> where
    --  version is the GNAT runtime library option for the platform. For example