Merge branch 'cherry-pick-133348be' into '25.1'

Merge branch 'issue_202' into 'master'

See merge request eng/ide/libadalang-tools!277

src/pp-main.adb

@@ -53,10 +53,12 @@ begin
    GNATCOLL.Traces.Parse_Config_File;
 
    Utils.Drivers.Driver
-     (Cmd               => Cmd,
-      Tool              => Tool,
-      Tool_Package_Name => "pretty_printer",
-      Callback          => null);
+     (Cmd                   => Cmd,
+      Tool                  => Tool,
+      Tool_Package_Name     => "pretty_printer",
+      Callback              => null,
+      --  GNATpp handles preprocessing directives in its own way
+      Preprocessing_Allowed => False);
 
    --  If syntax errors are detected during the processing then return a
    --  non zero exit code.

src/utils-drivers.adb

@@ -158,7 +158,8 @@ package body Utils.Drivers is
                   F_Name.all,
                   Counter,
                   Has_Syntax_Err,
-                  Pass => Second_Pass);
+                  Pass => Second_Pass,
+                  Preprocessing_Allowed => Preprocessing_Allowed);
                if Has_Syntax_Err and then not Utils.Syntax_Errors then
                   Utils.Syntax_Errors := True;
                end if;

src/utils-tools.adb

@@ -25,8 +25,10 @@ with GNAT.Byte_Order_Mark;
 with GNAT.OS_Lib;
 
 with Langkit_Support.Diagnostics;
+with Langkit_Support.File_Readers;
 
 with Libadalang.Iterators;        use Libadalang.Iterators;
+with Libadalang.Preprocessing;    use Libadalang.Preprocessing;
 with Libadalang.Project_Provider; use Libadalang.Project_Provider;
 
 with Utils.Command_Lines.Common;   use Utils.Command_Lines.Common;
@@ -36,13 +38,14 @@ with Utils.String_Utilities; use Utils.String_Utilities;
 package body Utils.Tools is
 
    procedure Process_File
-     (Tool         : in out Tool_State'Class;
-      Cmd          : in out Command_Line;
-      File_Name    : String;
-      Counter      : Natural;
-      Syntax_Error : out Boolean;
-      Reparse      : Boolean := False;
-      Pass         : Pass_Kind := Second_Pass)
+     (Tool                  : in out Tool_State'Class;
+      Cmd                   : in out Command_Line;
+      File_Name             : String;
+      Counter               : Natural;
+      Syntax_Error          : out Boolean;
+      Reparse               : Boolean := False;
+      Pass                  : Pass_Kind := Second_Pass;
+      Preprocessing_Allowed : Boolean := False)
    is
       use GNAT.OS_Lib, GNAT.Byte_Order_Mark;
       --  We read the file into a String, and convert to wide
@@ -84,17 +87,51 @@ package body Utils.Tools is
          declare
             use GNATCOLL.Projects;
 
+            Default_Config : Libadalang.Preprocessing.File_Config;
+            File_Configs   : Libadalang.Preprocessing.File_Config_Maps.Map;
+            File_Reader    :
+              Langkit_Support.File_Readers.File_Reader_Reference :=
+                Langkit_Support.File_Readers.No_File_Reader_Reference;
+
             Provider : constant Unit_Provider_Reference :=
               (if Status (Tool.Project_Tree.all) = Empty
                then No_Unit_Provider_Reference
                else Create_Project_Unit_Provider
                       (Tree             => Tool.Project_Tree,
                        Env              => Tool.Project_Env,
                        Is_Project_Owner => False));
+
          begin
+            --  Check if there are preprocessing directives and if so, update
+            --  the File_Reader.
+
+            if Preprocessing_Allowed then
+               Libadalang
+                 .Preprocessing
+                 .Extract_Preprocessor_Data_From_Project
+                    (Tree           => Tool.Project_Tree.all,
+                     Project        => No_Project,
+                     Default_Config => Default_Config,
+                     File_Configs   => File_Configs);
+
+               if Default_Config.Enabled or not File_Configs.Is_Empty then
+                  File_Reader :=
+                    Libadalang.Preprocessing.Create_Preprocessor
+                      (Default_Config,
+                       File_Configs);
+               end if;
+            end if;
+
             Tool.Context := Create_Context
               (Charset       => Wide_Character_Encoding (Cmd),
+               File_Reader   => File_Reader,
                Unit_Provider => Provider);
+
+            --  If preprocessing is not allowed, ignore related diagnostics
+
+            if not Preprocessing_Allowed then
+               Disable_Preprocessor_Directives_Errors (Tool.Context);
+            end if;
          end;
       end if;
 

src/utils-tools.ads

@@ -88,13 +88,14 @@ package Utils.Tools is
    --  Called in between First_Per_File_Action and Second_Per_File_Action
 
    procedure Process_File
-     (Tool         : in out Tool_State'Class;
-      Cmd          : in out Command_Line;
-      File_Name    : String;
-      Counter      : Natural;
-      Syntax_Error : out Boolean;
-      Reparse      : Boolean := False;
-      Pass         : Pass_Kind := Second_Pass);
+     (Tool                  : in out Tool_State'Class;
+      Cmd                   : in out Command_Line;
+      File_Name             : String;
+      Counter               : Natural;
+      Syntax_Error          : out Boolean;
+      Reparse               : Boolean := False;
+      Pass                  : Pass_Kind := Second_Pass;
+      Preprocessing_Allowed : Boolean := False);
    --  This class-wide procedure takes care of some bookkeeping, and then
    --  dispatches to First_Per_File_Action or Second_Per_File_Action depending
    --  on the .

testsuite/tests/metric/preprocessing/foo.adb

@@ -0,0 +1,14 @@
+procedure Foo (I : in out Integer) is
+begin
+   if I > 0 then
+      goto Fin;
+      #if DEBUG then
+      if I < 10 then
+      #else
+      if I < 20 then
+      #end if;
+         goto Fin;
+      end if;
+   end if;
+   <<Fin>>
+end;

testsuite/tests/metric/preprocessing/p.gpr

@@ -0,0 +1,7 @@
+project P is
+   for Object_Dir use "obj";
+   for Source_Dirs use (".");
+   package Compiler is
+      for Switches ("Ada") use ("-gnateDDEBUG");
+   end Compiler;
+end P;

testsuite/tests/metric/preprocessing/test.out

@@ -0,0 +1,28 @@
+Line metrics summed over 1 units
+  all lines            : 14
+  code lines           : 10
+  comment lines        : 0
+  end-of-line comments : 0
+  comment percentage   : 0.00
+  blank lines          : 4
+
+Average lines in body: 10.00
+
+Element metrics summed over 1 units
+  all statements      : 4
+  all declarations    : 2
+  logical SLOC        : 6
+
+ 1 public subprograms in 1 units
+
+ 1 subprogram bodies in 1 units
+
+Average cyclomatic complexity: 3.00
+
+Coupling metrics:
+=================
+   Unit Foo (foo.adb)
+      control fan-out coupling  : 0
+      control fan-in coupling   : 0
+      unit fan-out coupling     : 0
+      unit fan-in coupling      : 0

testsuite/tests/metric/preprocessing/test.sh

@@ -0,0 +1 @@
+gnatmetric --short-file-names -P p.gpr foo.adb

testsuite/tests/metric/preprocessing/test.yaml

@@ -0,0 +1,4 @@
+description:
+    gnatmetric test
+
+driver: shell_script

testsuite/tests/pp/U916-013/test.out

@@ -19,13 +19,13 @@ Info: AdaCore provides a new formatter GNATformat, currently in beta. This will
 -----
 
 Syntax errors in test_NOK.adb
+2:1: Cannot parse <subp_body>
 8:4: Skipped token val
 8:8: Skipped token :=
 8:11: Skipped token val
 8:15: Skipped token +
 8:17: Skipped token 1
 8:18: Skipped token ;
-2:1: Cannot parse <subp_body>
 10:1: Expected 'begin', got 'end'
 10:1: Skipped token end
 10:5: Skipped token test_OK