libadalang_24.0.0_a1358075/src/libadalang-project_provider.adb

--
--  Copyright (C) 2014-2022, AdaCore
--  SPDX-License-Identifier: Apache-2.0
--

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
with Ada.Strings.Unbounded.Hash;

with GNAT.OS_Lib;
with GNAT.Task_Lock;

with GNATCOLL.Strings; use GNATCOLL.Strings;
with GNATCOLL.VFS;     use GNATCOLL.VFS;
with GPR2.Project.Unit_Info;
with GPR2.Unit;

with Libadalang.GPR_Utils;      use Libadalang.GPR_Utils;
with Libadalang.Implementation; use Libadalang.Implementation;
with Libadalang.Unit_Files;

package body Libadalang.Project_Provider is

   package Filename_Sets is new Ada.Containers.Hashed_Sets
     (Element_Type        => Virtual_File,
      Hash                => Full_Name_Hash,
      Equivalent_Elements => "=");

   use type Ada.Containers.Count_Type;

   package US renames Ada.Strings.Unbounded;
   use type US.Unbounded_String;

   ------------------------
   -- GPR1 unit provider --
   ------------------------

   type Project_Data (Kind : Project_Kind := GPR1_Kind) is record
      case Kind is
         when GPR1_Kind =>
            GPR1_Tree             : Prj.Project_Tree_Access;
            GPR1_Env              : Prj.Project_Environment_Access;
            GPR1_Is_Project_Owner : Boolean;
         when GPR2_Kind =>
            GPR2_Tree : access GPR2.Project.Tree.Object;
      end case;
   end record;

   type Project_Unit_Provider is new LAL.Unit_Provider_Interface with record
      Data     : Project_Data;
      Projects : View_Vectors.Vector;
   end record;
   --  Unit provider backed up by a project file

   type Project_Unit_Provider_Access is access all Project_Unit_Provider;

   overriding function Get_Unit_Filename
     (Provider : Project_Unit_Provider;
      Name     : Text_Type;
      Kind     : Analysis_Unit_Kind) return String;

   overriding procedure Get_Unit_Location
     (Provider       : Project_Unit_Provider;
      Name           : Text_Type;
      Kind           : Analysis_Unit_Kind;
      Filename       : in out US.Unbounded_String;
      PLE_Root_Index : in out Natural);

   overriding function Get_Unit
     (Provider    : Project_Unit_Provider;
      Context     : LAL.Analysis_Context'Class;
      Name        : Text_Type;
      Kind        : Analysis_Unit_Kind;
      Charset     : String := "";
      Reparse     : Boolean := False) return LAL.Analysis_Unit'Class;

   overriding procedure Get_Unit_And_PLE_Root
     (Provider       : Project_Unit_Provider;
      Context        : LAL.Analysis_Context'Class;
      Name           : Text_Type;
      Kind           : Analysis_Unit_Kind;
      Charset        : String := "";
      Reparse        : Boolean := False;
      Unit           : in out LAL.Analysis_Unit'Class;
      PLE_Root_Index : in out Natural);

   overriding procedure Release (Provider : in out Project_Unit_Provider);

   ------------------------------------------
   -- Helpers to create project partitions --
   ------------------------------------------

   type Any_Provider_And_Projects is record
      Provider : LAL.Unit_Provider_Reference;
      Projects : View_Vectors.Vector;
   end record;
   --  Provider_And_Projects equivalent that is GPR library agnostic

   type Any_Provider_And_Projects_Array is
     array (Positive range <>) of Any_Provider_And_Projects;
   type Any_Provider_And_Projects_Array_Access is
      access all Any_Provider_And_Projects_Array;
   procedure Free is new Ada.Unchecked_Deallocation
     (Any_Provider_And_Projects_Array, Any_Provider_And_Projects_Array_Access);

   type Files_For_Unit is record
      Spec_File, Body_File : aliased US.Unbounded_String;
   end record;
   --  Identify the source files that implement one unit (spec & body for a
   --  specific unit name, when present).

   procedure Set_Unit_File
     (FFU  : in out Files_For_Unit;
      File : String;
      Part : Any_Unit_Part);
   --  Register the couple File/Part in FFU

   package Unit_Files_Maps is new Ada.Containers.Hashed_Maps
     (Key_Type        => US.Unbounded_String,
      Element_Type    => Files_For_Unit,
      Equivalent_Keys => US."=",
      Hash            => US.Hash);
   --  Associate a set of files to unit names

   procedure Set_Unit_File
     (Unit_Files : in out Unit_Files_Maps.Map;
      Unit_Name  : String;
      Unit_Part  : Any_Unit_Part;
      Filename   : String);
   --  Wrapper around Set_Unit_File to register the couple Filename/Unit_Part
   --  in the appropriate Unit_Files' entry. Create such an entry if needed.

   type Aggregate_Part is record
      Projects   : View_Vectors.Vector;
      Unit_Files : Unit_Files_Maps.Map;
   end record;
   --  Group of projects that make up one part in the aggregated projects
   --  partition.

   function Part_Image (Part : Aggregate_Part) return String;
   --  Return a human-readable string that represent the set of projects in
   --  Part.

   type Aggregate_Part_Access is access all Aggregate_Part;
   procedure Free is new Ada.Unchecked_Deallocation
     (Aggregate_Part, Aggregate_Part_Access);

   function Try_Merge
     (Part       : in out Aggregate_Part;
      Project    : Any_View;
      Unit_Files : in out Unit_Files_Maps.Map) return Boolean;
   --  If all common unit names in ``Part.Unit_Files`` and ``Unit_Files`` are
   --  associated with the same source files, update ``Part`` so that
   --  ``Project`` is part of it, clear ``Unit_Files`` and return True. Do
   --  nothing and return False otherwise.

   package Aggregate_Part_Vectors is new Ada.Containers.Vectors
     (Positive, Aggregate_Part_Access);
   procedure Free (Partition : in out Aggregate_Part_Vectors.Vector);

   function Create_Project_Unit_Provider
     (Tree  : Any_Tree;
      Views : View_Vectors.Vector) return LAL.Unit_Provider_Reference;
   --  Helper to create a ``Project_Unit_Provider`` reference based on the
   --  given ``Tree`` and ``Views``.

   function Create_Project_Unit_Providers
     (Tree : Any_Tree) return Any_Provider_And_Projects_Array_Access;
   --  Common implementation for the homonym public functions

   procedure Create_Project_Unit_Provider
     (Tree         : Any_Tree;
      View         : Any_View;
      Provider     : out Project_Unit_Provider_Access;
      Provider_Ref : out LAL.Unit_Provider_Reference);
   --  Common implementation for the homonym public functions.
   --
   --  Try to create a single unit provider for the given ``Tree``/``View``
   --  (``View`` being ``No_View`` means: use the root project). On success,
   --  set ``Provider`` and ``Provider_Ref`` to the created unit provider. On
   --  failure, raise an ``Unsupported_View_Error`` exception.

   procedure Create_Sorted_Filenames
     (File_Set    : Filename_Sets.Set;
      File_Vector : out Filename_Vectors.Vector);
   --  Sort files in ``File_Set`` and put the result in ``File_Vector``

   function Default_Charset_From_Project
     (Tree : Any_Tree; View : Any_View) return String;
   --  Common implementation for the homonym public functions

   -------------------
   -- Set_Unit_File --
   -------------------

   procedure Set_Unit_File
     (FFU  : in out Files_For_Unit;
      File : String;
      Part : Any_Unit_Part)
   is
      Unit_File : constant access US.Unbounded_String :=
        (case Part is
         when Unit_Spec => FFU.Spec_File'Access,
         when Unit_Body     => FFU.Body_File'Access);
   begin
      pragma Assert (Unit_File.all = US.Null_Unbounded_String);
      Unit_File.all :=
        (if File = ""
         then US.Null_Unbounded_String
         else US.To_Unbounded_String
                (+Create (+File).Full_Name (Normalize => True)));
   end Set_Unit_File;

   -------------------
   -- Set_Unit_File --
   -------------------

   procedure Set_Unit_File
     (Unit_Files : in out Unit_Files_Maps.Map;
      Unit_Name  : String;
      Unit_Part  : Any_Unit_Part;
      Filename   : String)
   is
      use Unit_Files_Maps;

      --  TODO??? Refactor to make a single lookup/insertion

      UN       : constant US.Unbounded_String :=
        US.To_Unbounded_String (Unit_Name);
      Pos      : Cursor := Unit_Files.Find (UN);
      Inserted : Boolean;
   begin
      if not Has_Element (Pos) then
         Unit_Files.Insert (UN, Pos, Inserted);
         pragma Assert (Inserted);
      end if;

      Set_Unit_File (Unit_Files.Reference (Pos), Filename, Unit_Part);
   end Set_Unit_File;

   ----------------
   -- Part_Image --
   ----------------

   function Part_Image (Part : Aggregate_Part) return String is
      use Ada.Strings.Unbounded;
      Image : Unbounded_String;
      First   : Boolean := True;
   begin
      Append (Image, "<");
      for View of Part.Projects loop
         if First then
            First := False;
         else
            Append (Image, ", ");
         end if;
         Append (Image, Name (View));
      end loop;
      Append (Image, ">");
      return To_String (Image);
   end Part_Image;

   ---------------
   -- Try_Merge --
   ---------------

   function Try_Merge
     (Part       : in out Aggregate_Part;
      Project    : Any_View;
      Unit_Files : in out Unit_Files_Maps.Map) return Boolean
   is
      use Unit_Files_Maps;
   begin
      --  If Part contains nothing yet, no need to do the costly overlap check:
      --  just move info there and return.

      if Part.Unit_Files.Is_Empty then
         Part.Projects.Append (Project);
         Part.Unit_Files.Move (Unit_Files);
         return True;
      end if;

      --  Otherwise, first check that Part.Unit_Files and Unit_Files don't have
      --  conflicting units.

      for Prj_Pos in Unit_Files.Iterate loop
         declare
            use Ada.Strings.Unbounded;
            Unit_Name : constant Unbounded_String := Key (Prj_Pos);
            Part_Pos  : constant Cursor := Part.Unit_Files.Find (Unit_Name);
         begin
            if Has_Element (Part_Pos)
               and then Unit_Files.Reference (Prj_Pos).Element.all
                        /= Part.Unit_Files.Reference (Part_Pos).Element.all
            then
               if Trace.Is_Active then
                  Trace.Trace
                    ("Found conflicting source files for unit "
                     & To_String (Unit_Name) & " in " & Name (Project)
                     & " and " & Part_Image (Part));
               end if;
               return False;
            end if;
         end;
      end loop;

      --  Finally merge Project and Unit_Files into Part

      Part.Projects.Append (Project);
      for Prj_Pos in Unit_Files.Iterate loop
         declare
            Dummy_Cursor   : Cursor;
            Dummy_Inserted : Boolean;
         begin
            Part.Unit_Files.Insert
              (Key (Prj_Pos), Element (Prj_Pos), Dummy_Cursor, Dummy_Inserted);
         end;
      end loop;

      return True;
   end Try_Merge;

   ----------
   -- Free --
   ----------

   procedure Free (Partition : in out Aggregate_Part_Vectors.Vector) is
   begin
      for Part of Partition loop
         Free (Part);
      end loop;
      Partition.Clear;
   end Free;

   ----------
   -- Free --
   ----------

   procedure Free (PAP_Array : in out Provider_And_Projects_Array_Access) is
      procedure Deallocate is new Ada.Unchecked_Deallocation
        (Provider_And_Projects_Array, Provider_And_Projects_Array_Access);
   begin
      for PAP of PAP_Array.all loop
         Prj.Unchecked_Free (PAP.Projects);
      end loop;
      Deallocate (PAP_Array);
   end Free;

   ----------------------------------
   -- Create_Project_Unit_Provider --
   ----------------------------------

   function Create_Project_Unit_Provider
     (Tree  : Any_Tree;
      Views : View_Vectors.Vector) return LAL.Unit_Provider_Reference
   is
      Provider : Project_Unit_Provider;
      Data     : Project_Data renames Provider.Data;
   begin
      case Tree.Kind is
         when GPR1_Kind =>
            Data :=
              (Kind                  => GPR1_Kind,
               GPR1_Tree             => Tree.GPR1_Value,
               GPR1_Env              => null,
               GPR1_Is_Project_Owner => False);

         when GPR2_Kind =>
            Data :=
              (Kind => GPR2_Kind, GPR2_Tree => Tree.GPR2_Value.Reference);
      end case;
      Provider.Projects := Views;
      return LAL.Create_Unit_Provider_Reference (Provider);
   end Create_Project_Unit_Provider;

   -----------------------------------
   -- Create_Project_Unit_Providers --
   -----------------------------------

   function Create_Project_Unit_Providers
     (Tree : Any_Tree) return Any_Provider_And_Projects_Array_Access
   is
      Partition : Aggregate_Part_Vectors.Vector;
   begin
      Trace.Increase_Indent ("Trying to partition " & Name (Root (Tree)));

      if Is_Aggregate_Project (Root (Tree)) then

         --  We have an aggregate project: partition aggregated projects so
         --  that each unit providers (associated to one exclusive set of
         --  projects) has visibility on only one version of a unit.

         declare
            Views : View_Vectors.Vector := Aggregated_Projects (Root (Tree));

            function "<" (Left, Right : Any_View) return Boolean is
              (Name (Left) < Name (Right));

            package Sorting is new View_Vectors.Generic_Sorting;
         begin
            --  Sort views by name so that our output is deterministic:
            --  Aggregated_Project does not specify the order of projects in
            --  its result.

            Sorting.Sort (Views);

            --  For each aggregated project...

            Aggregate_Iteration : for View of Views loop
               declare
                  --  List all units defined and keep track of which source
                  --  files implement them.

                  Unit_Files : Unit_Files_Maps.Map;

                  procedure Process
                    (Unit_Name : String;
                     Unit_Part : Any_Unit_Part;
                     Filename  : String);

                  -------------
                  -- Process --
                  -------------

                  procedure Process
                    (Unit_Name : String;
                     Unit_Part : Any_Unit_Part;
                     Filename  : String) is
                  begin
                     Set_Unit_File
                       (Unit_Files, Unit_Name, Unit_Part, Filename);
                  end Process;

                  New_Part_Needed : Boolean := True;
               begin
                  Iterate_Ada_Units (Tree, View, Process'Access);

                  --  Then look for a part whose units do not conflict with
                  --  Unit_Files. Create a new one if there is no such part.

                  Part_Lookup : for Part of Partition loop
                     if Try_Merge (Part.all, View, Unit_Files) then
                        New_Part_Needed := False;
                        exit Part_Lookup;
                     end if;
                  end loop Part_Lookup;

                  if New_Part_Needed then
                     declare
                        Part : constant Aggregate_Part_Access :=
                          new Aggregate_Part;
                        Success : constant Boolean :=
                          Try_Merge (Part.all, View, Unit_Files);
                     begin
                        pragma Assert (Success);
                        Partition.Append (Part);
                     end;
                  end if;
               end;
            end loop Aggregate_Iteration;
         end;

         --  If the partition is empty (there was no aggregated project),
         --  create one unit provider anyway: this provider will refer to an
         --  empty list of projects.

         if Partition.Is_Empty then
            Partition.Append (new Aggregate_Part);
         end if;

      else
         --  Project is not an aggregate project, so the partition is obvious:
         --  one part that contains the root project.

         declare
            Part : constant Aggregate_Part_Access := new Aggregate_Part;
         begin
            Part.Projects.Append (Root (Tree));
            Partition.Append (Part);
         end;
      end if;

      Trace.Decrease_Indent;

      --  For debuggability, log how the Tree was partitioned

      if Trace.Is_Active then
         Trace.Increase_Indent ("Input project partitioned into:");
         for Cur in Partition.Iterate loop
            declare
               N    : constant Positive :=
                  Aggregate_Part_Vectors.To_Index (Cur);
               Part : Aggregate_Part renames Partition.Element (N).all;
            begin
               Trace.Trace ("Part" & N'Image & ": " & Part_Image (Part));
            end;
         end loop;
         Trace.Decrease_Indent;
      end if;

      --  The partition is ready: turn each part into a unit provider and
      --  return the list.

      return Result : constant Any_Provider_And_Projects_Array_Access :=
         new Any_Provider_And_Projects_Array (1 .. Natural (Partition.Length))
      do
         for I in Result.all'Range loop
            declare
               Views : View_Vectors.Vector renames Partition (I).Projects;
            begin
               Result (I).Provider :=
                 Create_Project_Unit_Provider (Tree, Views);
               Result (I).Projects := Views;
            end;
         end loop;
         Free (Partition);
      end return;
   end Create_Project_Unit_Providers;

   ----------------------------------
   -- Create_Project_Unit_Provider --
   ----------------------------------

   procedure Create_Project_Unit_Provider
     (Tree         : Any_Tree;
      View         : Any_View;
      Provider     : out Project_Unit_Provider_Access;
      Provider_Ref : out LAL.Unit_Provider_Reference)
   is
      Actual_View : Any_View := View;
   begin
      --  If no project was given, try to run the partitionner

      if Actual_View = No_View (Tree) then
         declare
            PAPs : Any_Provider_And_Projects_Array_Access :=
              Create_Project_Unit_Providers (Tree);
         begin
            if PAPs.all'Length > 1 then
               Free (PAPs);
               raise Unsupported_View_Error with "inconsistent units found";
            end if;

            --  We only have one provider: return it

            Provider_Ref := PAPs.all (PAPs.all'First).Provider;
            Provider :=
              Project_Unit_Provider_Access (Provider_Ref.Unchecked_Get);
            Free (PAPs);
            return;
         end;
      end if;

      --  Peel the aggregate project layers (if any) around Actual_View. If we
      --  find an aggregate project with more than one aggregated project, this
      --  is an unsupported case.

      while Is_Aggregate_Project (Actual_View) loop
         declare
            Subprojects : constant View_Vectors.Vector :=
              Aggregated_Projects (Actual_View);
         begin
            exit when Subprojects.Length /= 1;
            Actual_View := Subprojects.First_Element;
         end;
      end loop;

      if Is_Aggregate_Project (Actual_View) then
         raise Unsupported_View_Error with
            "selected project is aggregate and has more than one sub-project";
      end if;

      declare
         Views : View_Vectors.Vector;
      begin
         Views.Append (Actual_View);
         Provider_Ref := Create_Project_Unit_Provider (Tree, Views);
         Provider :=
           Project_Unit_Provider_Access (Provider_Ref.Unchecked_Get);
      end;
   end Create_Project_Unit_Provider;

   -----------------------------------
   -- Create_Project_Unit_Providers --
   -----------------------------------

   function Create_Project_Unit_Providers
     (Tree : Prj.Project_Tree_Access) return Provider_And_Projects_Array_Access
   is
      Result : Any_Provider_And_Projects_Array_Access :=
        Create_Project_Unit_Providers
          ((Kind => GPR1_Kind, GPR1_Value => Tree));
   begin
      --  Convert Result (GPR library agnostic data structure) into the return
      --  type (GPR1-specific data structure).

      return R : constant Provider_And_Projects_Array_Access :=
        new Provider_And_Projects_Array (Result.all'Range)
      do
         for I in R.all'Range loop
            R (I).Provider := Result (I).Provider;
            declare
               Projects : View_Vectors.Vector renames Result (I).Projects;
               P        : Prj.Project_Array_Access renames R (I).Projects;
            begin
               P := new Prj.Project_Array (1 .. Natural (Projects.Length));
               for I in P.all'Range loop
                  P (I) := Projects (I).GPR1_Value;
               end loop;
            end;
         end loop;
         Free (Result);
      end return;
   end Create_Project_Unit_Providers;

   ----------------------------------
   -- Create_Project_Unit_Provider --
   ----------------------------------

   function Create_Project_Unit_Provider
     (Tree             : Prj.Project_Tree_Access;
      Project          : Prj.Project_Type := Prj.No_Project;
      Env              : Prj.Project_Environment_Access;
      Is_Project_Owner : Boolean := True)
      return LAL.Unit_Provider_Reference
   is
      Provider : Project_Unit_Provider_Access;
   begin
      return Result : LAL.Unit_Provider_Reference do
         Create_Project_Unit_Provider
           (Tree         => (Kind => GPR1_Kind, GPR1_Value => Tree),
            View         => (Kind => GPR1_Kind, GPR1_Value => Project),
            Provider     => Provider,
            Provider_Ref => Result);
         Provider.Data.GPR1_Env := Env;
         Provider.Data.GPR1_Is_Project_Owner := Is_Project_Owner;
      end return;
   end Create_Project_Unit_Provider;

   -----------------------
   -- Get_Unit_Filename --
   -----------------------

   overriding function Get_Unit_Filename
     (Provider : Project_Unit_Provider;
      Name     : Text_Type;
      Kind     : Analysis_Unit_Kind) return String is
   begin
      --  Get_Unit_Location is supposed to handle all cases, so this should be
      --  dead code.

      return (raise Program_Error);
   end Get_Unit_Filename;

   -----------------------
   -- Get_Unit_Location --
   -----------------------

   overriding procedure Get_Unit_Location
     (Provider       : Project_Unit_Provider;
      Name           : Text_Type;
      Kind           : Analysis_Unit_Kind;
      Filename       : in out US.Unbounded_String;
      PLE_Root_Index : in out Natural)
   is
      Str_Name  : constant String :=
        Libadalang.Unit_Files.Unit_String_Name (Name);
   begin
      case Provider.Data.Kind is
      when GPR1_Kind =>
         begin
            --  GNATCOLL.Projects does not provide the compilation unit index
            --  information: we have to assume that there are always at most
            --  one compilation unit per source file.

            PLE_Root_Index := 1;

            --  Look for a source file corresponding to Name/Kind in all
            --  projects associated to this Provider.

            GNAT.Task_Lock.Lock;

            --  Unlike what is documented, it's not because File_From_Unit
            --  returns an non-empty string that the unit does belong to the
            --  project, so we must also check Create_From_Project's result.

            for View of Provider.Projects loop
               declare
                  P    : constant Prj.Project_Type := View.GPR1_Value;
                  File : constant Filesystem_String := Prj.File_From_Unit
                    (Project   => P,
                     Unit_Name => Str_Name,
                     Part      => Convert (Kind),
                     Language  => "Ada");
               begin
                  if File'Length /= 0 then
                     declare
                        Path     : constant GNATCOLL.VFS.Virtual_File :=
                          Prj.Create_From_Project (P, File).File;
                        Fullname : constant String := +Path.Full_Name;
                     begin
                        if Fullname'Length /= 0 then
                           GNAT.Task_Lock.Unlock;
                           Filename := US.To_Unbounded_String (Fullname);
                           return;
                        end if;
                     end;
                  end if;
               end;
            end loop;

            GNAT.Task_Lock.Unlock;
         exception
            when others =>
               GNAT.Task_Lock.Unlock;
               raise;
         end;

      when GPR2_Kind =>
         declare
            procedure Set (SUI : GPR2.Unit.Source_Unit_Identifier);
            --  Set ``Filename`` and ``PLE_Root_Index`` from ``SUI``'s

            function Lookup (View : GPR2.Project.View.Object) return Boolean;
            --  If ``View`` contains the requested unit, return ``True`` and
            --  set ``Filename`` to the corresponding filename. Return
            --  ``False`` otherwise.

            Unit_Name : constant GPR2.Name_Type := GPR2.Name_Type (Str_Name);

            ---------
            -- Set --
            ---------

            procedure Set (SUI : GPR2.Unit.Source_Unit_Identifier) is
               use type GPR2.Unit_Index;
            begin
               --  GPR2 sets the CU index to 0 when there is no "at N" clause
               --  in the project file. This is equivalont to "at 1", which is
               --  what we need here since PLE_Root_Index is a Positive.

               Filename := US.To_Unbounded_String (SUI.Source.Value);
               PLE_Root_Index :=
                 (if SUI.Index = 0 then 1 else Positive (SUI.Index));
            end Set;

            ------------
            -- Lookup --
            ------------

            function Lookup (View : GPR2.Project.View.Object) return Boolean is
               Unit : constant GPR2.Project.Unit_Info.Object :=
                 View.Unit (Unit_Name);
            begin
               if Unit.Is_Defined then
                  case Kind is
                     when Unit_Specification =>
                        if Unit.Has_Spec then
                           Set (Unit.Spec);
                           return True;
                        end if;
                     when Unit_Body =>
                        if Unit.Has_Body then
                           Set (Unit.Main_Body);
                           return True;
                        end if;
                  end case;
               end if;

               return False;
            end Lookup;

            Tree : GPR2.Project.Tree.Object renames
              Provider.Data.GPR2_Tree.all;
         begin
            --  Look for all the requested unit in the closure of all the
            --  projects that this provider handles.

            for View of Provider.Projects loop
               for V of Closure (View.GPR2_Value) loop
                  if Lookup (V) then
                     return;
                  end if;
               end loop;
            end loop;

            --  Also look in the runtime project, if any

            if Tree.Has_Runtime_Project and then Lookup (Tree.Runtime_Project)
            then
               return;
            end if;
         end;
      end case;

      --  If we reach this point, we have not found a unit handled by this
      --  provider that matches the requested name/kind.

      Filename := US.Null_Unbounded_String;
      PLE_Root_Index := 1;
   end Get_Unit_Location;

   --------------
   -- Get_Unit --
   --------------

   overriding function Get_Unit
     (Provider : Project_Unit_Provider;
      Context  : LAL.Analysis_Context'Class;
      Name     : Text_Type;
      Kind     : Analysis_Unit_Kind;
      Charset  : String := "";
      Reparse  : Boolean := False) return LAL.Analysis_Unit'Class
   is
      --  Get_Unit_And_PLE_Root is supposed to handle all cases, so this should
      --  be dead code.

      pragma Unreferenced (Provider, Context, Name, Kind, Charset, Reparse);
   begin
      return (raise Program_Error);
   end Get_Unit;

   ---------------------------
   -- Get_Unit_And_PLE_Root --
   ---------------------------

   overriding procedure Get_Unit_And_PLE_Root
     (Provider       : Project_Unit_Provider;
      Context        : LAL.Analysis_Context'Class;
      Name           : Text_Type;
      Kind           : Analysis_Unit_Kind;
      Charset        : String := "";
      Reparse        : Boolean := False;
      Unit           : in out LAL.Analysis_Unit'Class;
      PLE_Root_Index : in out Natural)
   is
      Filename : US.Unbounded_String;
   begin
      Provider.Get_Unit_Location (Name, Kind, Filename, PLE_Root_Index);
      pragma Assert (PLE_Root_Index > 0);

      if US.Length (Filename) > 0 then
         Unit := LAL.Analysis_Unit'Class
           (Context.Get_From_File (US.To_String (Filename), Charset, Reparse));
      else
         declare
            Dummy_File : constant String :=
               Libadalang.Unit_Files.File_From_Unit (Name, Kind);
            Kind_Name  : constant Text_Type :=
              (case Kind is
               when Unit_Specification => "specification file",
               when Unit_Body          => "body file");
            Error      : constant Text_Type :=
               "Could not find source file for " & Name & " (" & Kind_Name
               & ")";
         begin
            Unit := LAL.Analysis_Unit'Class
              (Context.Get_With_Error (Dummy_File, Error, Charset));
         end;
      end if;
   end Get_Unit_And_PLE_Root;

   -------------
   -- Release --
   -------------

   overriding procedure Release (Provider : in out Project_Unit_Provider) is
   begin
      case Provider.Data.Kind is
         when GPR1_Kind =>
            declare
               Data : Project_Data renames Provider.Data;
            begin
               GNAT.Task_Lock.Lock;

               if Data.GPR1_Is_Project_Owner then
                  Prj.Unload (Data.GPR1_Tree.all);
                  Prj.Free (Data.GPR1_Tree);
                  Prj.Free (Data.GPR1_Env);
               end if;
               Data.GPR1_Tree := null;
               Data.GPR1_Env := null;
               Data.GPR1_Is_Project_Owner := False;

               GNAT.Task_Lock.Unlock;

            exception
               when others =>
                  GNAT.Task_Lock.Unlock;
                  raise;
            end;

         when GPR2_Kind =>
            null;
      end case;
   end Release;

   -----------------------------
   -- Create_Sorted_Filenames --
   -----------------------------

   procedure Create_Sorted_Filenames
     (File_Set    : Filename_Sets.Set;
      File_Vector : out Filename_Vectors.Vector)
   is
      package Sorting is new Filename_Vectors.Generic_Sorting
        ("<" => US."<");
   begin
      for F of File_Set loop

         --  Normalize the files to return to avoid discrepancies during
         --  testing if GPR1 does normalization and GPR2 does not or
         --  conversely.

         declare
            Original : constant String := +F.Full_Name;
            Normalized : constant String :=
              GNAT.OS_Lib.Normalize_Pathname (Original);
         begin
            File_Vector.Append (US.To_Unbounded_String (Normalized));
         end;
      end loop;
      Sorting.Sort (File_Vector);
   end Create_Sorted_Filenames;

   ------------------
   -- Source_Files --
   ------------------

   function Source_Files
     (Tree     : Prj.Project_Tree'Class;
      Mode     : Source_Files_Mode := Default;
      Projects : Prj.Project_Array := Prj.Empty_Project_Array)
      return Filename_Vectors.Vector
   is
      use GNATCOLL.Projects;

      Result : Filename_Sets.Set;

      procedure Include (P : Prj.Project_Type);
      --  Include sources that belong to ``P`` (according to ``Mode``) to
      --  ``Result``.

      procedure Append (F : Virtual_File);
      --  If ``F`` is an Ada source in the project tree, append it to
      --  ``Result``. This is considered the case if at least one project
      --  in the project tree considers this file as an Ada source.

      -------------
      -- Include --
      -------------

      procedure Include (P : Prj.Project_Type) is
         Recursive                : Boolean;
         Include_Externally_Built : Boolean;
         List                     : File_Array_Access;
      begin
         case Mode is
            when Default =>

               --  Go through all projects except externally built ones

               Recursive := True;
               Include_Externally_Built := False;

            when Root_Project =>

               --  Go through ``P`` only, regardless of whether it is
               --  externally built.

               Recursive := False;
               Include_Externally_Built := True;

            when Whole_Project | Whole_Project_With_Runtime =>

               --  Go through the whole project sub tree

               Recursive := True;
               Include_Externally_Built := True;
         end case;
         List := P.Source_Files
           (Recursive                => Recursive,
            Include_Externally_Built => Include_Externally_Built);
         for F of List.all loop
            Append (F);
         end loop;
         Unchecked_Free (List);
      end Include;

      ------------
      -- Append --
      ------------

      procedure Append (F : Virtual_File) is
         FIS : constant File_Info_Set := Tree.Info_Set (F);
         --  Compute the set of ``File_Info`` for this file (one for each
         --  specific project of the project tree that includes this source).
         --  We use ``Tree.Info_Set`` instead of ``Tree.Info`` in order to
         --  support the case of aggregate projects. In such case, the set
         --  might contain multiple elements (one for each aggregated project
         --  that includes this source file): we choose to consider this file
         --  an Ada source if any of those projects considers it an Ada source.
         --
         --  TODO??? We could be more precise by checking that the actual
         --  project found in the ``File_Info`` is the one we are currently
         --  traversing, but it might actually not be if this source was found
         --  as part of a recursive lookup. Besides, it sounds unrealistic for
         --  a given source file to be considered an Ada source file in one
         --  subproject but, say, a C source file in another. This
         --  approximation should be good enough in practice, and will be
         --  deprecated anyway once the transition to GPR2 is complete.
      begin
         for FI of FIS loop
            if File_Info (FI).Language = "ada" then
               Result.Include (F);
               return;
            end if;
         end loop;
      end Append;

   begin
      --  Include sources from all the requested projects themselves

      if Projects'Length = 0 then
         Include (Tree.Root_Project);
      else
         for P of Projects loop
            Include (P);
         end loop;
      end if;

      --  Only then, if requested, get runtime sources: they are common to all
      --  subprojects.

      if Mode = Whole_Project_With_Runtime then
         declare
            Env : constant Project_Environment_Access :=
              Get_Environment (Tree.Root_Project);
         begin
            for F of Predefined_Source_Files (Env) loop
               Append (F);
            end loop;
         end;
      end if;

      --  Return the sorted list of source files. Sorting gets the output
      --  deterministic and thus helps reproducibility.

      return V : Filename_Vectors.Vector do
         Create_Sorted_Filenames (Result, V);
      end return;
   end Source_Files;

   ------------------
   -- Source_Files --
   ------------------

   function Source_Files
     (Tree     : GPR2.Project.Tree.Object;
      Mode     : Source_Files_Mode := Default;
      Projects : GPR2.Project.View.Set.Object := GPR2.Project.View.Set.Empty)
      return Filename_Vectors.Vector
   is
      --  Note that the GNATCOLL.Projects and GPR2 APIs to query source files
      --  are just too different, so creating a common API on top of them is
      --  not worth it. For this reason, this GPR2 implementation of
      --  Source_Files is completely independent.

      Result : Filename_Sets.Set;

      procedure Process (View : GPR2.Project.View.Object);
      --  Include sources that belong to ``P`` (according to ``Mode``) to
      --  ``Result``.

      procedure Include (View : GPR2.Project.View.Object);
      --  Include in ``Result`` all sources that directly belong to ``P``

      -------------
      -- Process --
      -------------

      procedure Process (View : GPR2.Project.View.Object) is
      begin
         case Mode is
            when Default =>

               --  Go through all projects except externally built ones

               for V of Closure (View) loop
                  if not V.Is_Externally_Built then
                     Include (V);
                  end if;
               end loop;

            when Root_Project =>

               --  Go through ``P`` only, regardless of whether it is
               --  externally built.

               Include (View);

            when Whole_Project | Whole_Project_With_Runtime =>

               --  Go through the whole project sub tree

               for V of Closure (View) loop
                  Include (V);
               end loop;
         end case;
      end Process;

      -------------
      -- Include --
      -------------

      procedure Include (View : GPR2.Project.View.Object) is
         use type GPR2.Language_Id;
      begin
         for S of View.Sources loop
            if S.Language = GPR2.Ada_Language then
               Result.Include (Create (+String (S.Path_Name.Value)));
            end if;
         end loop;
      end Include;

   begin
      --  Include sources from all the requested projects themselves

      if Projects.Is_Empty then
         Process (Tree.Root_Project);
      else
         for P of Projects loop
            Process (P);
         end loop;
      end if;

      --  Only then, if requested, get runtime sources: they are common to all
      --  subprojects.

      if Mode = Whole_Project_With_Runtime and then Tree.Has_Runtime_Project
      then
         Include (Tree.Runtime_Project);
      end if;

      --  Return the sorted list of source files. Sorting gets the output
      --  deterministic and thus helps reproducibility.

      return V : Filename_Vectors.Vector do
         Create_Sorted_Filenames (Result, V);
      end return;
   end Source_Files;

   -----------------------------------
   -- Create_Project_Unit_Providers --
   -----------------------------------

   function Create_Project_Unit_Providers
     (Tree : GPR2.Project.Tree.Object)
      return GPR2_Provider_And_Projects_Array_Access
   is
      Result : Any_Provider_And_Projects_Array_Access :=
        Create_Project_Unit_Providers
          ((Kind => GPR2_Kind, GPR2_Value => Tree.Reference));
   begin
      --  Convert Result (GPR library agnostic data structure) into the return
      --  type (GPR2-specific data structure).

      return R : constant GPR2_Provider_And_Projects_Array_Access :=
        new GPR2_Provider_And_Projects_Array (Result.all'Range)
      do
         for I in R.all'Range loop
            R (I).Provider := Result (I).Provider;
            declare
               Projects : View_Vectors.Vector renames Result (I).Projects;
               P        : GPR2.Project.View.Vector.Object renames
                 R (I).Projects;
            begin
               for V of Projects loop
                  P.Append (V.GPR2_Value);
               end loop;
            end;
         end loop;
         Free (Result);
      end return;
   end Create_Project_Unit_Providers;

   ----------------------------------
   -- Create_Project_Unit_Provider --
   ----------------------------------

   function Create_Project_Unit_Provider
     (Tree             : GPR2.Project.Tree.Object;
      Project          : GPR2.Project.View.Object :=
                           GPR2.Project.View.Undefined)
      return LAL.Unit_Provider_Reference
   is
      Dummy : Project_Unit_Provider_Access;
   begin
      return Result : LAL.Unit_Provider_Reference do
         Create_Project_Unit_Provider
           (Tree         => (Kind => GPR2_Kind, GPR2_Value => Tree.Reference),
            View         => (Kind => GPR2_Kind, GPR2_Value => Project),
            Provider     => Dummy,
            Provider_Ref => Result);
      end return;
   end Create_Project_Unit_Provider;

   ----------------------------------
   -- Default_Charset_From_Project --
   ----------------------------------

   function Default_Charset_From_Project
     (Tree : Any_Tree; View : Any_View) return String
   is
      UTF8 : Boolean := False;

      procedure Process_Switch (View : Any_View; Switch : XString);
      --  If ``Switch`` is ``-gnatW8``, set ``UTF8`` to True

      --------------------
      -- Process_Switch --
      --------------------

      procedure Process_Switch (View : Any_View; Switch : XString) is
         pragma Unreferenced (View);
      begin
         if Switch = "-gnatW8" then
            UTF8 := True;
         end if;
      end Process_Switch;

   begin
      Iterate_Ada_Compiler_Switches (Tree, View, Process_Switch'Access);
      return (if UTF8 then "utf-8" else Default_Charset);
   end Default_Charset_From_Project;

   ----------------------------------
   -- Default_Charset_From_Project --
   ----------------------------------

   function Default_Charset_From_Project
     (Tree    : Prj.Project_Tree'Class;
      Project : Prj.Project_Type := Prj.No_Project) return String is
   begin
      return Default_Charset_From_Project
        (Tree => (Kind => GPR1_Kind, GPR1_Value => Tree'Unrestricted_Access),
         View => (Kind => GPR1_Kind, GPR1_Value => Project));
   end Default_Charset_From_Project;

   ----------------------------------
   -- Default_Charset_From_Project --
   ----------------------------------

   function Default_Charset_From_Project
     (Tree    : GPR2.Project.Tree.Object;
      Project : GPR2.Project.View.Object := GPR2.Project.View.Undefined)
      return String is
   begin
      return Default_Charset_From_Project
        (Tree => (Kind => GPR2_Kind, GPR2_Value => Tree'Unrestricted_Access),
         View => (Kind => GPR2_Kind, GPR2_Value => Project));
   end Default_Charset_From_Project;

end Libadalang.Project_Provider;