gcc/ada/libgnat/s-exctra.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                S Y S T E M . 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-2017, 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 Ada.Unchecked_Conversion;
  33
  34 with System.Standard_Library; use System.Standard_Library;
  35 with System.Soft_Links;       use System.Soft_Links;
  36
  37 package body System.Exception_Traces is
  38
  39    --  Calling the decorator directly from where it is needed would require
  40    --  introducing nasty dependencies upon the spec of this package (typically
  41    --  in a-except.adb). We also have to deal with the fact that the traceback
  42    --  array within an exception occurrence and the one the decorator accepts
  43    --  are of different types. These are two reasons for which a wrapper with
  44    --  a System.Address argument is indeed used to call the decorator provided
  45    --  by the user of this package. This wrapper is called via a soft-link,
  46    --  which either is null when no decorator is in place or "points to" the
  47    --  following function otherwise.
  48
  49    function Decorator_Wrapper
  50      (Traceback : System.Address;
  51       Len       : Natural) return String;
  52    --  The wrapper to be called when a decorator is in place for exception
  53    --  backtraces.
  54    --
  55    --  Traceback is the address of the call chain array as stored in the
  56    --  exception occurrence and Len is the number of significant addresses
  57    --  contained in this array.
  58
  59    Current_Decorator : Traceback_Decorator := null;
  60    --  The decorator to be called by the wrapper when it is not null, as set
  61    --  by Set_Trace_Decorator. When this access is null, the wrapper is null
  62    --  also and shall then not be called.
  63
  64    -----------------------
  65    -- Decorator_Wrapper --
  66    -----------------------
  67
  68    function Decorator_Wrapper
  69      (Traceback : System.Address;
  70       Len       : Natural) return String
  71    is
  72       subtype Trace_Array is Traceback_Entries.Tracebacks_Array (1 .. Len);
  73       type Trace_Array_Access is access all Trace_Array;
  74
  75       function To_Trace_Array is new
  76         Ada.Unchecked_Conversion (Address, Trace_Array_Access);
  77
  78       Decorator_Traceback : constant Trace_Array_Access :=
  79                               To_Trace_Array (Traceback);
  80
  81    begin
  82       return Current_Decorator.all (Decorator_Traceback.all);
  83    end Decorator_Wrapper;
  84
  85    -------------------------
  86    -- Set_Trace_Decorator --
  87    -------------------------
  88
  89    procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is
  90    begin
  91       Current_Decorator := Decorator;
  92       Traceback_Decorator_Wrapper :=
  93         (if Current_Decorator /= null
  94          then Decorator_Wrapper'Access else null);
  95    end Set_Trace_Decorator;
  96
  97    ---------------
  98    -- Trace_Off --
  99    ---------------
 100
 101    procedure Trace_Off is
 102    begin
 103       Exception_Trace := RM_Convention;
 104    end Trace_Off;
 105
 106    --------------
 107    -- Trace_On --
 108    --------------
 109
 110    procedure Trace_On (Kind : Trace_Kind) is
 111    begin
 112       case Kind is
 113          when Every_Raise =>
 114             Exception_Trace := Every_Raise;
 115
 116          when Unhandled_Raise =>
 117             Exception_Trace := Unhandled_Raise;
 118
 119          when Unhandled_Raise_In_Main =>
 120             Exception_Trace := Unhandled_Raise_In_Main;
 121       end case;
 122    end Trace_On;
 123
 124 end System.Exception_Traces;