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-2015, 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 32with Ada.Unchecked_Conversion; 33 34with System.Standard_Library; use System.Standard_Library; 35with System.Soft_Links; use System.Soft_Links; 36 37package 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 when Unhandled_Raise => 116 Exception_Trace := Unhandled_Raise; 117 when Unhandled_Raise_In_Main => 118 Exception_Trace := Unhandled_Raise_In_Main; 119 end case; 120 end Trace_On; 121 122end System.Exception_Traces; 123