Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / g-exctra.adb
blob1ac24cebd56a03bc1675b1475afd6ab50a8050b6
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 ------------------------------------------------------------------------------
32 with System.Standard_Library; use System.Standard_Library;
33 with System.Soft_Links; use System.Soft_Links;
35 package body GNAT.Exception_Traces is
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.
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.
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.
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.
62 -----------------------
63 -- Decorator_Wrapper --
64 -----------------------
66 function Decorator_Wrapper
67 (Traceback : System.Address;
68 Len : Natural) return String
70 Decorator_Traceback : Tracebacks_Array (1 .. Len);
71 for Decorator_Traceback'Address use Traceback;
73 -- Handle the "transition" from the array stored in the exception
74 -- occurrence to the array expected by the decorator.
76 pragma Import (Ada, Decorator_Traceback);
78 begin
79 return Current_Decorator.all (Decorator_Traceback);
80 end Decorator_Wrapper;
82 -------------------------
83 -- Set_Trace_Decorator --
84 -------------------------
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;
94 ---------------
95 -- Trace_Off --
96 ---------------
98 procedure Trace_Off is
99 begin
100 Exception_Trace := RM_Convention;
101 end Trace_Off;
103 --------------
104 -- Trace_On --
105 --------------
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;
117 end GNAT.Exception_Traces;