libadalang_24.0.0_a1358075/src-mains/nameres.adb

with Ada.Calendar;                    use Ada.Calendar;
with Ada.Containers.Generic_Array_Sort;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Exceptions;
with Ada.Strings.Unbounded;           use Ada.Strings.Unbounded;
with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;

with GNAT.Traceback.Symbolic;

with GNATCOLL.JSON;
with GNATCOLL.Memory; use GNATCOLL.Memory;
with GNATCOLL.Opt_Parse;
with GNATCOLL.VFS;    use GNATCOLL.VFS;

with Langkit_Support.Adalog.Debug;   use Langkit_Support.Adalog.Debug;
with Langkit_Support.Lexical_Envs;
with Langkit_Support.Slocs;          use Langkit_Support.Slocs;
with Langkit_Support.Text;           use Langkit_Support.Text;

with Libadalang.Analysis;  use Libadalang.Analysis;
with Libadalang.Common;    use Libadalang.Common;
with Libadalang.Helpers;   use Libadalang.Helpers;
with Libadalang.Iterators; use Libadalang.Iterators;

with Put_Title;

procedure Nameres is

   package J renames GNATCOLL.JSON;

   type Stats_Record is record
      Nb_Files_Analyzed    : Natural := 0;
      Nb_Successes         : Natural := 0;
      Nb_Fails             : Natural := 0;
      Nb_Xfails            : Natural := 0;
      Nb_Exception_Fails   : Natural := 0;
      Max_Nb_Fails         : Natural := 0;
      File_With_Most_Fails : Unbounded_String;
   end record;

   procedure Merge (Stats : in out Stats_Record; Other : Stats_Record);
   --  Merge data from Stats and Other into Stats

   type Config_Record is record
      Display_Slocs : Boolean := False;
      --  Whether to display slocs for resolved names

      Display_Images : Boolean := False;
      --  Whether to display images for resolved names
   end record;

   type Reference_Kind is (Any, Subp_Call, Subp_Overriding, Type_Derivation);
   --  Kind of reference for Find_All_References pragmas. Each kind leads to a
   --  specific find-all-references property: see Process_Refs below for
   --  associations.

   type Refs_Request is record
      Kind               : Reference_Kind;
      Target             : Basic_Decl;
      Imprecise_Fallback : Boolean;
      Show_Slocs         : Boolean;
      Follow_Renamings   : Boolean;
      From_Pragma        : Pragma_Node;
   end record;

   package Refs_Request_Vectors is new Ada.Containers.Vectors
     (Positive, Refs_Request);

   type Job_Data_Record is record
      Stats         : Stats_Record;
      Config        : Config_Record;
      Refs_Requests : Refs_Request_Vectors.Vector;
   end record;

   type Job_Data_Array is array (Job_ID range <>) of Job_Data_Record;
   type Job_Data_Array_Access is access all Job_Data_Array;
   procedure Free is new Ada.Unchecked_Deallocation
     (Job_Data_Array, Job_Data_Array_Access);

   Job_Data   : Job_Data_Array_Access;

   Time_Start : Time;
   --  Time at which the app starts, when Args.Time is set

   procedure App_Setup (Context : App_Context; Jobs : App_Job_Context_Array);
   procedure Job_Setup (Context : App_Job_Context);
   procedure Process_Unit (Context : App_Job_Context; Unit : Analysis_Unit);
   procedure Job_Post_Process (Context : App_Job_Context);
   procedure App_Post_Process
     (Context : App_Context; Jobs : App_Job_Context_Array);

   package App is new Libadalang.Helpers.App
     (Name               => "nameres",
      Description        =>
         "Run Libadalang's name resolution on a file, set of files or project",
      Enable_Parallelism => True,
      App_Setup          => App_Setup,
      Job_Setup          => Job_Setup,
      Process_Unit       => Process_Unit,
      Job_Post_Process   => Job_Post_Process,
      App_Post_Process   => App_Post_Process);

   package Args is
      use GNATCOLL.Opt_Parse;

      package File_Limit is new Parse_Option
        (App.Args.Parser, "-l", "--file-limit", "Stop program after N files",
         Integer, Default_Val => -1);

      package Discard_Errors_In_PLE is new Parse_Flag
        (App.Args.Parser, "-D", "--discard-PLE-errors",
         "Discard errors while constructing lexical envs");

      package Quiet is new Parse_Flag
        (App.Args.Parser, "-q", "--quiet", "Quiet mode (no output on stdout)");

      package JSON is new Parse_Flag
        (App.Args.Parser, "-J", "--json",
         "JSON mode (Structured output on stdout)");

      package Stats is new Parse_Flag
        (App.Args.Parser, "-S", "--stats",
         "Output stats at the end of analysis");

      package Resolve_All is new Parse_Flag
        (App.Args.Parser, "-A", "--all", "Resolve every cross reference");

      package Solve_Line is new Parse_Option
        (App.Args.Parser, "-L", "--solve-line", "Only analyze line N",
         Natural, Default_Val => 0);

      package Only_Show_Failures is new Parse_Flag
        (App.Args.Parser, Long => "--only-show-failures",
         Help => "Only output failures on stdout. Note that this triggers"
                 & " failures logging even when --quiet is passed.");

      package Imprecise_Fallback is new Parse_Flag
        (App.Args.Parser, Long => "--imprecise-fallback",
         Help => "Activate fallback mechanism for name resolution");

      package Disable_Operator_Resolution is new Parse_Flag
        (App.Args.Parser, Long => "--disable-operator-resolution",
         Help => "Do not resolve unary/binary operations");

      package Dump_Envs is new Parse_Flag
        (App.Args.Parser, "-E", "--dump-envs",
         Help => "Dump lexical envs after populating them");

      package Do_Reparse is new Parse_Flag
        (App.Args.Parser,
         Long => "--reparse",
         Help => "Reparse units 10 times (hardening)");

      package Time is new Parse_Flag
        (App.Args.Parser,
         Long  => "--time",
         Short => "-T",
         Help  => "Show the time it took to nameres each file. "
                  & "Implies --quiet so that you only have timing info");

      package Memory is new Parse_Flag
        (App.Args.Parser,
         Long  => "--memory",
         Short => "-M",
         Help  => "Show the global memory footprint on exit");

      package Timeout is new Parse_Option
        (App.Args.Parser, "-t", "--timeout",
         "Timeout equation solving after N steps",
         Natural,
         Default_Val => Langkit_Support.Adalog.Default_Timeout_Ticks_Number);

      package Lookup_Cache_Mode is new Parse_Enum_Option
        (App.Args.Parser,
         Long        => "--lookup-cache-mode",
         Arg_Type    => Langkit_Support.Lexical_Envs.Lookup_Cache_Kind,
         Default_Val => Langkit_Support.Lexical_Envs.Full,
         Help        => "Set the lookup cache mode (ADVANCED)");

      package Debug is new Parse_Flag
        (App.Args.Parser, "-D", "--debug",
         Help => "Debug logic equation solving");
   end Args;

   package Env renames Ada.Environment_Variables;

   function Lookup_Cache_Mode
     return Langkit_Support.Lexical_Envs.Lookup_Cache_Kind
   is
     (if Env.Exists ("LAL_NAMERES_LOOKUP_CACHE_MODE")
      then Langkit_Support.Lexical_Envs.Lookup_Cache_Kind'Value
        (Env.Value ("LAL_NAMERES_LOOKUP_CACHE_MODE"))
      else Args.Lookup_Cache_Mode.Get);

   function Quiet return Boolean is
      (Args.Quiet.Get or else Args.JSON.Get or else Args.Time.Get);

   function Text (N : Ada_Node'Class) return String is (Image (Text (N)));

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

   function "<" (Left, Right : Ada_Node) return Boolean is
     (Sloc_Range (Left).Start_Line < Sloc_Range (Right).Start_Line);

   procedure Sort is new Ada.Containers.Generic_Array_Sort
     (Index_Type   => Positive,
      Element_Type => Ada_Node,
      Array_Type   => Ada_Node_Array,
      "<"          => "<");

   function Decode_Boolean_Literal (T : Text_Type) return Boolean is
     (Boolean'Wide_Wide_Value (T));
   procedure Process_File
     (Job_Data : in out Job_Data_Record;
      Unit     : Analysis_Unit;
      Filename : String);

   function Do_Pragma_Test (Arg : Expr) return Ada_Node_Array is
     (P_Matching_Nodes (Arg));
   --  Do the resolution associated to a Test pragma.
   --
   --  This function is here to provide a simple breakpoint location for
   --  debugging sessions.

   procedure New_Line;
   procedure Put_Line (S : String);
   procedure Put (S : String);

   procedure Dump_Exception
     (E   : Ada.Exceptions.Exception_Occurrence;
      Obj : in out J.JSON_Value);
   --  Dump the exception ``E``, honoring the ``Args.No_Traceback`` flag (e.g.
   --  don't show tracebacks when asked not to). If ``Obj`` is passed and
   --  ``Args.JSON`` is set, also set fields in ``Obj``.

   procedure Increment (Counter : in out Natural);

   type Supported_Pragma is
     (Ignored_Pragma, Error_In_Pragma, Pragma_Config, Pragma_Section,
      Pragma_Test, Pragma_Test_Statement, Pragma_Test_Statement_UID,
      Pragma_Test_Block, Pragma_Find_All_References);
   type Decoded_Pragma (Kind : Supported_Pragma) is record
      case Kind is
         when Ignored_Pragma =>
            --  Nameres does not handle this pragma
            null;

         when Error_In_Pragma =>
            --  We had trouble decoding this pragma
            Error_Sloc    : Source_Location;
            Error_Message : Unbounded_String;

         when Pragma_Config =>
            --  Tune nameres' settings
            Config_Name : Unbounded_Text_Type;
            Config_Expr : Expr;

         when Pragma_Section =>
            --  Output headlines
            Section_Name : Unbounded_Text_Type;

         when Pragma_Test =>
            --  Run name resolution on the given expression
            Test_Expr  : Expr;
            Test_Debug : Boolean;

         when Pragma_Test_Statement
            | Pragma_Test_Statement_UID
            | Pragma_Test_Block
         =>
            --  Run name resolution on the statement that precedes this pragma.
            --
            --  For the UID version, but show the unique_identifying name of
            --  the declarations instead of the node image.  This is used in
            --  case the node might change (for example in tests where we
            --  resolve runtime things).
            --
            --  For the block version, run name resolution on all xref entry
            --  points in the statement that precedes this pragma, or on the
            --  whole compilation unit if top-level.
            Test_Target : Ada_Node;

         when Pragma_Find_All_References =>
            --  Run the find-all-references property designated by Refs_Kind on
            --  Refs_Target, for all loaded units. If Refs_Target is null, run
            --  the find-all-reference property on all applicable nodes in this
            --  unit.
            Refs_Kind               : Reference_Kind;
            Refs_Target             : Basic_Decl;
            Refs_Imprecise_Fallback : Boolean;
            Refs_Show_Slocs         : Boolean;
            Refs_Follow_Renamings   : Boolean;
      end case;
   end record;

   function Decode_Pragma (Node : Pragma_Node) return Decoded_Pragma;

   -----------
   -- Merge --
   -----------

   procedure Merge (Stats : in out Stats_Record; Other : Stats_Record) is
   begin
      Stats.Nb_Files_Analyzed :=
         Stats.Nb_Files_Analyzed + Other.Nb_Files_Analyzed;
      Stats.Nb_Successes := Stats.Nb_Successes + Other.Nb_Successes;
      Stats.Nb_Fails := Stats.Nb_Fails + Other.Nb_Fails;
      Stats.Nb_Xfails := Stats.Nb_Xfails + Other.Nb_Xfails;
      Stats.Nb_Exception_Fails :=
         Stats.Nb_Exception_Fails + Other.Nb_Exception_Fails;

      if Stats.Max_Nb_Fails < Other.Max_Nb_Fails then
         Stats.Max_Nb_Fails := Other.Max_Nb_Fails;
         Stats.File_With_Most_Fails := Other.File_With_Most_Fails;
      end if;
   end Merge;

   --------------
   -- New_Line --
   --------------

   procedure New_Line is
   begin
      if not Quiet then
         Ada.Text_IO.New_Line;
      end if;
   end New_Line;

   --------------
   -- Put_Line --
   --------------

   procedure Put_Line (S : String) is begin
      if not Quiet then
         Ada.Text_IO.Put_Line (S);
      end if;
   end Put_Line;

   ---------
   -- Put --
   ---------

   procedure Put (S : String) is begin
      if not Quiet then
         Ada.Text_IO.Put (S);
      end if;
   end Put;

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

   procedure Dump_Exception
     (E   : Ada.Exceptions.Exception_Occurrence;
      Obj : in out J.JSON_Value) is
   begin
      if not Quiet or else Args.Only_Show_Failures.Get then
         App.Dump_Exception (E);
      end if;

      if Args.JSON.Get then
         Obj.Set_Field ("success", False);
         Obj.Set_Field
           ("exception_message", Ada.Exceptions.Exception_Message (E));

         if App.Args.Sym_Traceback.Get then
            Obj.Set_Field
              ("exception_traceback",
               GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
         else
            Obj.Set_Field
              ("exception_traceback",
               Ada.Exceptions.Exception_Information (E));
         end if;

         Ada.Text_IO.Put_Line (Obj.Write);
      end if;
   end Dump_Exception;

   ---------------
   -- Increment --
   ---------------

   procedure Increment (Counter : in out Natural) is
   begin
      Counter := Counter + 1;
   end Increment;

   -------------------
   -- Decode_Pragma --
   -------------------

   function Decode_Pragma (Node : Pragma_Node) return Decoded_Pragma is

      Name         : constant String := Text (Node.F_Id);
      Untyped_Args : constant Ada_Node_Array := Node.F_Args.Children;
      Args         : array (Untyped_Args'Range) of Pragma_Argument_Assoc;

      function Error (Message : String) return Decoded_Pragma
      is ((Error_In_Pragma, Start_Sloc (Node.Sloc_Range), +Message));
      --  Shortcut to build Error_In_Pragma records

      function N_Args_Error (Expected : Natural) return Decoded_Pragma
      is (Error ("expected " & Expected'Image & " pragma arguments, got"
                 & Args'Length'Image));
      function N_Args_Error
        (At_Least, At_Most : Natural) return Decoded_Pragma
      is (Error ("expected between" & At_Least'Image & " and" & At_Most'Image
                 & " pragma arguments, got" & Args'Length'Image));
      --  Return an Error_In_Pragma record for an unexpected number of pragma
      --  arguments.

   begin
      for I in Untyped_Args'Range loop
         Args (I) := Untyped_Args (I).As_Pragma_Argument_Assoc;
      end loop;

      if Name = "Config" then
         if Args'Length /= 1 then
            return N_Args_Error (1);
         elsif Args (1).F_Name.Is_Null then
            return Error ("Missing argument name");
         elsif Args (1).F_Name.Kind /= Ada_Identifier then
            return Error ("Argument name must be an identifier");
         else
            return (Pragma_Config,
                    To_Unbounded_Text (Args (1).F_Name.Text),
                    Args (1).F_Expr);
         end if;

      elsif Name = "Section" then
         if Args'Length /= 1 then
            return N_Args_Error (1);
         elsif not Args (1).F_Name.Is_Null then
            return Error ("No argument name allowed");
         elsif Args (1).F_Expr.Kind /= Ada_String_Literal then
            return Error ("Section name must be a string literal");
         else
            return (Pragma_Section,
                    To_Unbounded_Text (Args (1).F_Expr
                    .As_String_Literal.P_Denoted_Value));
         end if;

      elsif Name = "Test" then
         if Args'Length not in 1 | 2 then
            return N_Args_Error (1, 2);
         end if;

         declare
            Result : Decoded_Pragma (Pragma_Test);
         begin
            if not Args (1).F_Name.Is_Null then
               return Error ("No argument name allowed");
            end if;
            Result.Test_Expr := Args (1).F_Expr;

            if Args'Length > 1 then
               if not Args (2).F_Name.Is_Null then
                  return Error ("No argument name allowed");
               elsif Args (2).F_Expr.Kind /= Ada_Identifier
                     or else Args (2).F_Expr.Text /= "Debug"
               then
                  return Error ("When present, the second argument must be the"
                                & "Debug identifier");
               end if;
               Result.Test_Debug := True;
            else
               Result.Test_Debug := False;
            end if;

            return Result;
         end;

      elsif Name = "Test_Statement" then
         if Args'Length /= 0 then
            return N_Args_Error (0);
         end if;
         return (Pragma_Test_Statement, Node.Previous_Sibling);

      elsif Name = "Test_Statement_UID" then
         if Args'Length /= 0 then
            return N_Args_Error (0);
         end if;
         return (Pragma_Test_Statement_UID, Node.Previous_Sibling);

      elsif Name = "Test_Block" then
         if Args'Length /= 0 then
            return N_Args_Error (0);
         end if;
         declare
            Parent : constant Ada_Node := Node.Parent.Parent;
            Target : constant Ada_Node :=
              (if Parent.Kind = Ada_Compilation_Unit
               then Parent.As_Compilation_Unit.F_Body
               else Node.Previous_Sibling);
         begin
            return (Pragma_Test_Block, Target);
         end;

      elsif Name = "Find_All_References" then
         if Args'Length not in 1 .. 4 then
            return N_Args_Error (1, 4);
         end if;

         declare
            Result : Decoded_Pragma (Pragma_Find_All_References);

            N : Positive := 1;
            --  Logical index of the next positional argument to process

            Target : Ada_Node := Node.Previous_Sibling;
            --  Temporary to compute the find-all-refs target. By default,
            --  target the declaration that precedes the pragma.

            Imprecise_Fallback : Boolean renames
               Result.Refs_Imprecise_Fallback;
            Show_Slocs         : Boolean renames Result.Refs_Show_Slocs;
            Follow_Renamings   : Boolean renames Result.Refs_Follow_Renamings;
         begin
            Imprecise_Fallback := False;
            Follow_Renamings := False;
            Show_Slocs := True;

            for A of Args loop
               if A.F_Name.Is_Null then
                  --  This is a positional pragma argument

                  case N is
                  when 1 =>
                     if A.F_Expr.Kind /= Ada_Identifier then
                        return Error ("Identifier expected");
                     end if;

                     declare
                        Name : constant Text_Type := A.F_Expr.Text;
                     begin
                        --  The first argument is the reference kind
                        if Name = "Any" then
                           Result.Refs_Kind := Any;
                        elsif Name = "Calls" then
                           Result.Refs_Kind := Subp_Call;
                        elsif Name = "Overrides" then
                           Result.Refs_Kind := Subp_Overriding;
                        elsif Name = "Derived" then
                           Result.Refs_Kind := Type_Derivation;
                        else
                           return Error
                             ("Invalid reference kind: " & Image (Name));
                        end if;
                     end;

                  when 2 =>
                     --  The optional second argument is the find-all-refs
                     --  target.
                     case A.F_Expr.Kind is
                     when Ada_Identifier =>
                        --  Raw identifier: directive to locate the target
                        declare
                           Name : constant Text_Type := A.F_Expr.Text;
                        begin
                           if Name = "All_Decls" then
                              Target := No_Ada_Node;

                           elsif Name = "Previous_Decl" then
                              null;

                           elsif Name = "Previous_Referenced_Decl" then
                              --  Assume that the previous statement is a call:
                              --  the target is the callee.
                              Target := Target.As_Call_Stmt.F_Call.As_Ada_Node;
                              if Target.Kind = Ada_Call_Expr then
                                 Target := Target.As_Call_Expr.F_Name
                                      .P_Referenced_Decl.As_Ada_Node;
                              end if;

                           else
                              return Error ("Invalid target: " & Image (Name));
                           end if;
                        end;

                     when Ada_String_Literal =>
                        --  String literal: name of the target. Look for the
                        --  last declaration with this name that appears in
                        --  the source before this pragma.
                        declare
                           Name : constant Text_Type :=
                              A.F_Expr.As_String_Literal.P_Denoted_Value;
                           It   : Traverse_Iterator'Class := Find
                             (Node.Unit.Root, Kind_In (Ada_Basic_Decl'First,
                                                       Ada_Basic_Decl'Last));
                           N    : Ada_Node;

                           Pragma_Sloc : constant Source_Location :=
                              Start_Sloc (Node.Sloc_Range);
                        begin
                           Target := No_Ada_Node;
                           Decl_Loop : while It.Next (N)
                              and Start_Sloc (N.Sloc_Range) < Pragma_Sloc
                           loop
                              for DN of N.As_Basic_Decl.P_Defining_Names loop
                                 if DN.Text = Name then
                                    Target := N;
                                    exit Decl_Loop;
                                 end if;
                              end loop;
                           end loop Decl_Loop;

                           if Target.Is_Null then
                              return Error
                                ("No declaration for " & Image (Name));
                           end if;
                        end;

                     when others =>
                        return Error ("Unexpected expression (identifier or"
                                      & " string literal expected)");
                     end case;

                  when others =>
                     return Error ("Too many positional arguments");
                  end case;
                  N := N + 1;

               else
                  --  This is a named argument. The grammar should make sure
                  --  that names for pragma arguments are identifiers.
                  declare
                     pragma Assert (A.F_Name.Kind = Ada_Identifier);
                     Name : constant Text_Type := A.F_Name.Text;
                  begin
                     if Name = "Imprecise_Fallback" then
                        Imprecise_Fallback := Decode_Boolean_Literal
                          (A.F_Expr.Text);
                     elsif Name = "Show_Slocs" then
                        Show_Slocs := Decode_Boolean_Literal
                          (A.F_Expr.Text);
                     elsif Name = "Follow_Renamings" then
                        Follow_Renamings := Decode_Boolean_Literal
                          (A.F_Expr.Text);
                     else
                        return Error ("Unknown argument: " & Image (Name));
                     end if;
                  end;
               end if;
            end loop;

            --  Make sure we received at least one positional argument

            if N = 1 then
               return Error ("Missing first positional argument");
            end if;

            Result.Refs_Target := Target.As_Basic_Decl;
            return Result;
         end;

      else
         return (Kind => Ignored_Pragma);
      end if;
   end Decode_Pragma;

   ---------------
   -- App_Setup --
   ---------------

   procedure App_Setup (Context : App_Context; Jobs : App_Job_Context_Array) is
      pragma Unreferenced (Context);
   begin
      if Args.Memory.Get then
         GNATCOLL.Memory.Configure (Activate_Monitor => True);
      end if;

      Set_Lookup_Cache_Mode (Lookup_Cache_Mode);

      if Args.Debug.Get then
         Langkit_Support.Adalog.Solver_Trace.Set_Active (True);
         Langkit_Support.Adalog.Solv_Trace.Set_Active (True);
         Langkit_Support.Adalog.Sol_Trace.Set_Active (True);
         Set_Debug_State (Trace);
      end if;

      if Args.Time.Get then
         Time_Start := Clock;
      end if;

      Job_Data := new Job_Data_Array'(Jobs'Range => (others => <>));
   end App_Setup;

   ---------------
   -- Job_Setup --
   ---------------

   procedure Job_Setup (Context : App_Job_Context) is
      Ctx : Analysis_Context renames Context.Analysis_Ctx;
   begin
      Ctx.Discard_Errors_In_Populate_Lexical_Env
        (Args.Discard_Errors_In_PLE.Get);
      Ctx.Set_Logic_Resolution_Timeout (Args.Timeout.Get);
   end Job_Setup;

   ------------------
   -- Process_Unit --
   ------------------

   procedure Process_Unit (Context : App_Job_Context; Unit : Analysis_Unit) is
      Job_Data : Job_Data_Record renames Nameres.Job_Data (Context.ID);
      Basename : constant String := +Create (+Unit.Get_Filename).Base_Name;

      Before, After : Time;
      Time_Elapsed  : Duration;
   begin
      if not Quiet then
         Put_Title ('#', "Analyzing " & Basename);
      end if;
      Before := Clock;

      begin
         Process_File (Job_Data, Unit, Unit.Get_Filename);
      exception
         when E : others =>
            Put_Line ("PLE failed with exception for file " & Basename);
            App.Dump_Exception (E);
            return;
      end;
      After := Clock;

      Time_Elapsed := After - Before;

      if Args.Time.Get then
         Ada.Text_IO.Put_Line
           ("Time elapsed in process file for "
            & Basename & ": " & Time_Elapsed'Image);
      end if;

      Increment (Job_Data.Stats.Nb_Files_Analyzed);
      if Args.File_Limit.Get /= -1
         and then Job_Data.Stats.Nb_Files_Analyzed
                  >= Args.File_Limit.Get
      then
         Abort_App ("Requested file limit reached: aborting");
      end if;
   end Process_Unit;

   ------------------
   -- Process_File --
   ------------------

   procedure Process_File
     (Job_Data : in out Job_Data_Record;
      Unit     : Analysis_Unit;
      Filename : String)
   is
      Nb_File_Fails : Natural := 0;
      --  Number of name resolution failures not covered by XFAILs we had in
      --  this file.

      Config : Config_Record renames Job_Data.Config;

      Empty : Boolean := True;
      --  False if processing pragmas has output at least one line. True
      --  otherwise.

      function Is_Pragma_Node (N : Ada_Node) return Boolean is
        (Kind (N) = Ada_Pragma_Node);

      procedure Process_Pragma (Node : Ada_Node);
      --  Decode a pragma node and run actions accordingly (trigger name
      --  resolution, output a section name, ...).

      procedure Resolve_Node (Node : Ada_Node; Show_Slocs : Boolean := True);
      --  Run name resolution testing on Node.
      --
      --  This involves running P_Resolve_Names on Node, displaying resolved
      --  references, updating statistics, creating a JSON report if requested,
      --  etc.

      function Is_Xref_Entry_Point (N : Ada_Node) return Boolean
      is (P_Xref_Entry_Point (N)
          and then
            (Args.Solve_Line.Get = 0
             or else
             Natural (Sloc_Range (N).Start_Line) = Args.Solve_Line.Get));
      --  Return whether we should use N as an entry point for name resolution
      --  testing.

      procedure Resolve_Block (Block : Ada_Node);
      --  Call Resolve_Node on all xref entry points (according to
      --  Is_Xref_Entry_Point) in Block except for Block itself.

      --------------------
      -- Process_Pragma --
      --------------------

      procedure Process_Pragma (Node : Ada_Node) is
         P : constant Decoded_Pragma := Decode_Pragma (Node.As_Pragma_Node);
      begin
         case P.Kind is
         when Ignored_Pragma =>
            null;

         when Error_In_Pragma =>
            Put_Line (Image (P.Error_Sloc) & ": " & (+P.Error_Message));
            Empty := False;

         when Pragma_Config =>
            declare
               Value : constant Text_Type := Text (P.Config_Expr);
            begin
               if P.Config_Name = "Display_Slocs" then
                  Config.Display_Slocs := Decode_Boolean_Literal (Value);
               elsif P.Config_Name = "Display_Images" then
                  Config.Display_Images :=
                     Decode_Boolean_Literal (Value);
               else
                  raise Program_Error with
                     "Invalid configuration: " & Image (+P.Config_Name);
               end if;
            end;

         when Pragma_Section =>
            if not Quiet then
               Put_Title ('-', Image (To_Wide_Wide_String (P.Section_Name)));
            end if;
            Empty := True;

         when Pragma_Test =>
            Trigger_Envs_Debug (P.Test_Debug);

            declare
               Entities : Ada_Node_Array := Do_Pragma_Test (P.Test_Expr);
            begin
               Put_Line (Text (P.Test_Expr) & " resolves to:");
               Sort (Entities);
               for E of Entities loop
                  Put ("    " & (if Config.Display_Images
                                 then E.Image
                                 else Image (E.Text)));
                  if Config.Display_Slocs then
                     Put_Line (" at " & Image (Start_Sloc (E.Sloc_Range)));
                  else
                     New_Line;
                  end if;
               end loop;
               if Entities'Length = 0 then
                  Put_Line ("    <none>");
               end if;
            end;

            Empty := False;
            Trigger_Envs_Debug (False);

         when Pragma_Test_Statement | Pragma_Test_Statement_UID =>
            Resolve_Node (Node       => P.Test_Target,
                          Show_Slocs => P.Kind /= Pragma_Test_Statement_UID);
            Empty := False;

         when Pragma_Test_Block =>
            Resolve_Block (P.Test_Target);
            Empty := False;

         when Pragma_Find_All_References =>
            Job_Data.Refs_Requests.Append
              (Refs_Request'(P.Refs_Kind,
                             P.Refs_Target,
                             P.Refs_Imprecise_Fallback,
                             P.Refs_Show_Slocs,
                             P.Refs_Follow_Renamings,
                             Node.As_Pragma_Node));
         end case;
      end Process_Pragma;

      -------------------
      -- Resolve_Block --
      -------------------

      procedure Resolve_Block (Block : Ada_Node) is

         procedure Resolve_Entry_Point (Node : Ada_Node);
         --  Callback for tree traversal in Block

         -------------------------
         -- Resolve_Entry_Point --
         -------------------------

         procedure Resolve_Entry_Point (Node : Ada_Node) is
         begin
            if Node /= Block then
               Resolve_Node (Node);
            end if;
         end Resolve_Entry_Point;

         It : Ada_Node_Iterators.Iterator'Class :=
            Find (Block, Is_Xref_Entry_Point'Access);
      begin
         It.Iterate (Resolve_Entry_Point'Access);
      end Resolve_Block;

      ------------------
      -- Resolve_Node --
      ------------------

      procedure Resolve_Node (Node : Ada_Node; Show_Slocs : Boolean := True) is

         function XFAIL return Boolean;
         --  If there is an XFAIL pragma for the node being resolved, show the
         --  message, and return True.

         function Print_Node (N : Ada_Node'Class) return Visit_Status;
         --  Callback for the tree traversal in Node. Print xref info for N.

         ----------------
         -- Print_Node --
         ----------------

         function Print_Node (N : Ada_Node'Class) return Visit_Status is
         begin
            if not Quiet
               and then Kind (N) in Ada_Expr
               and then (Kind (N) not in Ada_Name
                         or else not N.As_Name.P_Is_Defining)
            then
               Put_Line ("Expr: " & N.Image);
               if Kind (N) in Ada_Name
                  and then
                    (not Args.Disable_Operator_Resolution.Get
                     or else not (Kind (N) in Ada_Op))
               then
                  declare
                     Decl_Name : constant Defining_Name :=
                        N.As_Name.P_Referenced_Defining_Name
                          (Args.Imprecise_Fallback.Get);

                     Referenced_Decl_Image : constant String :=
                        (if Show_Slocs or else Decl_Name.Is_Null
                         then Image (Decl_Name)
                         else Image
                           (Decl_Name.P_Unique_Identifying_Name));
                  begin
                     Put_Line ("  references:    " & Referenced_Decl_Image);
                  end;
               end if;

               declare
                  Type_Decl : constant Base_Type_Decl :=
                     P_Expression_Type (As_Expr (N));
                  Expected_Type_Decl : constant Base_Type_Decl :=
                     P_Expected_Expression_Type (As_Expr (N));

                  Type_Decl_Image : constant String :=
                    (if Show_Slocs or else Type_Decl.Is_Null
                     then Image (Type_Decl)
                     else Image (Type_Decl.P_Unique_Identifying_Name));

                  Expected_Type_Decl_Image : constant String :=
                    (if Show_Slocs or else Expected_Type_Decl.Is_Null
                     then Image (Expected_Type_Decl)
                     else Image
                       (Expected_Type_Decl.P_Unique_Identifying_Name));
               begin
                  Put_Line ("  type:          " & Type_Decl_Image);
                  Put_Line ("  expected type: " & Expected_Type_Decl_Image);
               end;
            end if;
            return
              (if (P_Xref_Entry_Point (N) and then As_Ada_Node (N) /= Node)
               or else (Kind (N) in Ada_Defining_Name
                        and then not P_Xref_Entry_Point (N))
               then Over
               else Into);
         end Print_Node;

         -----------
         -- XFAIL --
         -----------

         function XFAIL return Boolean is
            N : constant Ada_Node := Next_Sibling (Node);
         begin
            if not Is_Null (N) and then Kind (N) = Ada_Pragma_Node then
               if Child (N, 1).Text = "XFAIL_Nameres" then
                  declare
                     Arg : constant String_Literal :=
                        N.As_Pragma_Node.F_Args.Child (1)
                        .As_Base_Assoc.P_Assoc_Expr.As_String_Literal;
                  begin
                     if Arg.Is_Null then
                        raise Program_Error
                          with "Invalid arg for " & N.Image;
                     end if;
                     Put_Line ("XFAIL: " & Image (Arg.P_Denoted_Value, False));
                     Put_Line ("");
                  end;
               end if;
               return True;
            end if;
            return False;
         end XFAIL;

         Verbose     : constant Boolean :=
            not (Quiet or else Args.Only_Show_Failures.Get);
         Output_JSON : constant Boolean := Args.JSON.Get;

         Dummy : Visit_Status;
         Obj   : aliased J.JSON_Value;

      begin
         --  Pre-processing output

         if Output_JSON then
            Obj := J.Create_Object;
            Obj.Set_Field ("kind", "node_resolution");
            Obj.Set_Field ("file", Filename);
            Obj.Set_Field ("sloc", Image (Node.Sloc_Range));
         end if;
         if Verbose then
            Put_Title ('*', "Resolving xrefs for node " & Node.Image);
         end if;
         if Langkit_Support.Adalog.Debug.Debug then
            Assign_Names_To_Logic_Vars (Node);
         end if;

         --  Perform name resolution

         if P_Resolve_Names (Node) or else Args.Imprecise_Fallback.Get then
            if not Args.Only_Show_Failures.Get then
               Dummy := Traverse (Node, Print_Node'Access);
            end if;

            Increment (Job_Data.Stats.Nb_Successes);

            if Output_JSON then
               Obj.Set_Field ("success", True);
            end if;
         else
            if not Quiet then
               Put_Line ("Resolution failed for node " & Node.Image);
            end if;

            if XFAIL then
               Increment (Job_Data.Stats.Nb_Xfails);
            else
               Increment (Nb_File_Fails);
            end if;

            if Output_JSON then
               Obj.Set_Field ("success", False);
            end if;
         end if;

         --  Post-processing output

         if Verbose then
            Put_Line ("");
         end if;
         if Output_JSON then
            Ada.Text_IO.Put_Line (Obj.Write);
         end if;
      exception
         when E : others =>
            Put_Line
              ("Resolution failed with exception for node " & Node.Image);
            Dump_Exception (E, Obj);

            if XFAIL then
               Increment (Job_Data.Stats.Nb_Xfails);
            else
               Increment (Job_Data.Stats.Nb_Exception_Fails);
               Increment (Nb_File_Fails);
            end if;
      end Resolve_Node;

   begin
      --  Make sure there is no diagnostic for this unit. If there are, print
      --  them and do nothing else.

      if Has_Diagnostics (Unit) then
         for D of Diagnostics (Unit) loop
            Put_Line (Format_GNU_Diagnostic (Unit, D));
         end loop;
         return;
      end if;

      --  Manually trigger PLE first, and if requested reparse the unit, to
      --  make sure that rebuilding lexical envs works correctly.

      Populate_Lexical_Env (Unit);
      if Args.Do_Reparse.Get then
         for I in 1 .. 10 loop
            Reparse (Unit);
            Populate_Lexical_Env (Unit);
         end loop;
      end if;

      Job_Data.Config := (others => <>);

      if Args.Dump_Envs.Get then
         Put_Title ('-', "Dumping envs for " & Filename);
         Dump_Lexical_Env (Unit);
      end if;

      if Args.Resolve_All.Get or Args.Solve_Line.Get /= 0 then
         Resolve_Block (Root (Unit));
      end if;

      --  Run through all pragmas and execute the associated actions

      declare
         It : Traverse_Iterator'Class :=
            Find (Unit.Root, Is_Pragma_Node'Access);
      begin
         It.Iterate (Process_Pragma'Access);
      end;
      if not Empty then
         New_Line;
      end if;

      --  Update statistics

      Job_Data.Stats.Nb_Fails := Job_Data.Stats.Nb_Fails + Nb_File_Fails;
      if Job_Data.Stats.Max_Nb_Fails < Nb_File_Fails then
         Job_Data.Stats.File_With_Most_Fails := +Filename;
         Job_Data.Stats.Max_Nb_Fails := Nb_File_Fails;
      end if;

   end Process_File;

   ----------------------
   -- Job_Post_Process --
   ----------------------

   procedure Job_Post_Process (Context : App_Job_Context) is
      Job_Data : Job_Data_Record renames Nameres.Job_Data (Context.ID);
      Units    : Analysis_Unit_Array
        (1 .. Natural (Context.Units_Processed.Length));

      function Is_Refs_Target
        (Decl : Basic_Decl;
         Kind : Reference_Kind) return Boolean
      is (case Kind is
          when Any                         => True,
          when Subp_Call | Subp_Overriding => Decl.P_Is_Subprogram,
          when Type_Derivation             => Decl.Kind in Ada_Type_Decl);
      --  Return whether Decl is a valid target for the given Kind request

      procedure Process_Refs
        (Target             : Basic_Decl;
         Kind               : Reference_Kind;
         Imprecise_Fallback : Boolean;
         Show_Slocs         : Boolean;
         Follow_Renamings   : Boolean);
      --  Call the find-all-reference property corresponding to Kind on Target

      ------------------
      -- Process_Refs --
      ------------------

      procedure Process_Refs
        (Target             : Basic_Decl;
         Kind               : Reference_Kind;
         Imprecise_Fallback : Boolean;
         Show_Slocs         : Boolean;
         Follow_Renamings   : Boolean)
      is
         Empty : Boolean := True;
         What  : constant String :=
           (case Kind is
            when Any             => "References to ",
            when Subp_Call       => "Calls to ",
            when Subp_Overriding => "Overridings for ",
            when Type_Derivation => "Derivations for ");

         function Locator (Node : Ada_Node'Class) return String;
         --  Return a location string for Node suitable for test output

         procedure Print_Ref (Ref : Ada_Node'Class);

         -------------
         -- Locator --
         -------------

         function Locator (Node : Ada_Node'Class) return String is
            File : constant String :=
               +Create (+Node.Unit.Get_Filename).Base_Name;
            Sloc : constant String := Image (Node.Sloc_Range);
         begin
            return
               "(" & File & (if Show_Slocs
                             then ", " & Sloc
                             else "") & ")";
         end Locator;

         ---------------
         -- Print_Ref --
         ---------------

         procedure Print_Ref (Ref : Ada_Node'Class) is
            Ref_Decl : Ada_Node := Ref.As_Ada_Node;
         begin
            --  Follow Ref's parents chain until we have an xref entry point,
            --  to get meaningful references.
            while not Ref_Decl.Is_Null
                  and then not Ref_Decl.Parent.Is_Null
                  and then not Ref_Decl.P_Xref_Entry_Point
            loop
               Ref_Decl := Ref_Decl.Parent;
            end loop;

            declare
               Text      : constant Text_Type := Ref_Decl.Text;
               Text_Last : Natural := Text'Last;
            begin
               --  Look for the first line break in Text
               for I in Text'Range loop
                  if Text (I) in Chars.CR | Chars.LF then
                     Text_Last := I - 1;
                     exit;
                  end if;
               end loop;

               Put_Line ("   " & Image (Text (Text'First .. Text_Last)) & " "
                         & Locator (Ref_Decl));
            end;

            Empty := False;
         end Print_Ref;

      begin
         for DN of Target.P_Defining_Names loop
            Put_Line (What & Image (DN.Text) & " " & Locator (DN));
            case Kind is
            when Any =>
               for R of DN.P_Find_All_References
                 (Units, Follow_Renamings, Imprecise_Fallback)
               loop
                  Print_Ref (Ref (R));
               end loop;

            when Subp_Call =>
               for R of DN.P_Find_All_Calls
                 (Units, Follow_Renamings, Imprecise_Fallback)
               loop
                  Print_Ref (Ref (R));
               end loop;

            when Subp_Overriding =>
               for R of DN.P_Semantic_Parent.As_Basic_Decl.P_Find_All_Overrides
                 (Units, Imprecise_Fallback)
               loop
                  Print_Ref (R);
               end loop;

            when Type_Derivation =>
               for R of DN.P_Semantic_Parent.As_Type_Decl
                        .P_Find_All_Derived_Types
                          (Units, Imprecise_Fallback)
               loop
                  Print_Ref (R);
               end loop;
            end case;
         end loop;

         if Empty then
            Put_Line ("   <none>");
         end if;
      end Process_Refs;

   begin
      --  Compute the list of units

      for I in Units'Range loop
         Units (I) := Context.Units_Processed (I);
      end loop;

      --  Process all Find_All_References requests

      for R of Job_Data.Refs_Requests loop
         if R.Target.Is_Null then
            --  If there is no target, run the request on all valid targets in
            --  the unit that contains the pragma.
            declare
               It     : Traverse_Iterator'Class := Find
                 (R.From_Pragma.Unit.Root,
                  Kind_In (Ada_Basic_Decl'First, Ada_Basic_Decl'Last));
               Target : Ada_Node;
               T      : Basic_Decl;
            begin
               while It.Next (Target) loop
                  T := Target.As_Basic_Decl;
                  if Is_Refs_Target (T, R.Kind) then
                     Process_Refs
                       (T,
                        R.Kind,
                        R.Imprecise_Fallback,
                        R.Show_Slocs,
                        R.Follow_Renamings);
                  end if;
               end loop;
            end;

         else
            Process_Refs
              (R.Target,
               R.Kind,
               R.Imprecise_Fallback,
               R.Show_Slocs,
               R.Follow_Renamings);
         end if;
      end loop;
   end Job_Post_Process;

   ----------------------
   -- App_Post_Process --
   ----------------------

   procedure App_Post_Process
     (Context : App_Context; Jobs : App_Job_Context_Array)
   is
      pragma Unreferenced (Context);

      Stats     : Stats_Record;
      Total     : Natural;
      Time_Stop : Time;
      Watermark : GNATCOLL.Memory.Watermark_Info;
   begin
      --  Measure time and memory before post-processing

      if Args.Time.Get then
         Time_Stop := Clock;
      end if;

      if Args.Memory.Get then
         Watermark := GNATCOLL.Memory.Get_Allocations;
      end if;

      --  Aggregate statistics from all jobs

      Stats := Job_Data (Jobs'First).Stats;
      for I in Jobs'First + 1 .. Jobs'Last loop
         Merge (Stats, Job_Data (I).Stats);
      end loop;
      Total := Stats.Nb_Successes + Stats.Nb_Fails + Stats.Nb_Xfails;

      if Args.Stats.Get and then Total > 0 then
         declare
            type Percentage is delta 0.01 range 0.0 .. 0.01 * 2.0**32;
            Percent_Successes : constant Percentage := Percentage
              (Float (Stats.Nb_Successes) / Float (Total) * 100.0);
            Percent_Failures : constant Percentage :=
              Percentage (Float (Stats.Nb_Fails) / Float (Total) * 100.0);

            Percent_XFAIL : constant Percentage :=
              Percentage (Float (Stats.Nb_Xfails) / Float (Total) * 100.0);
         begin
            Put_Line ("Resolved " & Total'Image & " nodes");
            Put_Line ("Of which" & Stats.Nb_Successes'Image
                      & " successes - " & Percent_Successes'Image & "%");
            Put_Line ("Of which" & Stats.Nb_Fails'Image
                      & " failures - " & Percent_Failures'Image & "%");

            Put_Line ("Of which" & Stats.Nb_Xfails'Image
                      & " XFAILS - " & Percent_XFAIL'Image & "%");
            Put_Line ("File with most failures ("
                      & Stats.Max_Nb_Fails'Image
                      & "):" & (+Stats.File_With_Most_Fails));
         end;
      end if;

      Put_Line ("Done.");

      if Args.Memory.Get then
         declare
            Watermark_Mb : constant Byte_Count :=
              Watermark.Current / 1024 / 1024;
         begin
            Ada.Text_IO.Put_Line
              ("Memory allocation at end (MB):" & Watermark_Mb'Image);
         end;
      end if;

      Free (Job_Data);

      if Args.Time.Get then
         Ada.Text_IO.Put_Line
           ("Total time elapsed:" & Duration'Image (Time_Stop - Time_Start));

         --  If the user has requested --time and --memory, warn that this
         --  skews time measurements.
         if Args.Memory.Get then
            Ada.Text_IO.Put_Line
              ("WARNING: measuring memory impacts time performance!");
         end if;
      end if;
   end App_Post_Process;

begin
   App.Run;
end Nameres;