Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-exexpr.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 -- A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N --
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 -- This is the version using the GCC EH mechanism
33
34 with Ada.Unchecked_Conversion;
35 with Ada.Unchecked_Deallocation;
36
37 with System.Storage_Elements; use System.Storage_Elements;
38 with System.Exceptions.Machine; use System.Exceptions.Machine;
39
40 separate (Ada.Exceptions)
41 package body Exception_Propagation is
42
43 use Exception_Traces;
44
45 Foreign_Exception : aliased System.Standard_Library.Exception_Data;
46 pragma Import (Ada, Foreign_Exception,
47 "system__exceptions__foreign_exception");
48 -- Id for foreign exceptions
49
50 --------------------------------------------------------------
51 -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
52 --------------------------------------------------------------
53
54 procedure GNAT_GCC_Exception_Cleanup
55 (Reason : Unwind_Reason_Code;
56 Excep : not null GNAT_GCC_Exception_Access);
57 pragma Convention (C, GNAT_GCC_Exception_Cleanup);
58 -- Procedure called when a GNAT GCC exception is free.
59
60 procedure Propagate_GCC_Exception
61 (GCC_Exception : not null GCC_Exception_Access);
62 pragma No_Return (Propagate_GCC_Exception);
63 -- Propagate a GCC exception
64
65 procedure Reraise_GCC_Exception
66 (GCC_Exception : not null GCC_Exception_Access);
67 pragma No_Return (Reraise_GCC_Exception);
68 pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
69 -- Called to implement raise without exception, ie reraise. Called
70 -- directly from gigi.
71
72 function Setup_Current_Excep
73 (GCC_Exception : not null GCC_Exception_Access) return EOA;
74 pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
75 -- Write Get_Current_Excep.all from GCC_Exception. Called by the
76 -- personality routine.
77
78 procedure Unhandled_Except_Handler
79 (GCC_Exception : not null GCC_Exception_Access);
80 pragma No_Return (Unhandled_Except_Handler);
81 pragma Export (C, Unhandled_Except_Handler,
82 "__gnat_unhandled_except_handler");
83 -- Called for handle unhandled exceptions, ie the last chance handler
84 -- on platforms (such as SEH) that never returns after throwing an
85 -- exception. Called directly by gigi.
86
87 function CleanupUnwind_Handler
88 (UW_Version : Integer;
89 UW_Phases : Unwind_Action;
90 UW_Eclass : Exception_Class;
91 UW_Exception : not null GCC_Exception_Access;
92 UW_Context : System.Address;
93 UW_Argument : System.Address) return Unwind_Reason_Code;
94 pragma Import (C, CleanupUnwind_Handler,
95 "__gnat_cleanupunwind_handler");
96 -- Hook called at each step of the forced unwinding we perform to trigger
97 -- cleanups found during the propagation of an unhandled exception.
98
99 -- GCC runtime functions used. These are C non-void functions, actually,
100 -- but we ignore the return values. See raise.c as to why we are using
101 -- __gnat stubs for these.
102
103 procedure Unwind_RaiseException
104 (UW_Exception : not null GCC_Exception_Access);
105 pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
106
107 procedure Unwind_ForcedUnwind
108 (UW_Exception : not null GCC_Exception_Access;
109 UW_Handler : System.Address;
110 UW_Argument : System.Address);
111 pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
112
113 procedure Set_Exception_Parameter
114 (Excep : EOA;
115 GCC_Exception : not null GCC_Exception_Access);
116 pragma Export
117 (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
118 -- Called inserted by gigi to set the exception choice parameter from the
119 -- gcc occurrence.
120
121 procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
122 -- Utility routine to initialize occurrence Excep from a foreign exception
123 -- whose machine occurrence is Mo. The message is empty, the backtrace
124 -- is empty too and the exception identity is Foreign_Exception.
125
126 -- Hooks called when entering/leaving an exception handler for a given
127 -- occurrence, aimed at handling the stack of active occurrences. The
128 -- calls are generated by gigi in tree_transform/N_Exception_Handler.
129
130 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
131 pragma Export (C, Begin_Handler, "__gnat_begin_handler");
132
133 procedure End_Handler (GCC_Exception : GCC_Exception_Access);
134 pragma Export (C, End_Handler, "__gnat_end_handler");
135
136 --------------------------------------------------------------------
137 -- Accessors to Basic Components of a GNAT Exception Data Pointer --
138 --------------------------------------------------------------------
139
140 -- As of today, these are only used by the C implementation of the GCC
141 -- propagation personality routine to avoid having to rely on a C
142 -- counterpart of the whole exception_data structure, which is both
143 -- painful and error prone. These subprograms could be moved to a more
144 -- widely visible location if need be.
145
146 function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
147 pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
148 pragma Warnings (Off, Is_Handled_By_Others);
149
150 function Language_For (E : Exception_Data_Ptr) return Character;
151 pragma Export (C, Language_For, "__gnat_language_for");
152
153 function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
154 pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
155
156 function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
157 return Exception_Id;
158 pragma Export (C, EID_For, "__gnat_eid_for");
159
160 ---------------------------------------------------------------------------
161 -- Objects to materialize "others" and "all others" in the GCC EH tables --
162 ---------------------------------------------------------------------------
163
164 -- Currently, these only have their address taken and compared so there is
165 -- no real point having whole exception data blocks allocated. Note that
166 -- there are corresponding declarations in gigi (trans.c) which must be
167 -- kept properly synchronized.
168
169 Others_Value : constant Character := 'O';
170 pragma Export (C, Others_Value, "__gnat_others_value");
171
172 All_Others_Value : constant Character := 'A';
173 pragma Export (C, All_Others_Value, "__gnat_all_others_value");
174
175 Unhandled_Others_Value : constant Character := 'U';
176 pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
177 -- Special choice (emitted by gigi) to catch and notify unhandled
178 -- exceptions on targets which always handle exceptions (such as SEH).
179 -- The handler will simply call Unhandled_Except_Handler.
180
181 -------------------------
182 -- Allocate_Occurrence --
183 -------------------------
184
185 function Allocate_Occurrence return EOA is
186 Res : GNAT_GCC_Exception_Access;
187
188 begin
189 Res := New_Occurrence;
190 Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
191 Res.Occurrence.Machine_Occurrence := Res.all'Address;
192
193 return Res.Occurrence'Access;
194 end Allocate_Occurrence;
195
196 --------------------------------
197 -- GNAT_GCC_Exception_Cleanup --
198 --------------------------------
199
200 procedure GNAT_GCC_Exception_Cleanup
201 (Reason : Unwind_Reason_Code;
202 Excep : not null GNAT_GCC_Exception_Access)
203 is
204 pragma Unreferenced (Reason);
205
206 procedure Free is new Unchecked_Deallocation
207 (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
208
209 Copy : GNAT_GCC_Exception_Access := Excep;
210
211 begin
212 -- Simply free the memory
213
214 Free (Copy);
215 end GNAT_GCC_Exception_Cleanup;
216
217 ----------------------------
218 -- Set_Foreign_Occurrence --
219 ----------------------------
220
221 procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
222 begin
223 Excep.all := (
224 Id => Foreign_Exception'Access,
225 Machine_Occurrence => Mo,
226 Msg => <>,
227 Msg_Length => 0,
228 Exception_Raised => True,
229 Pid => Local_Partition_ID,
230 Num_Tracebacks => 0,
231 Tracebacks => <>);
232 end Set_Foreign_Occurrence;
233
234 -------------------------
235 -- Setup_Current_Excep --
236 -------------------------
237
238 function Setup_Current_Excep
239 (GCC_Exception : not null GCC_Exception_Access) return EOA
240 is
241 Excep : constant EOA := Get_Current_Excep.all;
242
243 begin
244 -- Setup the exception occurrence
245
246 if GCC_Exception.Class = GNAT_Exception_Class then
247
248 -- From the GCC exception
249
250 declare
251 GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
252 To_GNAT_GCC_Exception (GCC_Exception);
253 begin
254 Excep.all := GNAT_Occurrence.Occurrence;
255 return GNAT_Occurrence.Occurrence'Access;
256 end;
257
258 else
259 -- A default one
260
261 Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
262
263 return Excep;
264 end if;
265 end Setup_Current_Excep;
266
267 -------------------
268 -- Begin_Handler --
269 -------------------
270
271 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
272 pragma Unreferenced (GCC_Exception);
273 begin
274 null;
275 end Begin_Handler;
276
277 -----------------
278 -- End_Handler --
279 -----------------
280
281 procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
282 begin
283 if GCC_Exception /= null then
284
285 -- The exception might have been reraised, in this case the cleanup
286 -- mustn't be called.
287
288 Unwind_DeleteException (GCC_Exception);
289 end if;
290 end End_Handler;
291
292 -----------------------------
293 -- Reraise_GCC_Exception --
294 -----------------------------
295
296 procedure Reraise_GCC_Exception
297 (GCC_Exception : not null GCC_Exception_Access)
298 is
299 begin
300 -- Simply propagate it
301
302 Propagate_GCC_Exception (GCC_Exception);
303 end Reraise_GCC_Exception;
304
305 -----------------------------
306 -- Propagate_GCC_Exception --
307 -----------------------------
308
309 -- Call Unwind_RaiseException to actually throw, taking care of handling
310 -- the two phase scheme it implements.
311
312 procedure Propagate_GCC_Exception
313 (GCC_Exception : not null GCC_Exception_Access)
314 is
315 Excep : EOA;
316
317 begin
318 -- Perform a standard raise first. If a regular handler is found, it
319 -- will be entered after all the intermediate cleanups have run. If
320 -- there is no regular handler, it will return.
321
322 Unwind_RaiseException (GCC_Exception);
323
324 -- If we get here we know the exception is not handled, as otherwise
325 -- Unwind_RaiseException arranges for the handler to be entered. Take
326 -- the necessary steps to enable the debugger to gain control while the
327 -- stack is still intact.
328
329 Excep := Setup_Current_Excep (GCC_Exception);
330 Notify_Unhandled_Exception (Excep);
331
332 -- Now, un a forced unwind to trigger cleanups. Control should not
333 -- resume there, if there are cleanups and in any cases as the
334 -- unwinding hook calls Unhandled_Exception_Terminate when end of
335 -- stack is reached.
336
337 Unwind_ForcedUnwind
338 (GCC_Exception,
339 CleanupUnwind_Handler'Address,
340 System.Null_Address);
341
342 -- We get here in case of error. The debugger has been notified before
343 -- the second step above.
344
345 Unhandled_Except_Handler (GCC_Exception);
346 end Propagate_GCC_Exception;
347
348 -------------------------
349 -- Propagate_Exception --
350 -------------------------
351
352 procedure Propagate_Exception (Excep : EOA) is
353 begin
354 Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
355 end Propagate_Exception;
356
357 -----------------------------
358 -- Set_Exception_Parameter --
359 -----------------------------
360
361 procedure Set_Exception_Parameter
362 (Excep : EOA;
363 GCC_Exception : not null GCC_Exception_Access)
364 is
365 begin
366 -- Setup the exception occurrence
367
368 if GCC_Exception.Class = GNAT_Exception_Class then
369
370 -- From the GCC exception
371
372 declare
373 GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
374 To_GNAT_GCC_Exception (GCC_Exception);
375 begin
376 Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
377 end;
378
379 else
380 -- A default one
381
382 Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
383 end if;
384 end Set_Exception_Parameter;
385
386 ------------------------------
387 -- Unhandled_Except_Handler --
388 ------------------------------
389
390 procedure Unhandled_Except_Handler
391 (GCC_Exception : not null GCC_Exception_Access)
392 is
393 Excep : EOA;
394 begin
395 Excep := Setup_Current_Excep (GCC_Exception);
396 Unhandled_Exception_Terminate (Excep);
397 end Unhandled_Except_Handler;
398
399 -------------
400 -- EID_For --
401 -------------
402
403 function EID_For
404 (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
405 is
406 begin
407 return GNAT_Exception.Occurrence.Id;
408 end EID_For;
409
410 ----------------------
411 -- Foreign_Data_For --
412 ----------------------
413
414 function Foreign_Data_For
415 (E : SSL.Exception_Data_Ptr) return Address
416 is
417 begin
418 return E.Foreign_Data;
419 end Foreign_Data_For;
420
421 --------------------------
422 -- Is_Handled_By_Others --
423 --------------------------
424
425 function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
426 begin
427 return not E.all.Not_Handled_By_Others;
428 end Is_Handled_By_Others;
429
430 ------------------
431 -- Language_For --
432 ------------------
433
434 function Language_For (E : SSL.Exception_Data_Ptr) return Character is
435 begin
436 return E.all.Lang;
437 end Language_For;
438
439 end Exception_Propagation;