https://gcc.gnu.org/g:0827f611f87041f1b0fadba68c0f08506d44ce3e
commit r16-1131-g0827f611f87041f1b0fadba68c0f08506d44ce3e
Author: Viljar Indus <in...@adacore.com>
Date: Mon Dec 2 12:18:06 2024 +0200
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:
---
gcc/ada/clean.adb | 7 +-
gcc/ada/diagnostics-json_utils.adb | 139 ++++++++++++++++++
gcc/ada/diagnostics-json_utils.ads | 5 +
gcc/ada/diagnostics-sarif_emitter.adb | 263 ++++++++++++++++++++++++----------
gcc/ada/gnatls.adb | 4 +-
gcc/ada/osint.adb | 118 +++++++++++++--
gcc/ada/osint.ads | 10 ++
7 files changed, 460 insertions(+), 86 deletions(-)
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index f28cf691cf9d..dcbeffe1b8e9 100644
--- 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 072cab4a4928..8ce04c4631f6 100644
--- 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 526e09e49cd6..75adc08b40b9 100644
--- 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 31b3154d5a34..bae2dc0a88e6 100644
--- 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 4e549a98c297..6fa2327e7244 100644
--- 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 bf2affed70f7..46334aa97af1 100644
--- 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 041af4101dd8..5dbbfd8fd7ff 100644
--- 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
