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 32with System.Standard_Library; use System.Standard_Library; 33with System.Soft_Links; use System.Soft_Links; 34 35package 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 117end GNAT.Exception_Traces; 118