ada: Add System.Traceback.Symbolic.Calling_Entity

This patch adds a new convenience function to the runtime library,
intended to help with logging.

gcc/ada/ChangeLog:

	* libgnat/s-trasym.ads (Calling_Entity): New function.
	* libgnat/s-trasym.adb (Calling_Entity): Add dummy body.
	* libgnat/s-trasym__dwarf.adb (Calling_Entity): New function.
	(Symbolic_Traceback, Symbolic_Traceback_No_Lock,
	Module_Symbolic_Traceback, Multi_Module_Symbolic_Traceback): Add
	Subprg_Name_Only parameter and corresponding functionality.
	(Symbolic_Traceback_No_Lock): Fix typo in documentation comment.
	* libgnat/s-dwalin.ads (Symbolic_Traceback): Likewise.
	* libgnat/s-dwalin.adb (Symbolic_Traceback): Likewise.

diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb
index 1e97a4727dd591e1f8c4be8ab9b6e487ed8bab3a..713aad4a304f79c1ec23a91991ef6376318b41e1 100644 (file)
--- a/gcc/ada/libgnat/s-dwalin.adb
+++ b/gcc/ada/libgnat/s-dwalin.adb
@@ -1912,11 +1912,12 @@ package body System.Dwarf_Lines is
    ------------------------
 
    procedure Symbolic_Traceback
-     (Cin          :        Dwarf_Context;
-      Traceback    :        STE.Tracebacks_Array;
-      Suppress_Hex :        Boolean;
-      Symbol_Found :    out Boolean;
-      Res          : in out System.Bounded_Strings.Bounded_String)
+     (Cin              : Dwarf_Context;
+      Traceback        : STE.Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Symbol_Found     : out Boolean;
+      Res              : in out System.Bounded_Strings.Bounded_String)
    is
       use Ada.Characters.Handling;
       C : Dwarf_Context := Cin;
@@ -1953,7 +1954,7 @@ package body System.Dwarf_Lines is
 
          --  If we're not requested to suppress hex addresses, emit it now.
 
-         if not Suppress_Hex then
+         if not Suppress_Hex and then not Subprg_Name_Only then
             Append_Address (Res, Addr_In_Traceback);
             Append (Res, ' ');
          end if;
@@ -2006,10 +2007,12 @@ package body System.Dwarf_Lines is
                   Append (Res, "???");
                end if;
 
-               Append (Res, " at ");
-               Append (Res, String (File_Name (1 .. Last)));
-               Append (Res, ':');
-               Append (Res, Line_Image (2 .. Line_Image'Last));
+               if not Subprg_Name_Only then
+                  Append (Res, " at ");
+                  Append (Res, String (File_Name (1 .. Last)));
+                  Append (Res, ':');
+                  Append (Res, Line_Image (2 .. Line_Image'Last));
+               end if;
             end;
          else
             if Subprg_Name.Len > 0 then
@@ -2020,7 +2023,9 @@ package body System.Dwarf_Lines is
                Append (Res, "???");
             end if;
 
-            Append (Res, " at ???");
+            if not Subprg_Name_Only then
+               Append (Res, " at ???");
+            end if;
          end if;
 
          Append (Res, ASCII.LF);

diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads
index c65d66effa2165dbb0fe76b8de62b9c58f40b32a..641e515e62f861f67bac16605f86d49a15ba2ed7 100644 (file)
--- a/gcc/ada/libgnat/s-dwalin.ads
+++ b/gcc/ada/libgnat/s-dwalin.ads
@@ -80,11 +80,12 @@ package System.Dwarf_Lines is
    --  Read symbol information to speed up Symbolic_Traceback.
 
    procedure Symbolic_Traceback
-     (Cin          :        Dwarf_Context;
-      Traceback    :        STE.Tracebacks_Array;
-      Suppress_Hex :        Boolean;
-      Symbol_Found :    out Boolean;
-      Res          : in out System.Bounded_Strings.Bounded_String);
+     (Cin              : Dwarf_Context;
+      Traceback        : STE.Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Symbol_Found     : out Boolean;
+      Res              : in out System.Bounded_Strings.Bounded_String);
    --  Generate a string for a traceback suitable for displaying to the user.
    --  If one or more symbols are found, Symbol_Found is set to True. This
    --  allows the caller to fall back to hexadecimal addresses.

diff --git a/gcc/ada/libgnat/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb
index 96a19259beaa7ae038240e385a2a9cf7aa575e42..5bab088d47a32523c5ba9865dc779c3c9a2b73ad 100644 (file)
--- a/gcc/ada/libgnat/s-trasym.adb
+++ b/gcc/ada/libgnat/s-trasym.adb
@@ -123,4 +123,8 @@ package body System.Traceback.Symbolic is
       null;
    end Enable_Cache;
 
+   function Calling_Entity return String is
+   begin
+      return "???";
+   end Calling_Entity;
 end System.Traceback.Symbolic;

diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads
index 96b26cb435434880cae4518b5a926215f859778e..59939cee70bc3f3fe769731384b4c86086692efa 100644 (file)
--- a/gcc/ada/libgnat/s-trasym.ads
+++ b/gcc/ada/libgnat/s-trasym.ads
@@ -105,4 +105,7 @@ package System.Traceback.Symbolic is
    --  with default value), but backward compatibility for direct calls
    --  is supported.
 
+   function Calling_Entity return String;
+   --  Return the name of the caller of the current subprogram if it's
+   --  available. Otherwise return "???".
 end System.Traceback.Symbolic;

diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb
index 479b5d34d118cfd845e052b787e76ca4ba94239a..09026c91efe8c0faf13bb6b80f10ac29b230d093 100644 (file)
--- a/gcc/ada/libgnat/s-trasym__dwarf.adb
+++ b/gcc/ada/libgnat/s-trasym__dwarf.adb
@@ -96,13 +96,16 @@ package body System.Traceback.Symbolic is
    --  Initialize Exec_Module if not already initialized
 
    function Symbolic_Traceback
-     (Traceback    : System.Traceback_Entries.Tracebacks_Array;
-      Suppress_Hex : Boolean) return String;
+     (Traceback        : System.Traceback_Entries.Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean) return String;
    function Symbolic_Traceback
      (E            : Ada.Exceptions.Exception_Occurrence;
       Suppress_Hex : Boolean) return String;
    --  Suppress_Hex means do not print any hexadecimal addresses, even if the
-   --  symbol is not available.
+   --  symbol is not available. Subprg_Name_Only means to only print the
+   --  subprogram name for each frame, as opposed to the complete description
+   --  of the frame.
 
    function Lt (Left, Right : Module_Cache_Acc) return Boolean;
    --  Sort function for Module_Cache
@@ -166,30 +169,34 @@ package body System.Traceback.Symbolic is
    --  Non-symbolic traceback (simply write addresses in hexa)
 
    procedure Symbolic_Traceback_No_Lock
-     (Traceback    :        Tracebacks_Array;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String);
-   --  Like the public Symbolic_Traceback_No_Lock except there is no provision
-   --  against concurrent accesses.
+     (Traceback        : Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String);
+   --  Like the public Symbolic_Traceback except there is no provision against
+   --  concurrent accesses.
 
    procedure Module_Symbolic_Traceback
-     (Traceback    :        Tracebacks_Array;
-      Module       :        Module_Cache;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String);
+     (Traceback        : Tracebacks_Array;
+      Module           : Module_Cache;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String);
    --  Returns the Traceback for a given module
 
    procedure Multi_Module_Symbolic_Traceback
-     (Traceback    :        Tracebacks_Array;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String);
+     (Traceback        : Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String);
    --  Build string containing symbolic traceback for the given call chain
 
    procedure Multi_Module_Symbolic_Traceback
-     (Traceback    :        Tracebacks_Array;
-      Module       :        Module_Cache;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String);
+     (Traceback        : Tracebacks_Array;
+      Module           : Module_Cache;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String);
    --  Likewise but using Module
 
    Max_String_Length : constant := 4096;
@@ -328,6 +335,36 @@ package body System.Traceback.Symbolic is
       Module_Cache_Array_Sort (Modules_Cache.all);
    end Enable_Cache;
 
+   function Calling_Entity return String is
+      N_Skipped_Frames : constant Natural := 3;
+      --  We ask Call_Chain to skip the following frames:
+      --
+      --  1. The frame of Call_Chain itself.
+      --  2. The frame of Calling_Entity.
+      --  3. The frame of Calling_Entity's caller.
+      --
+      --  The frame above that is the function the caller is looking for.
+
+      Traceback : Tracebacks_Array (1 .. 1);
+      Len       : Natural;
+   begin
+      Call_Chain (Traceback, 1, Len, Skip_Frames => N_Skipped_Frames);
+
+      if Len = 0 then
+         return "???";
+      end if;
+
+      declare
+         With_Trailing_Newline : constant String :=
+           Symbolic_Traceback
+             (Traceback, Suppress_Hex => True, Subprg_Name_Only => True);
+      begin
+         return
+           With_Trailing_Newline
+             (With_Trailing_Newline'First .. With_Trailing_Newline'Last - 1);
+      end;
+   end Calling_Entity;
+
    ---------------------
    -- Executable_Name --
    ---------------------
@@ -450,14 +487,15 @@ package body System.Traceback.Symbolic is
    -------------------------------
 
    procedure Module_Symbolic_Traceback
-     (Traceback    :        Tracebacks_Array;
-      Module       :        Module_Cache;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String)
+     (Traceback        : Tracebacks_Array;
+      Module           : Module_Cache;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String)
    is
       Success : Boolean;
    begin
-      if Symbolic.Module_Name.Is_Supported then
+      if Symbolic.Module_Name.Is_Supported and then not Subprg_Name_Only then
          Append (Res, '[');
          Append (Res, Module.Name.all);
          Append (Res, ']' & ASCII.LF);
@@ -467,11 +505,13 @@ package body System.Traceback.Symbolic is
         (Module.C,
          Traceback,
          Suppress_Hex,
+         Subprg_Name_Only,
          Success,
          Res);
 
       if not Success then
-         Hexa_Traceback (Traceback, Suppress_Hex, Res);
+         Hexa_Traceback
+           (Traceback, Suppress_Hex or else Subprg_Name_Only, Res);
       end if;
 
       --  We must not allow an unhandled exception here, since this function
@@ -487,9 +527,10 @@ package body System.Traceback.Symbolic is
    -------------------------------------
 
    procedure Multi_Module_Symbolic_Traceback
-     (Traceback    :        Tracebacks_Array;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String)
+     (Traceback        : Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String)
    is
       F : constant Natural := Traceback'First;
    begin
@@ -514,6 +555,7 @@ package body System.Traceback.Symbolic is
                   Multi_Module_Symbolic_Traceback
                     (Traceback,
                      Modules_Cache (Mid).all,
+                     Subprg_Name_Only,
                      Suppress_Hex,
                      Res);
                   return;
@@ -527,6 +569,7 @@ package body System.Traceback.Symbolic is
             Multi_Module_Symbolic_Traceback
               (Traceback (F + 1 .. Traceback'Last),
                Suppress_Hex,
+               Subprg_Name_Only,
                Res);
          end;
       else
@@ -534,10 +577,7 @@ package body System.Traceback.Symbolic is
          --  First try the executable
          if Is_Inside (Exec_Module.C, Traceback (F)) then
             Multi_Module_Symbolic_Traceback
-              (Traceback,
-               Exec_Module,
-               Suppress_Hex,
-               Res);
+              (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res);
             return;
          end if;
 
@@ -553,10 +593,7 @@ package body System.Traceback.Symbolic is
             Init_Module (Module, Success, M_Name, Load_Addr);
             if Success then
                Multi_Module_Symbolic_Traceback
-                 (Traceback,
-                  Module,
-                  Suppress_Hex,
-                  Res);
+                 (Traceback, Module, Suppress_Hex, Subprg_Name_Only, Res);
                Close_Module (Module);
             else
                --  Module not found
@@ -564,6 +601,7 @@ package body System.Traceback.Symbolic is
                Multi_Module_Symbolic_Traceback
                  (Traceback (F + 1 .. Traceback'Last),
                   Suppress_Hex,
+                  Subprg_Name_Only,
                   Res);
             end if;
          end;
@@ -571,10 +609,11 @@ package body System.Traceback.Symbolic is
    end Multi_Module_Symbolic_Traceback;
 
    procedure Multi_Module_Symbolic_Traceback
-     (Traceback    :        Tracebacks_Array;
-      Module       :        Module_Cache;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String)
+     (Traceback        : Tracebacks_Array;
+      Module           : Module_Cache;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String)
    is
       Pos : Positive;
    begin
@@ -599,10 +638,12 @@ package body System.Traceback.Symbolic is
         (Traceback (Traceback'First .. Pos - 1),
          Module,
          Suppress_Hex,
+         Subprg_Name_Only,
          Res);
       Multi_Module_Symbolic_Traceback
         (Traceback (Pos .. Traceback'Last),
          Suppress_Hex,
+         Subprg_Name_Only,
          Res);
    end Multi_Module_Symbolic_Traceback;
 
@@ -633,23 +674,22 @@ package body System.Traceback.Symbolic is
    --------------------------------
 
    procedure Symbolic_Traceback_No_Lock
-     (Traceback    :        Tracebacks_Array;
-      Suppress_Hex :        Boolean;
-      Res          : in out Bounded_String)
-   is
+     (Traceback        : Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean;
+      Res              : in out Bounded_String) is
    begin
       if Symbolic.Module_Name.Is_Supported then
-         Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
+         Multi_Module_Symbolic_Traceback
+           (Traceback, Suppress_Hex, Subprg_Name_Only, Res);
       else
          if Exec_Module_State = Failed then
             Append (Res, "Call stack traceback locations:" & ASCII.LF);
-            Hexa_Traceback (Traceback, Suppress_Hex, Res);
+            Hexa_Traceback
+              (Traceback, Suppress_Hex or else Subprg_Name_Only, Res);
          else
             Module_Symbolic_Traceback
-              (Traceback,
-               Exec_Module,
-               Suppress_Hex,
-               Res);
+              (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res);
          end if;
       end if;
    end Symbolic_Traceback_No_Lock;
@@ -662,8 +702,9 @@ package body System.Traceback.Symbolic is
    --  Copied from Ada.Exceptions.Exception_Data
 
    function Symbolic_Traceback
-     (Traceback    : Tracebacks_Array;
-      Suppress_Hex : Boolean) return String
+     (Traceback        : Tracebacks_Array;
+      Suppress_Hex     : Boolean;
+      Subprg_Name_Only : Boolean) return String
    is
       Load_Address : constant Address := Get_Executable_Load_Address;
       Res          : Bounded_String (Max_Length => Max_String_Length);
@@ -671,12 +712,13 @@ package body System.Traceback.Symbolic is
    begin
       System.Soft_Links.Lock_Task.all;
       Init_Exec_Module;
-      if Load_Address /= Null_Address then
+      if not Subprg_Name_Only and then Load_Address /= Null_Address then
          Append (Res, LDAD_Header);
          Append_Address (Res, Load_Address);
          Append (Res, ASCII.LF);
       end if;
-      Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
+      Symbolic_Traceback_No_Lock
+        (Traceback, Suppress_Hex, Subprg_Name_Only, Res);
       System.Soft_Links.Unlock_Task.all;
 
       return To_String (Res);
@@ -690,13 +732,17 @@ package body System.Traceback.Symbolic is
    function Symbolic_Traceback
      (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
    begin
-      return Symbolic_Traceback (Traceback, Suppress_Hex => False);
+      return
+        Symbolic_Traceback
+          (Traceback, Suppress_Hex => False, Subprg_Name_Only => False);
    end Symbolic_Traceback;
 
    function Symbolic_Traceback_No_Hex
      (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
    begin
-      return Symbolic_Traceback (Traceback, Suppress_Hex => True);
+      return
+        Symbolic_Traceback
+          (Traceback, Suppress_Hex => True, Subprg_Name_Only => False);
    end Symbolic_Traceback_No_Hex;
 
    function Symbolic_Traceback
@@ -704,9 +750,11 @@ package body System.Traceback.Symbolic is
       Suppress_Hex : Boolean) return String
    is
    begin
-      return Symbolic_Traceback
+      return
+        Symbolic_Traceback
           (Ada.Exceptions.Traceback.Tracebacks (E),
-           Suppress_Hex);
+           Suppress_Hex,
+           False);
    end Symbolic_Traceback;
 
    function Symbolic_Traceback