libadalang_22.0.0_5f365aa4/src/libadalang-helpers.adb

------------------------------------------------------------------------------
--                                                                          --
--                                Libadalang                                --
--                                                                          --
--                     Copyright (C) 2014-2021, AdaCore                     --
--                                                                          --
-- Libadalang is free software;  you can redistribute it and/or modify  it  --
-- under terms of the GNU General Public License  as published by the Free  --
-- Software Foundation;  either version 3,  or (at your option)  any later  --
-- version.   This  software  is distributed in the hope that it  will  be  --
-- useful but  WITHOUT ANY WARRANTY;  without even the implied warranty of  --
-- MERCHANTABILITY  or  FITNESS  FOR  A PARTICULAR PURPOSE.                 --
--                                                                          --
-- As a special  exception  under  Section 7  of  GPL  version 3,  you are  --
-- granted additional  permissions described in the  GCC  Runtime  Library  --
-- Exception, version 3.1, as published by the Free Software Foundation.    --
--                                                                          --
-- You should have received a copy of the GNU General Public License and a  --
-- copy of the GCC Runtime Library Exception along with this program;  see  --
-- the files COPYING3 and COPYING.RUNTIME respectively.  If not, see        --
-- <http://www.gnu.org/licenses/>.                                          --
------------------------------------------------------------------------------

with Ada.Command_Line;
with Ada.Containers.Synchronized_Queue_Interfaces;
with Ada.Containers.Unbounded_Synchronized_Queues;
with Ada.Containers.Hashed_Sets;
with Ada.Directories;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with System.Multiprocessors;

with GNAT.OS_Lib;
with GNAT.Traceback.Symbolic;

with GNATCOLL.VFS;       use GNATCOLL.VFS;

with Libadalang.Auto_Provider;    use Libadalang.Auto_Provider;
with Libadalang.Project_Provider; use Libadalang.Project_Provider;

with Langkit_Support.Text; use Langkit_Support.Text;

package body Libadalang.Helpers is

   Abort_App_Exception : exception;
   --  Exception used to abort the execution of an App in a user callback. See
   --  the Abort_App procedure.

   function "+" (S : String) return Unbounded_String
                 renames To_Unbounded_String;
   function "+" (S : Unbounded_String) return String renames To_String;

   procedure Print_Error (Message : String);
   --  Helper to print Message on the standard error

   package String_QI is new Ada.Containers.Synchronized_Queue_Interfaces
     (Unbounded_String);
   package String_Queues is new Ada.Containers.Unbounded_Synchronized_Queues
     (String_QI);

   -----------------
   -- Print_Error --
   -----------------

   procedure Print_Error (Message : String) is
   begin
      --  If Message's last character is a newline, leave it out and let
      --  Put_Line append it. This avoids the additional line break that
      --  Text_IO would append later otherwise.

      if Message = "" then
         return;
      elsif Message (Message'Last) = ASCII.LF then
         Put_Line
           (Standard_Error, Message (Message'First .. Message'Last - 1));
      else
         Put_Line (Standard_Error, Message);
      end if;
   end Print_Error;

   ---------------
   -- Abort_App --
   ---------------

   procedure Abort_App (Message : String := "") is
   begin
      if Message /= "" then
         Put_Line (Standard_Error, Message);
      end if;
      raise Abort_App_Exception;
   end Abort_App;

   package body App is

      --  The following protected object is used for a job to signal to the
      --  other jobs that it has aborted. In this case, the other jobs must
      --  finish processing their current analysis unit and stop there.

      protected Abortion is
         procedure Signal_Abortion;
         function Abort_Signaled return Boolean;
      private
         Abort_Signaled_State : Boolean := False;
      end Abortion;

      procedure List_Predefined_Sources
        (Project : Project_Tree'Class;
         Env     : Project_Environment_Access;
         Files   : in out String_Vectors.Vector);
      --  Append to Files the list of predefined sources (typically,
      --  runtime files).

      function Files_From_Args
        (Files : out String_Vectors.Vector) return Boolean;
      --  If source files are passed on the command line, append them to Files
      --  and return True. Do nothing and return False otherwise.

      protected body Abortion is
         procedure Signal_Abortion is
         begin
            Abort_Signaled_State := True;
         end Signal_Abortion;

         function Abort_Signaled return Boolean is
         begin
            return Abort_Signaled_State;
         end Abort_Signaled;
      end Abortion;

      --------------------
      -- Dump_Exception --
      --------------------

      procedure Dump_Exception (E : Ada.Exceptions.Exception_Occurrence) is
      begin
         if Args.No_Traceback.Get then
            --  Do not use Exception_Information nor Exception_Message. The
            --  former includes tracebacks and the latter includes line
            --  numbers in Libadalang: both are bad for testcase output
            --  consistency.
            Put_Line ("> " & Ada.Exceptions.Exception_Name (E));
            New_Line;

         elsif Args.Sym_Traceback.Get then
            Put_Line (Ada.Exceptions.Exception_Message (E));
            Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));

         else
            Put_Line ("> " & Ada.Exceptions.Exception_Information (E));
            New_Line;
         end if;
      end Dump_Exception;

      -----------------------------
      -- List_Predefined_Sources --
      -----------------------------

      procedure List_Predefined_Sources
        (Project : Project_Tree'Class;
         Env     : Project_Environment_Access;
         Files   : in out String_Vectors.Vector)
      is
         List : File_Array := Predefined_Source_Files (Env);
      begin
         --  Sort for determinism
         Sort (List);

         for F of List loop
            declare
               FI        : constant File_Info := Project.Info (F);
               Full_Name : Filesystem_String renames F.Full_Name.all;
               Name      : constant String := +Full_Name;
            begin
               if FI.Language = "ada" then
                  Files.Append (+Name);
               end if;
            end;
         end loop;
      end List_Predefined_Sources;

      ---------------------
      -- Files_From_Args --
      ---------------------

      function Files_From_Args
        (Files : out String_Vectors.Vector) return Boolean
      is
         Arg_Files : constant Args.Files.Result_Array := Args.Files.Get;
      begin
         if Arg_Files'Length = 0 then
            return False;
         else
            for F of Arg_Files loop
               Files.Append (F);
            end loop;
            return True;
         end if;
      end Files_From_Args;

      ---------
      -- Run --
      ---------

      procedure Run is

         procedure Finalize;
         --  Clean up local resources. This must be called both on normal
         --  termination and during abortion.

         Project : Project_Tree_Access;
         Env     : Project_Environment_Access;
         --  Reference to the loaded project tree, if any. Null otherwise.

         UFP : Unit_Provider_Reference;
         --  When project file handling is enabled, corresponding unit provider

         EH : Event_Handler_Reference;
         --  Event handler for command line app.

         type App_Job_Context_Array_Access is access App_Job_Context_Array;
         procedure Free is new Ada.Unchecked_Deallocation
           (App_Job_Context_Array, App_Job_Context_Array_Access);

         App_Ctx      : aliased App_Context;
         Job_Contexts : App_Job_Context_Array_Access;

         Files : String_Vectors.Vector;
         Queue : String_Queues.Queue;

         task type Main_Task_Type
            --  Increase task's Storage_Size to match the primary stack size.
            --  This helps avoiding stack overflows in PLE for client programs
            --  (such as nameres).
            with Storage_Size => 8 * 1024 * 1024
         is
            entry Start (ID : Job_ID);
            entry Stop;
         end Main_Task_Type;

         --------------
         -- Finalize --
         --------------

         procedure Finalize is
         begin
            UFP := No_Unit_Provider_Reference;
            EH := No_Event_Handler_Ref;
            if Project /= null then
               Project.Unload;
               Free (Project);
               Free (Env);
            end if;

            Free (Job_Contexts);
         end Finalize;

         --------------------
         -- Main_Task_Type --
         --------------------

         task body Main_Task_Type is
            F   : Unbounded_String;
            JID : Job_ID;
         begin
            --  Wait for the signal to start jobs

            accept Start (ID : Job_ID) do
               JID := ID;
            end Start;

            --  We can now do our processings and invoke user callbacks when
            --  appropriate.

            declare
               Job_Name : constant String := "Job" & JID'Image;
               Job_Ctx  : App_Job_Context renames Job_Contexts (JID);

               type Any_Step is (Setup, In_Unit, Post_Process);
               Step : Any_Step := Setup;
            begin
               Trace.Increase_Indent ("Setting up " & Job_Name);
               Job_Setup (Job_Ctx);
               Trace.Decrease_Indent;

               Step := In_Unit;
               loop
                  --  Stop as soon as we noticed that another job requested
                  --  abortion.

                  if Abortion.Abort_Signaled then
                     Trace.Trace
                       (Job_Name & " leaving after another job aborted");
                     Job_Ctx.Aborted := True;
                     exit;
                  end if;

                  --  Pick the next file and process it

                  select
                     Queue.Dequeue (F);
                  or
                     delay 0.1;
                     exit;
                  end select;

                  Trace.Increase_Indent (Job_Name & ": Processing " & (+F));
                  declare
                     Unit : constant Analysis_Unit :=
                       Job_Ctx.Analysis_Ctx.Get_From_File (+F);
                  begin
                     Process_Unit (Job_Ctx, Unit);
                     Job_Ctx.Units_Processed.Append (Unit);
                  end;
                  Trace.Decrease_Indent;

               end loop;

               Trace.Increase_Indent (Job_Name & ": Post-processing");
               Step := Post_Process;
               Job_Post_Process (Job_Ctx);
               Trace.Decrease_Indent;

            --  Make sure to handle properly uncaught errors (they have nowhere
            --  to propagate once here) and abortion requests.

            exception
               when Abort_App_Exception =>
                  Trace.Trace (Job_Name & " aborted the app");
                  Job_Ctx.Aborted := True;
                  Abortion.Signal_Abortion;

               when E : others =>
                  Job_Ctx.Aborted := True;
                  Abortion.Signal_Abortion;
                  declare
                     Context : constant String :=
                       (case Step is
                        when Setup        => "in Job_Setup",
                        when In_Unit      => "in Process_Unit for " & (+F),
                        when Post_Process => "in Job_Post_Process");
                  begin
                     Put_Line
                       (Standard_Error,
                        "Unhandled error " & Context
                        & " (job" & JID'Image & ")");
                     Dump_Exception (E);
                  end;
            end;

            accept Stop do
               null;
            end Stop;
         end Main_Task_Type;

      begin
         --  Setup traces from config file
         GNATCOLL.Traces.Parse_Config_File;

         if not Args.Parser.Parse then
            return;
         end if;

         --  Use the default command line event handler. Forward the value of
         --  the Exit_On_Missing_File command line option.

         EH := Command_Line_Event_Handler (Args.Exit_On_Missing_File.Get);

         Trace.Increase_Indent ("Setting up the unit provider");
         if Length (Args.Project_File.Get) > 0 then
            if Args.Auto_Dirs.Get'Length /= 0 then
               Abort_App ("--auto-dir conflicts with -P");
            end if;

            --  Handle project file and build the list of source files to
            --  process.
            Load_Project
              (Project_File  => +Args.Project_File.Get,
               Scenario_Vars =>
                 Unbounded_String_Array (Args.Scenario_Vars.Get),
               Target        => +Args.Target.Get,
               RTS           => +Args.RTS.Get,
               Config_File   => +Args.Config_File.Get,
               Project       => Project,
               Env           => Env);
            UFP := Project_To_Provider (Project);

            if not Files_From_Args (Files) then
               List_Sources_From_Project
                 (Project.all,
                  Args.Process_Full_Project_Tree.Get,
                  Files);
            end if;

            if Args.Process_Runtime.Get then
               List_Predefined_Sources (Project.all, Env, Files);
            end if;

            --  Fill in the provider
            App_Ctx.Provider := (Kind => Project_File, Project => Project);

         elsif Args.Auto_Dirs.Get'Length > 0 then
            --  The auto provider is requested: initialize it with the given
            --  directories. Also build the list of source files to process.
            declare
               Auto_Dirs   : Args.Auto_Dirs.Result_Array renames
                  Args.Auto_Dirs.Get;
               Dirs        : GNATCOLL.VFS.File_Array (Auto_Dirs'Range);
               Found_Files : GNATCOLL.VFS.File_Array_Access;
            begin
               for I in Dirs'Range loop
                  Dirs (I) := Create (+To_String (Auto_Dirs (I)));
               end loop;
               Found_Files := Find_Files (Directories => Dirs);
               UFP := Create_Auto_Provider_Reference
                 (Found_Files.all, +Args.Charset.Get);

               if not Files_From_Args (Files) then
                  Sort (Found_Files.all);
                  for F of Found_Files.all loop
                     Files.Append (To_Unbounded_String (+F.Full_Name));
                  end loop;
               end if;

               --  Fill in the provider
               App_Ctx.Provider := (Kind => Auto_Dir, others => <>);
               for D of Dirs loop
                  App_Ctx.Provider.Dirs.Append
                    (To_Unbounded_String (+D.Full_Name));
               end loop;
               for F of Found_Files.all loop
                  App_Ctx.Provider.Dirs.Append
                    (To_Unbounded_String (+F.Full_Name));
               end loop;

               Unchecked_Free (Found_Files);
            end;

         else
            declare
               Dummy : Boolean := Files_From_Args (Files);
            begin
               --  Fill in the provider
               App_Ctx.Provider := (Kind => Default);
            end;
         end if;

         --  Make sure project-specific options are used only with -P
         if App_Ctx.Provider.Kind /= Project_File then
            if Args.Target.Get /= Null_Unbounded_String then
               Abort_App ("--target requires -P");
            elsif Args.RTS.Get /= Null_Unbounded_String then
               Abort_App ("--RTS requires -P");
            elsif Args.Config_File.Get /= Null_Unbounded_String then
               Abort_App ("--config requires -P");
            end if;
         end if;

         if Files.Is_Empty then
            Put_Line (Standard_Error, "No source file to process");
         end if;
         Trace.Decrease_Indent;

         --  Initialize contexts

         declare
            Job_Count : constant Positive :=
              (if Args.Jobs.Get = 0
               then Positive (System.Multiprocessors.Number_Of_CPUs)
               else Args.Jobs.Get);
            --  Create the number of jobs requested by the --jobs/-j argument.
            --  If 0, create one job per CPU.
         begin
            Job_Contexts := new App_Job_Context_Array'
              (1 .. Job_ID (Job_Count) =>
               (App_Ctx => App_Ctx'Unchecked_Access, others => <>));
         end;
         for JID in Job_Contexts.all'Range loop
            Job_Contexts (JID) :=
              (ID              => JID,
               App_Ctx         => App_Ctx'Unchecked_Access,
               Analysis_Ctx    => Create_Context
                                    (Charset       => +Args.Charset.Get,
                                     Unit_Provider => UFP,
                                     Event_Handler => EH),
               Units_Processed => <>,
               Aborted         => False);
         end loop;

         --  Finally, create all jobs, and one context per job to process unit
         --  files.

         Trace.Trace ("Setting up the app");
         App_Setup (App_Ctx, Job_Contexts.all);

         Trace.Trace ("Running jobs");
         declare
            Task_Pool : array (Job_Contexts.all'Range) of Main_Task_Type;
         begin
            for JID in Task_Pool'Range loop
               Task_Pool (JID).Start (JID);
            end loop;

            for F of Files loop
               Queue.Enqueue (F);
            end loop;

            for T of Task_Pool loop
               T.Stop;
            end loop;
         end;

         --  If there is at least one job that triggered abortion, make sure
         --  the program stops with an error exit status. We still want to run
         --  post-processing in this case.

         if Abortion.Abort_Signaled then
            Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
         end if;

         --  Run post-process routines and finalize the app

         Trace.Trace ("Running app post-processing");
         App_Post_Process (App_Ctx, Job_Contexts.all);
         Finalize;

         Trace.Trace ("Done");

      exception
         when Abort_App_Exception =>
            Trace.Trace ("App aborted");
            Finalize;
            Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      end Run;
   end App;

   ------------------
   -- Load_Project --
   ------------------

   procedure Load_Project
     (Project_File             : String;
      Scenario_Vars            : Unbounded_String_Array := Empty_Array;
      Target, RTS, Config_File : String := "";
      Project                  : out Project_Tree_Access;
      Env                      : out Project_Environment_Access)
   is
      procedure Cleanup;
      --  Cleanup helpers for error handling

      -------------
      -- Cleanup --
      -------------

      procedure Cleanup is
      begin
         Free (Project);
         Free (Env);
      end Cleanup;
   begin
      Libadalang.Project_Provider.Trace.Trace
        ("Loading project " & Project_File);
      Project := new Project_Tree;
      Initialize (Env);

      --  Set scenario variables
      for Assoc of Scenario_Vars loop
         declare
            A        : constant String := +Assoc;
            Eq_Index : Natural := A'First;
         begin
            while Eq_Index <= A'Last
              and then A (Eq_Index) /= '=' loop
               Eq_Index := Eq_Index + 1;
            end loop;
            if Eq_Index not in A'Range then
               Cleanup;
               Abort_App ("Invalid scenario variable: -X" & A);
            end if;
            Change_Environment
              (Env.all,
               A (A'First .. Eq_Index - 1),
               A (Eq_Index + 1 .. A'Last));
         end;
      end loop;

      --  Set the target/runtime or use the config file
      if Config_File = "" then
         Env.Set_Target_And_Runtime (Target, RTS);
      elsif Target /= "" or else RTS /= "" then
         Cleanup;
         Abort_App ("--config not allowed if --target or --RTS are passed");
      else
         Env.Set_Config_File (Create (+Config_File));
      end if;

      --  Load the project tree, and beware of loading errors. Wrap
      --  the project in a unit provider.
      begin
         Project.Load
           (Root_Project_Path => Create (+Project_File),
            Env               => Env,
            Errors            => Print_Error'Access);
      exception
         when Invalid_Project =>
            Libadalang.Project_Provider.Trace.Trace ("Loading failed");
            Cleanup;
            Abort_App;
      end;
      Libadalang.Project_Provider.Trace.Trace ("Loading succeeded");
   end Load_Project;

   -------------------------------
   -- List_Sources_From_Project --
   -------------------------------

   procedure List_Sources_From_Project
     (Project             : Project_Tree'Class;
      Include_Subprojects : Boolean;
      Files               : out String_Vectors.Vector)
   is
      --  Get a sorted list of source files in Project's root project.
      --  Sorting gets the output deterministic and thus helps
      --  reproducibility.

      List : File_Array_Access :=
        Project.Root_Project.Source_Files
          (Recursive                => Include_Subprojects,
           Include_Externally_Built => False);
   begin
      Sort (List.all);

      for F of List.all loop
         declare
            FI        : constant File_Info := Project.Info (F);
            Full_Name : Filesystem_String renames F.Full_Name.all;
            Name      : constant String := +Full_Name;
         begin
            if FI.Language = "ada" then
               Files.Append (+Name);
            end if;
         end;
      end loop;
      Unchecked_Free (List);
   end List_Sources_From_Project;

   -------------------------
   -- Project_To_Provider --
   -------------------------

   function Project_To_Provider
     (Project : Project_Tree_Access) return Unit_Provider_Reference
   is
      Partition : Provider_And_Projects_Array_Access :=
        Create_Project_Unit_Providers (Project);
   begin
      --  Reject partitions with multiple parts: we cannot analyze it with
      --  only one provider.

      if Partition.all'Length /= 1 then
         Free (Partition);
         Abort_App ("This aggregate project contains conflicting sources");
      end if;

      return Result : constant Unit_Provider_Reference :=
        Partition.all (Partition'First).Provider
      do
         Free (Partition);
      end return;
   end Project_To_Provider;

   package Cmd_Line_Event_Handler is
      package Files_Sets is new Ada.Containers.Hashed_Sets
        (Unbounded_Text_Type, Hash, "=");

      type Cmd_Line_Event_Handler_Type
      is new Event_Handler_Interface with record
         Exit_On_Missing_File : Boolean;
         Already_Seen_Missing_Files : Files_Sets.Set;
      end record;

      overriding procedure Unit_Requested_Callback
        (Self               : in out Cmd_Line_Event_Handler_Type;
         Context            : Analysis_Context'Class;
         Name               : Text_Type;
         From               : Analysis_Unit'Class;
         Found              : Boolean;
         Is_Not_Found_Error : Boolean);

      overriding procedure Unit_Parsed_Callback
        (Self     : in out Cmd_Line_Event_Handler_Type;
         Context  : Analysis_Context'Class;
         Unit     : Analysis_Unit'Class;
         Reparsed : Boolean)
      is null;

      overriding procedure Release (Self : in out Cmd_Line_Event_Handler_Type)
      is null;
   end Cmd_Line_Event_Handler;

   package body Cmd_Line_Event_Handler is

      -----------------------------
      -- Unit_Requested_Callback --
      -----------------------------

      procedure Unit_Requested_Callback
        (Self               : in out Cmd_Line_Event_Handler_Type;
         Context            : Analysis_Context'Class;
         Name               : Text_Type;
         From               : Analysis_Unit'Class;
         Found              : Boolean;
         Is_Not_Found_Error : Boolean) is
      begin
         if not Found and Is_Not_Found_Error then
            if Self.Already_Seen_Missing_Files.Contains
              (To_Unbounded_Text (Name))
            then
               return;
            end if;

            Self.Already_Seen_Missing_Files.Include (To_Unbounded_Text (Name));

            Print_Error
              ((if Self.Exit_On_Missing_File then "ERROR: " else "WARNING: ")
               & "File "
               & Ada.Directories.Simple_Name (Image (Name))
               & " not found");

            if Self.Exit_On_Missing_File then
               GNAT.OS_Lib.OS_Exit (1);
            end if;
         end if;
      end Unit_Requested_Callback;
   end Cmd_Line_Event_Handler;

   --------------------------------
   -- Command_Line_Event_Handler --
   --------------------------------

   function Command_Line_Event_Handler
     (Exit_On_Missing_File : Boolean) return Event_Handler_Reference
   is
      Ret : Event_Handler_Reference;
   begin
      Ret.Set
        (Cmd_Line_Event_Handler.Cmd_Line_Event_Handler_Type'
          (Exit_On_Missing_File       => Exit_On_Missing_File,
           Already_Seen_Missing_Files => <>));
      return Ret;
   end Command_Line_Event_Handler;

end Libadalang.Helpers;