Merge branch 'topic/gnatcheck/codepeer_fallback' into 'master'

Fix the codepeer target handling

See merge request eng/libadalang/langkit-query-language!523

Author: HugoGGuerrier

lkql_checker/src/gnatcheck-compiler.adb

@@ -4,6 +4,8 @@
 --
 
 with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Characters.Latin_1;
+with Ada.Containers;
 with Ada.Directories;         use Ada.Directories;
 with Ada.Strings;             use Ada.Strings;
 with Ada.Strings.Fixed;       use Ada.Strings.Fixed;
@@ -80,6 +82,88 @@ package body Gnatcheck.Compiler is
    --  This function treats the provided path as case-insensitive on Windows
    --  systems.
 
+   ---------------------------------
+   -- Target information fetching --
+   ---------------------------------
+
+   function Get_Available_Targets return String_Sets.Set;
+   --  Call the ``gprconfig`` tool to list all currently available targets. If
+   --  you want the list of available targets when GNATcheck has been started,
+   --  use the ``Available_Targets`` global to avoid useless calls.
+
+   function Get_Available_Targets return String_Sets.Set is
+      Res                 : String_Sets.Set;
+      GPRConfig_Exec      : String_Access := Locate_Exec_On_Path ("gprconfig");
+      Args                : Argument_List (1 .. 2);
+      Return_Code         : Integer := -1;
+      Output_File         : File_Descriptor;
+      Output_File_Name    : String_Access;
+      Output_File_Content : String_Access;
+      Split_Content       : String_Vector;
+   begin
+      --  If no regular "gprconfig" has been found, look for the gnatsas one
+      if GPRConfig_Exec = null then
+         GPRConfig_Exec := Locate_Exec_On_Path ("gnatsas-gprconfig");
+
+         --  If the gnatsas "gprconfig" is not available, look for the codepeer
+         --  one (for retro-compatibility purposes).
+         if GPRConfig_Exec = null then
+            GPRConfig_Exec := Locate_Exec_On_Path ("codepeer-gprconfig");
+
+            --  If the result is still null, raise a fatal error. We cannot
+            --  continue the analysis execution.
+            if GPRConfig_Exec = null then
+               Error ("cannot locate gprconfig executable");
+               raise Fatal_Error;
+            end if;
+         end if;
+      end if;
+
+      --  Create the temporary file to get the "gprbuild" output
+      Create_Temp_Output_File (Output_File, Output_File_Name);
+
+      --  Prepare the argument list
+      Args (1) := new String'("--show-targets");
+      Args (2) := new String'("--config=Ada");
+
+      --  Spawn "gprconfig" to fetch the list of available targets
+      Spawn
+        (Program_Name           => GPRConfig_Exec.all,
+         Args                   => Args,
+         Output_File_Descriptor => Output_File,
+         Return_Code            => Return_Code,
+         Err_To_Out             => False);
+
+      --  Parse the output to fill the result
+      Output_File_Content := Read_File (Output_File_Name.all);
+      Split_Content :=
+        Split
+          (Output_File_Content.all,
+           Ada.Characters.Latin_1.LF,
+           Trim_Elems => True);
+      for I in Split_Content.First_Index + 1 .. Split_Content.Last_Index loop
+         if Split_Content (I) /= "" then
+            Res.Include (Split_Content (I));
+         end if;
+      end loop;
+
+      --  Release allocated resources and delete the temporary file
+      Close (Output_File);
+      Delete_File (Output_File_Name.all);
+      Free (GPRConfig_Exec);
+      Free (Output_File_Name);
+      Free (Output_File_Content);
+      for I in Args'Range loop
+         Free (Args (I));
+      end loop;
+
+      --  Finally return the set of available targets
+      return Res;
+   end Get_Available_Targets;
+
+   Available_Targets : constant String_Sets.Set := Get_Available_Targets;
+   --  Cache containing all available targets when GNATcheck has been started.
+
    ---------------------------------------------------------
    -- Data structures and routines for restriction checks --
    ---------------------------------------------------------
@@ -1552,35 +1636,22 @@ package body Gnatcheck.Compiler is
    --------------------------------
 
    function Should_Use_Codepeer_Target return Boolean is
-      Regular_Gnatls : String_Access := Locate_Exec_On_Path ("gnatls");
+      use Ada.Containers;
    begin
-      --  If we could find a regular gnatls, it means there is a native
-      --  toolchain, that takes precedence over a potential codepeer toolchain.
-      if Regular_Gnatls /= null then
-         Free (Regular_Gnatls);
-         return False;
-      end if;
-
-      --  If we couldn't, look for a codepeer toolchain.
-      declare
-         Gnatls : String_Access := Locate_Exec_On_Path ("codepeer-gnatls");
-      begin
-         if Gnatls /= null then
-            Free (Gnatls);
-            return True;
-         end if;
-      end;
-
-      return False;
+      return
+        Available_Targets.Length = 1
+        and then (Available_Targets.Contains ("gnatsas")
+                  or else Available_Targets.Contains ("codepeer"));
    end Should_Use_Codepeer_Target;
 
    -------------------
    -- GPRbuild_Exec --
    -------------------
 
    function GPRbuild_Exec return String is
+      use Ada.Strings.Unbounded;
    begin
-      if Should_Use_Codepeer_Target then
+      if Target = "gnatsas" or else Target = "codepeer" then
          return "codepeer-gprbuild";
       else
          return "gprbuild";
@@ -1686,9 +1757,6 @@ package body Gnatcheck.Compiler is
          if Target /= Null_Unbounded_String then
             Num_Args := @ + 1;
             Args (Num_Args) := new String'("--target=" & To_String (Target));
-         elsif Should_Use_Codepeer_Target then
-            Num_Args := @ + 1;
-            Args (Num_Args) := new String'("--target=codepeer");
          end if;
       else
          --  Target and runtime will be taken from config project anyway
@@ -1711,8 +1779,7 @@ package body Gnatcheck.Compiler is
 
       for Dir of Arg.Rules_Dirs.Get loop
          Num_Args := @ + 1;
-         Args (Num_Args) :=
-           new String'("--rules-dir=" & Ada.Strings.Unbounded.To_String (Dir));
+         Args (Num_Args) := new String'("--rules-dir=" & To_String (Dir));
       end loop;
 
       Num_Args := @ + 1;
@@ -1816,6 +1883,7 @@ package body Gnatcheck.Compiler is
       Args        : Argument_List (1 .. 128 + Integer (Last_Source));
       Num_Args    : Integer := 0;
 
+      use Ada.Strings.Unbounded;
    begin
       if GPRbuild = null then
          Error ("cannot locate gprbuild executable");
@@ -1833,9 +1901,9 @@ package body Gnatcheck.Compiler is
       Args (8) := new String'("--restricted-to-languages=ada");
       Num_Args := 8;
 
-      if Should_Use_Codepeer_Target then
+      if Target /= Null_Unbounded_String then
          Num_Args := @ + 1;
-         Args (Num_Args) := new String'("--target=codepeer");
+         Args (Num_Args) := new String'("--target=" & To_String (Target));
       end if;
 
       if Arg.Jobs.Get > 1 then

lkql_checker/src/gnatcheck-compiler.ads

@@ -19,9 +19,9 @@ package Gnatcheck.Compiler is
    ---------------------
 
    function Should_Use_Codepeer_Target return Boolean;
-   --  Returns whether the current gnatcheck process should use the codepeer
-   --  tools. This function tests if the `codepeer-gnatls` executable can be
-   --  accessed when no other regular toolchain can be found.
+   --  Returns whether the current gnatcheck process should set the "codepeer"
+   --  target as the default one. This function returns ``True`` if the
+   --  "codepeer" target is the only available one.
 
    function GPRbuild_Exec return String;
    --  Return the executable name to use in order to spawn a GPRBuild process

lkql_checker/src/gnatcheck-projects.adb

@@ -557,6 +557,10 @@ package body Gnatcheck.Projects is
          Project_Options.Add_Switch (GPR2.Options.Resolve_Links);
       end if;
 
+      if Should_Use_Codepeer_Target then
+         GPR2.KB.Set_Default_Target ("codepeer");
+      end if;
+
       if not My_Project.Tree.Load
                (Project_Options,
                 Reporter         => Gpr2_Reporter,
@@ -778,17 +782,6 @@ package body Gnatcheck.Projects is
       GPR2.Project.Registry.Pack.Check_Attributes (+"Check");
    end Register_Tool_Attributes;
 
-   ------------------------
-   -- Set_Default_Target --
-   ------------------------
-
-   procedure Set_Default_Target is
-   begin
-      if not Gnatkp_Mode and then Should_Use_Codepeer_Target then
-         GPR2.KB.Set_Default_Target ("codepeer");
-      end if;
-   end Set_Default_Target;
-
    -------------------------
    -- Set_External_Values --
    -------------------------

lkql_checker/src/gnatcheck-projects.ads

@@ -327,10 +327,6 @@ package Gnatcheck.Projects is
    -- General project file processing --
    -------------------------------------
 
-   procedure Set_Default_Target;
-   --  If codepeer is on PATH, replaces default target with "codepeer",
-   --  does nothing in gnatkp mode.
-
    procedure Initialize_Environment;
    --  Initializes the environment for extracting the information from the
    --  project file. This includes setting the parameters specific for the

lkql_checker/src/gnatcheck_main.adb

@@ -462,8 +462,6 @@ begin
       end if;
    end if;
 
-   Gnatcheck.Projects.Set_Default_Target;
-
    --  If we have the project file specified as a tool parameter, analyze it.
 
    Gnatcheck.Projects.Process_Project_File (Gnatcheck_Prj);