diff --git a/src/gnatcoll-traces.adb b/src/gnatcoll-traces.adb index 3aa6d7db..e7b9562b 100644 --- a/src/gnatcoll-traces.adb +++ b/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; diff --git a/src/gnatcoll-traces.ads b/src/gnatcoll-traces.ads index 77820834..52527e6b 100644 --- a/src/gnatcoll-traces.ads +++ b/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); diff --git a/testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_no b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_no new file mode 100644 index 00000000..4febbacd --- /dev/null +++ b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_no @@ -0,0 +1,2 @@ +PKG=yes +DEBUG.ENCLOSING_ENTITY=no \ No newline at end of file diff --git a/testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_yes b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_yes new file mode 100644 index 00000000..f65f7972 --- /dev/null +++ b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_enclosing_entity_yes @@ -0,0 +1,2 @@ +PKG=yes +DEBUG.ENCLOSING_ENTITY=yes diff --git a/testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_no b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_no new file mode 100644 index 00000000..a14ec360 --- /dev/null +++ b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_no @@ -0,0 +1,2 @@ +PKG=yes +DEBUG.LOCATION=no \ No newline at end of file diff --git a/testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_yes b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_yes new file mode 100644 index 00000000..d906d595 --- /dev/null +++ b/testsuite/tests/traces/debug_config_parsing/.gnatdebug_location_yes @@ -0,0 +1,2 @@ +PKG=yes +DEBUG.LOCATION=yes \ No newline at end of file diff --git a/testsuite/tests/traces/debug_config_parsing/test.adb b/testsuite/tests/traces/debug_config_parsing/test.adb new file mode 100644 index 00000000..b0cc01a1 --- /dev/null +++ b/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; diff --git a/testsuite/tests/traces/debug_config_parsing/test.gpr b/testsuite/tests/traces/debug_config_parsing/test.gpr new file mode 100644 index 00000000..d083f0c1 --- /dev/null +++ b/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; diff --git a/testsuite/tests/traces/debug_config_parsing/test.out b/testsuite/tests/traces/debug_config_parsing/test.out new file mode 100644 index 00000000..f0868134 --- /dev/null +++ b/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 diff --git a/testsuite/tests/traces/debug_config_parsing/test.sh b/testsuite/tests/traces/debug_config_parsing/test.sh new file mode 100644 index 00000000..2ce03097 --- /dev/null +++ b/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 diff --git a/testsuite/tests/traces/debug_config_parsing/test.yaml b/testsuite/tests/traces/debug_config_parsing/test.yaml new file mode 100644 index 00000000..39d41c37 --- /dev/null +++ b/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"]