Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-exextr.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- ADA.EXCEPTIONS.EXCEPTION_TRACES --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
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 pragma Warnings (Off);
35 with Ada.Exceptions.Last_Chance_Handler;
36 pragma Warnings (On);
37 -- Bring last chance handler into closure
38
39 separate (Ada.Exceptions)
40 package body Exception_Traces is
41
42 Nline : constant String := String'(1 => ASCII.LF);
43 -- Convenient shortcut
44
45 type Exception_Action is access procedure (E : Exception_Occurrence);
46 Global_Action : Exception_Action := null;
47 pragma Export
48 (Ada, Global_Action, "__gnat_exception_actions_global_action");
49 -- Global action, executed whenever an exception is raised. Changing the
50 -- export name must be coordinated with code in g-excact.adb.
51
52 Raise_Hook_Initialized : Boolean := False;
53 pragma Export
54 (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
55
56 procedure Last_Chance_Handler (Except : Exception_Occurrence);
57 pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
58 pragma No_Return (Last_Chance_Handler);
59 -- Users can replace the default version of this routine,
60 -- Ada.Exceptions.Last_Chance_Handler.
61
62 function To_Action is new Ada.Unchecked_Conversion
63 (Raise_Action, Exception_Action);
64
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
68
69 procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean);
70 -- Factorizes the common processing for Notify_Handled_Exception and
71 -- Notify_Unhandled_Exception. Is_Unhandled is set to True only in the
72 -- latter case because Notify_Handled_Exception may be called for an
73 -- actually unhandled occurrence in the Front-End-SJLJ case.
74
75 ----------------------
76 -- Notify_Exception --
77 ----------------------
78
79 procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is
80 begin
81 -- Output the exception information required by the Exception_Trace
82 -- configuration. Take care not to output information about internal
83 -- exceptions.
84
85 if not Excep.Id.Not_Handled_By_Others
86 and then
87 (Exception_Trace = Every_Raise
88 or else
89 (Is_Unhandled
90 and then
91 (Exception_Trace = Unhandled_Raise
92 or else Exception_Trace = Unhandled_Raise_In_Main)))
93 then
94 -- Exception trace messages need to be protected when several tasks
95 -- can issue them at the same time.
96
97 Lock_Task.all;
98 To_Stderr (Nline);
99
100 if Exception_Trace /= Unhandled_Raise_In_Main then
101 if Is_Unhandled then
102 To_Stderr ("Unhandled ");
103 end if;
104
105 To_Stderr ("Exception raised");
106 To_Stderr (Nline);
107 end if;
108
109 To_Stderr (Exception_Information (Excep.all));
110 Unlock_Task.all;
111 end if;
112
113 -- Call the user-specific actions
114 -- ??? We should presumably look at the reraise status here.
115
116 if Raise_Hook_Initialized
117 and then Exception_Data_Ptr (Excep.Id).Raise_Hook /= null
118 then
119 To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all);
120 end if;
121
122 if Global_Action /= null then
123 Global_Action (Excep.all);
124 end if;
125 end Notify_Exception;
126
127 ------------------------------
128 -- Notify_Handled_Exception --
129 ------------------------------
130
131 procedure Notify_Handled_Exception (Excep : EOA) is
132 begin
133 Notify_Exception (Excep, Is_Unhandled => False);
134 end Notify_Handled_Exception;
135
136 --------------------------------
137 -- Notify_Unhandled_Exception --
138 --------------------------------
139
140 procedure Notify_Unhandled_Exception (Excep : EOA) is
141 begin
142 -- Check whether there is any termination handler to be executed for
143 -- the environment task, and execute it if needed. Here we handle both
144 -- the Abnormal and Unhandled_Exception task termination. Normal
145 -- task termination routine is executed elsewhere (either in the
146 -- Task_Wrapper or in the Adafinal routine for the environment task).
147
148 Task_Termination_Handler.all (Excep.all);
149
150 Notify_Exception (Excep, Is_Unhandled => True);
151 Debug_Unhandled_Exception (SSL.Exception_Data_Ptr (Excep.Id));
152 end Notify_Unhandled_Exception;
153
154 -----------------------------------
155 -- Unhandled_Exception_Terminate --
156 -----------------------------------
157
158 procedure Unhandled_Exception_Terminate (Excep : EOA) is
159 Occ : Exception_Occurrence;
160 -- This occurrence will be used to display a message after finalization.
161 -- It is necessary to save a copy here, or else the designated value
162 -- could be overwritten if an exception is raised during finalization
163 -- (even if that exception is caught). The occurrence is saved on the
164 -- stack to avoid dynamic allocation (if this exception is due to lack
165 -- of space in the heap, we therefore avoid a second failure). We assume
166 -- that there is enough room on the stack however.
167
168 begin
169 Save_Occurrence (Occ, Excep.all);
170 Last_Chance_Handler (Occ);
171 end Unhandled_Exception_Terminate;
172
173 ------------------------------------
174 -- Handling GNAT.Exception_Traces --
175 ------------------------------------
176
177 -- The bulk of exception traces output is centralized in Notify_Exception,
178 -- for both the Handled and Unhandled cases. Extra task specific output is
179 -- triggered in the task wrapper for unhandled occurrences in tasks. It is
180 -- not performed in this unit to avoid dependencies on the tasking units
181 -- here.
182
183 -- We used to rely on the output performed by Unhanded_Exception_Terminate
184 -- for the case of an unhandled occurrence in the environment thread, and
185 -- the task wrapper was responsible for the whole output in the tasking
186 -- case.
187
188 -- This initial scheme had a drawback: the output from Terminate only
189 -- occurs after finalization is done, which means possibly never if some
190 -- tasks keep hanging around.
191
192 -- The first "presumably obvious" fix consists in moving the Terminate
193 -- output before the finalization. It has not been retained because it
194 -- introduces annoying changes in output orders when the finalization
195 -- itself issues outputs, this also in "regular" cases not resorting to
196 -- Exception_Traces.
197
198 -- Today's solution has the advantage of simplicity and better isolates
199 -- the Exception_Traces machinery.
200
201 end Exception_Traces;