gcc/ada/g-exctra.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                  G N A T . E X C E P T I O N _ T R A C E S               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2000-2010, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Standard_Library; use System.Standard_Library;
  33 with System.Soft_Links;       use System.Soft_Links;
  34
  35 package body GNAT.Exception_Traces is
  36
  37    --  Calling the decorator directly from where it is needed would require
  38    --  introducing nasty dependencies upon the spec of this package (typically
  39    --  in a-except.adb). We also have to deal with the fact that the traceback
  40    --  array within an exception occurrence and the one the decorator shall
  41    --  accept are of different types. These are two reasons for which a wrapper
  42    --  with a System.Address argument is indeed used to call the decorator
  43    --  provided by the user of this package. This wrapper is called via a
  44    --  soft-link, which either is null when no decorator is in place or "points
  45    --  to" the following function otherwise.
  46
  47    function Decorator_Wrapper
  48      (Traceback : System.Address;
  49       Len       : Natural) return String;
  50    --  The wrapper to be called when a decorator is in place for exception
  51    --  backtraces.
  52    --
  53    --  Traceback is the address of the call chain array as stored in the
  54    --  exception occurrence and Len is the number of significant addresses
  55    --  contained in this array.
  56
  57    Current_Decorator : Traceback_Decorator := null;
  58    --  The decorator to be called by the wrapper when it is not null, as set
  59    --  by Set_Trace_Decorator. When this access is null, the wrapper is null
  60    --  also and shall then not be called.
  61
  62    -----------------------
  63    -- Decorator_Wrapper --
  64    -----------------------
  65
  66    function Decorator_Wrapper
  67      (Traceback : System.Address;
  68       Len       : Natural) return String
  69    is
  70       Decorator_Traceback : Tracebacks_Array (1 .. Len);
  71       for Decorator_Traceback'Address use Traceback;
  72
  73       --  Handle the "transition" from the array stored in the exception
  74       --  occurrence to the array expected by the decorator.
  75
  76       pragma Import (Ada, Decorator_Traceback);
  77
  78    begin
  79       return Current_Decorator.all (Decorator_Traceback);
  80    end Decorator_Wrapper;
  81
  82    -------------------------
  83    -- Set_Trace_Decorator --
  84    -------------------------
  85
  86    procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is
  87    begin
  88       Current_Decorator := Decorator;
  89       Traceback_Decorator_Wrapper :=
  90         (if Current_Decorator /= null
  91          then Decorator_Wrapper'Access else null);
  92    end Set_Trace_Decorator;
  93
  94    ---------------
  95    -- Trace_Off --
  96    ---------------
  97
  98    procedure Trace_Off is
  99    begin
 100       Exception_Trace := RM_Convention;
 101    end Trace_Off;
 102
 103    --------------
 104    -- Trace_On --
 105    --------------
 106
 107    procedure Trace_On (Kind : Trace_Kind) is
 108    begin
 109       case Kind is
 110          when Every_Raise =>
 111             Exception_Trace := Every_Raise;
 112          when Unhandled_Raise =>
 113             Exception_Trace := Unhandled_Raise;
 114       end case;
 115    end Trace_On;
 116
 117 end GNAT.Exception_Traces;