Merge branch 'mr/jicquel/#56.block_logger_traces' into 'master'

Display entity and location with Block_Logger traces as additional info

See merge request eng/toolchain/gnatcoll-core!100

src/gnatcoll-traces.adb

@@ -1278,7 +1278,7 @@ package body GNATCOLL.Traces is
             end if;
 
             if Global.Location.Active then
-               Msg.Append ("(loc: ");
+               Msg.Append ("(loc:");
                Msg.Append (Location);
                Msg.Append (')');
             end if;
@@ -2178,15 +2178,23 @@ package body GNATCOLL.Traces is
          if Active (Handle) then
             Result.Me := Handle;
             Result.Style := Style;
-            Result.Loc := new String'(Entity & ':' & Location);
+            Result.Location := new String'(Location);
+            Result.Entity := new String'(Entity);
+
+            --  To ensure consistency between all traces, location and entity
+            --  are also displayed in the loc and entity fields of the message,
+            --  despite this piece of information already being contained in
+            --  the first part of the message.
+
             if Message /= "" then
                Increase_Indent
-                  (Handle, "Entering " & Result.Loc.all & ' ' & Message,
-                   Style => Style, Location => "", Entity => "");
+                 (Handle,
+                 "Entering " & Entity & ':' & Location & ' ' & Message,
+                  Style => Style, Location => Location, Entity => Entity);
             else
                Increase_Indent
-                  (Handle, "Entering " & Result.Loc.all,
-                   Style => Style, Location => "", Entity => "");
+                 (Handle, "Entering " & Entity & ':' & Location,
+                  Style => Style, Location => Location, Entity => Entity);
             end if;
          end if;
       end return;
@@ -2200,13 +2208,21 @@ package body GNATCOLL.Traces is
    begin
       --  If we were active when Create was called
       if Self.Me /= null then
+
+         --  To ensure consistency between all traces, location and entity
+         --  are also displayed in the loc and entity fields of the message,
+         --  despite this piece of information already being contained in
+         --  the first part of the message.
+
          Decrease_Indent
-            (Self.Me, "Leaving " & Self.Loc.all,
+            (Self.Me, "Leaving " & Self.Entity.all & ':' & Self.Location.all,
              Style    => Self.Style,
-             Location => "",   --  avoid duplicate info in the output
-             Entity   => "");
+             Location => Self.Location.all,
+             Entity   => Self.Entity.all);
       end if;
-      Free (Self.Loc);
+
+      Free (Self.Location);
+      Free (Self.Entity);
    end Finalize;
 
 end GNATCOLL.Traces;

src/gnatcoll-traces.ads

@@ -900,7 +900,8 @@ private
    type Block_Trace_Handle is new Ada.Finalization.Limited_Controlled with
    record
       Me            : Logger;
-      Loc           : GNAT.Strings.String_Access;
+      Location      : GNAT.Strings.String_Access;
+      Entity        : GNAT.Strings.String_Access;
       Style         : Message_Style;
    end record;
    overriding procedure Finalize (Self : in out Block_Logger);

testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_no

@@ -0,0 +1,2 @@
+PKG=yes
+DEBUG.ENCLOSING_ENTITY=no

testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_yes

@@ -0,0 +1,2 @@
+PKG=yes
+DEBUG.ENCLOSING_ENTITY=yes

testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_no

@@ -0,0 +1,2 @@
+PKG=yes
+DEBUG.LOCATION=no

testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_yes

@@ -0,0 +1,2 @@
+PKG=yes
+DEBUG.LOCATION=yes

testsuite/tests/traces/debug_config_parsing/test.adb

@@ -0,0 +1,24 @@
+with GNATCOLL.Traces; use GNATCOLL.Traces;
+with Ada.Command_Line;
+
+procedure Test is
+
+   Log : constant Logger := Create ("PKG");
+
+   procedure Foo (A : Integer);
+   --  Recursive function that decrement A and that traces its value
+   --  until it reaches 1 (included).
+
+   procedure Foo (A : Integer) is
+      Block_Log : constant Block_Logger := Create (Log);
+   begin
+      Trace (Log, "A =" & A'Img);
+      if A > 1 then
+         Foo (A - 1);
+      end if;
+   end Foo;
+
+begin
+   Parse_Config_File (Ada.Command_Line.Argument (1));
+   Foo (3);
+end Test;

testsuite/tests/traces/debug_config_parsing/test.gpr

@@ -0,0 +1,7 @@
+with "gnatcoll";
+
+project Test is
+   for Object_Dir use "obj";
+   for Exec_Dir use ".";
+   for Main use ("test.adb");
+end Test;

testsuite/tests/traces/debug_config_parsing/test.out

@@ -0,0 +1,43 @@
+== DEBUG.LOCATION=yes
+[PKG] Entering Test.Foo:test.adb:13 (loc:test.adb:13)
+   [PKG] A = 3 (loc:test.adb:15)
+   [PKG] Entering Test.Foo:test.adb:13 (loc:test.adb:13)
+      [PKG] A = 2 (loc:test.adb:15)
+      [PKG] Entering Test.Foo:test.adb:13 (loc:test.adb:13)
+         [PKG] A = 1 (loc:test.adb:15)
+      [PKG] Leaving Test.Foo:test.adb:13 (loc:test.adb:13)
+   [PKG] Leaving Test.Foo:test.adb:13 (loc:test.adb:13)
+[PKG] Leaving Test.Foo:test.adb:13 (loc:test.adb:13)
+
+== DEBUG.LOCATION=no
+[PKG] Entering Test.Foo:test.adb:13
+   [PKG] A = 3
+   [PKG] Entering Test.Foo:test.adb:13
+      [PKG] A = 2
+      [PKG] Entering Test.Foo:test.adb:13
+         [PKG] A = 1
+      [PKG] Leaving Test.Foo:test.adb:13
+   [PKG] Leaving Test.Foo:test.adb:13
+[PKG] Leaving Test.Foo:test.adb:13
+
+== DEBUG.ENCLOSING_ENTITY=yes
+[PKG] Entering Test.Foo:test.adb:13 (entity:Test.Foo)
+   [PKG] A = 3 (entity:Test.Foo)
+   [PKG] Entering Test.Foo:test.adb:13 (entity:Test.Foo)
+      [PKG] A = 2 (entity:Test.Foo)
+      [PKG] Entering Test.Foo:test.adb:13 (entity:Test.Foo)
+         [PKG] A = 1 (entity:Test.Foo)
+      [PKG] Leaving Test.Foo:test.adb:13 (entity:Test.Foo)
+   [PKG] Leaving Test.Foo:test.adb:13 (entity:Test.Foo)
+[PKG] Leaving Test.Foo:test.adb:13 (entity:Test.Foo)
+
+== DEBUG.ENCLOSING_ENTITY=no
+[PKG] Entering Test.Foo:test.adb:13
+   [PKG] A = 3
+   [PKG] Entering Test.Foo:test.adb:13
+      [PKG] A = 2
+      [PKG] Entering Test.Foo:test.adb:13
+         [PKG] A = 1
+      [PKG] Leaving Test.Foo:test.adb:13
+   [PKG] Leaving Test.Foo:test.adb:13
+[PKG] Leaving Test.Foo:test.adb:13

testsuite/tests/traces/debug_config_parsing/test.sh

@@ -0,0 +1,14 @@
+echo "== DEBUG.LOCATION=yes"
+./test .gnatdebug_location_yes
+
+echo ""
+echo "== DEBUG.LOCATION=no"
+./test .gnatdebug_location_no
+
+echo ""
+echo "== DEBUG.ENCLOSING_ENTITY=yes"
+./test .gnatdebug_enclosing_entity_yes
+
+echo ""
+echo "== DEBUG.ENCLOSING_ENTITY=no"
+./test .gnatdebug_enclosing_entity_no

testsuite/tests/traces/debug_config_parsing/test.yaml

@@ -0,0 +1,4 @@
+driver: build_run_diff
+description: Check behavior of DEBUG configuration variants
+control:
+    - [SKIP, "env.is_cross", "Tests using test.sh currently not supported on cross targets, see T616-039"]