1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- G N A T . E X C E P T I O N _ T R A C E S --
9 -- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 with System
.Standard_Library
; use System
.Standard_Library
;
34 with System
.Soft_Links
; use System
.Soft_Links
;
36 package body GNAT
.Exception_Traces
is
38 -- Calling the decorator directly from where it is needed would require
39 -- introducing nasty dependencies upon the spec of this package (typically
40 -- in a-except.adb). We also have to deal with the fact that the traceback
41 -- array within an exception occurrence and the one the decorator shall
42 -- accept are of different types. These are two reasons for which a wrapper
43 -- with a System.Address argument is indeed used to call the decorator
44 -- provided by the user of this package. This wrapper is called via a
45 -- soft-link, which either is null when no decorator is in place or "points
46 -- to" the following function otherwise.
48 function Decorator_Wrapper
49 (Traceback
: System
.Address
;
52 -- The wrapper to be called when a decorator is in place for exception
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.
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.
64 -----------------------
65 -- Decorator_Wrapper --
66 -----------------------
68 function Decorator_Wrapper
69 (Traceback
: System
.Address
;
73 Decorator_Traceback
: Tracebacks_Array
(1 .. Len
);
74 for Decorator_Traceback
'Address use Traceback
;
76 -- Handle the "transition" from the array stored in the exception
77 -- occurrence to the array expected by the decorator.
79 pragma Import
(Ada
, Decorator_Traceback
);
82 return Current_Decorator
.all (Decorator_Traceback
);
83 end Decorator_Wrapper
;
85 -------------------------
86 -- Set_Trace_Decorator --
87 -------------------------
89 procedure Set_Trace_Decorator
(Decorator
: Traceback_Decorator
) is
91 Current_Decorator
:= Decorator
;
93 if Current_Decorator
/= null then
94 Traceback_Decorator_Wrapper
:= Decorator_Wrapper
'Access;
96 Traceback_Decorator_Wrapper
:= null;
98 end Set_Trace_Decorator
;
100 -- Trace_On/Trace_Off control the kind of automatic output to occur
101 -- by way of the global Exception_Trace variable.
107 procedure Trace_Off
is
109 Exception_Trace
:= RM_Convention
;
116 procedure Trace_On
(Kind
: Trace_Kind
) is
120 Exception_Trace
:= Every_Raise
;
121 when Unhandled_Raise
=>
122 Exception_Trace
:= Unhandled_Raise
;
126 end GNAT
.Exception_Traces
;