g-exctra.adb 5.49 KB
Newer Older
Richard Kenner committed
1 2 3 4 5 6 7 8
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                  G N A T . E X C E P T I O N _ T R A C E S               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
9
--            Copyright (C) 2000-2002 Ada Core Technologies, Inc.           --
Richard Kenner committed
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
29 30
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
Richard Kenner committed
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
--                                                                          --
------------------------------------------------------------------------------

with System.Standard_Library; use System.Standard_Library;
with System.Soft_Links;       use System.Soft_Links;

package body GNAT.Exception_Traces is

   --  Calling the decorator directly from where it is needed would require
   --  introducing nasty dependencies upon the spec of this package (typically
   --  in a-except.adb). We also have to deal with the fact that the traceback
   --  array within an exception occurrence and the one the decorator shall
   --  accept are of different types. These are two reasons for which a wrapper
   --  with a System.Address argument is indeed used to call the decorator
   --  provided by the user of this package. This wrapper is called via a
   --  soft-link, which either is null when no decorator is in place or "points
   --  to" the following function otherwise.

   function Decorator_Wrapper
     (Traceback : System.Address;
      Len       : Natural)
      return      String;
   --  The wrapper to be called when a decorator is in place for exception
   --  backtraces.
   --
   --  Traceback is the address of the call chain array as stored in the
   --  exception occurrence and Len is the number of significant addresses
   --  contained in this array.

   Current_Decorator : Traceback_Decorator := null;
   --  The decorator to be called by the wrapper when it is not null, as set
   --  by Set_Trace_Decorator. When this access is null, the wrapper is null
   --  also and shall then not be called.

   -----------------------
   -- Decorator_Wrapper --
   -----------------------

   function Decorator_Wrapper
     (Traceback : System.Address;
      Len       : Natural)
      return      String
   is
      Decorator_Traceback : Tracebacks_Array (1 .. Len);
      for Decorator_Traceback'Address use Traceback;

      --  Handle the "transition" from the array stored in the exception
      --  occurrence to the array expected by the decorator.

      pragma Import (Ada, Decorator_Traceback);

   begin
      return Current_Decorator.all (Decorator_Traceback);
   end Decorator_Wrapper;

   -------------------------
   -- Set_Trace_Decorator --
   -------------------------

   procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is
   begin
      Current_Decorator := Decorator;

      if Current_Decorator /= null then
         Traceback_Decorator_Wrapper := Decorator_Wrapper'Access;
      else
         Traceback_Decorator_Wrapper := null;
      end if;
   end Set_Trace_Decorator;

   --  Trace_On/Trace_Off control the kind of automatic output to occur
   --  by way of the global Exception_Trace variable.

   ---------------
   -- Trace_Off --
   ---------------

   procedure Trace_Off is
   begin
      Exception_Trace := RM_Convention;
   end Trace_Off;

   --------------
   -- Trace_On --
   --------------

117
   procedure Trace_On (Kind : Trace_Kind) is
Richard Kenner committed
118 119 120 121 122 123 124 125 126 127
   begin
      case Kind is
         when Every_Raise =>
            Exception_Trace := Every_Raise;
         when Unhandled_Raise =>
            Exception_Trace := Unhandled_Raise;
      end case;
   end Trace_On;

end GNAT.Exception_Traces;