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-2021, 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, which could rely on 33-- different underlying unwinding engines, for example DWARF or ARM unwind 34-- info based. Here is a sketch of the most prominent data structures 35-- involved: 36 37-- (s-excmac.ads) 38-- GNAT_GCC_Exception: 39-- *-----------------------------------* 40-- o-->| (s-excmac.ads) | 41-- | | Header : <gcc occurrence type> | 42-- | | - Class | 43-- | | ... | Constraint_Error: 44-- | |-----------------------------------* Program_Error: 45-- | | (a-except.ads) | Foreign_Exception: 46-- | | Occurrence : Exception_Occurrence | 47-- | | | (s-stalib. ads) 48-- | | - Id : Exception_Id --------------> Exception_Data 49-- o------ - Machine_Occurrence | *------------------------* 50-- | - Msg | | Not_Handled_By_Others | 51-- | - Traceback | | Lang | 52-- | ... | | Foreign_Data --o | 53-- *-----------------------------------* | Full_Name | | 54-- || | ... | | 55-- || foreign rtti blob *----------------|-------* 56-- || *---------------* | 57-- || | ... ... |<-------------------------o 58-- || *---------------* 59-- || 60-- Setup_Current_Excep() 61-- || 62-- || Latch into ATCB or 63-- || environment Current Exception Buffer: 64-- || 65-- vv 66-- <> : Exception_Occurrence 67-- *---------------------------* 68-- | ... ... ... ... ... ... * --- Get_Current_Excep() ----> 69-- *---------------------------* 70 71-- On "raise" events, the runtime allocates a new GNAT_GCC_Exception 72-- instance and eventually calls into libgcc's Unwind_RaiseException. 73-- This part handles the object through the header part only. 74 75-- During execution, Get_Current_Excep provides a pointer to the 76-- Exception_Occurrence being raised or last raised by the current task. 77 78-- This is actually the address of a statically allocated 79-- Exception_Occurrence attached to the current ATCB or to the environment 80-- thread into which an occurrence being raised is synchronized at critical 81-- points during the raise process, via Setup_Current_Excep. 82 83with Ada.Unchecked_Conversion; 84with Ada.Unchecked_Deallocation; 85 86with System.Storage_Elements; use System.Storage_Elements; 87with System.Exceptions.Machine; use System.Exceptions.Machine; 88 89separate (Ada.Exceptions) 90package body Exception_Propagation is 91 92 use Exception_Traces; 93 94 type bool is new Boolean; 95 pragma Convention (C, bool); 96 97 Foreign_Exception : aliased System.Standard_Library.Exception_Data; 98 pragma Import (Ada, Foreign_Exception, 99 "system__exceptions__foreign_exception"); 100 -- Id for foreign exceptions 101 102 -------------------------------------------------------------- 103 -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- 104 -------------------------------------------------------------- 105 106 -- Phase identifiers (Unwind Actions) 107 108 type Unwind_Action is new Integer; 109 pragma Convention (C, Unwind_Action); 110 111 UA_SEARCH_PHASE : constant Unwind_Action := 1; 112 UA_CLEANUP_PHASE : constant Unwind_Action := 2; 113 UA_HANDLER_FRAME : constant Unwind_Action := 4; 114 UA_FORCE_UNWIND : constant Unwind_Action := 8; 115 UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension 116 117 pragma Unreferenced 118 (UA_HANDLER_FRAME, 119 UA_FORCE_UNWIND, 120 UA_END_OF_STACK); 121 122 procedure GNAT_GCC_Exception_Cleanup 123 (Reason : Unwind_Reason_Code; 124 Excep : not null GNAT_GCC_Exception_Access); 125 pragma Convention (C, GNAT_GCC_Exception_Cleanup); 126 -- Procedure called when a GNAT GCC exception is free. 127 128 procedure Propagate_GCC_Exception 129 (GCC_Exception : not null GCC_Exception_Access); 130 pragma No_Return (Propagate_GCC_Exception); 131 -- Propagate a GCC exception 132 133 procedure Reraise_GCC_Exception 134 (GCC_Exception : not null GCC_Exception_Access); 135 pragma No_Return (Reraise_GCC_Exception); 136 pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); 137 -- Called to implement raise without exception, ie reraise. Called 138 -- directly from gigi. 139 140 function Setup_Current_Excep 141 (GCC_Exception : not null GCC_Exception_Access; 142 Phase : Unwind_Action) return EOA; 143 pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); 144 -- Acknowledge GCC_Exception as the current exception object being 145 -- raised, which could be an Ada or a foreign exception object. Return 146 -- a pointer to the embedded Ada occurrence for an Ada exception object, 147 -- to the current exception buffer otherwise. 148 -- 149 -- Synchronize the current exception buffer as needed for possible 150 -- accesses through Get_Current_Except.all afterwards, depending on the 151 -- Phase bits, received either from the personality routine, from a 152 -- forced_unwind cleanup handler, or just before the start of propagation 153 -- for an Ada exception (Phase 0 in this case). 154 155 procedure Unhandled_Except_Handler 156 (GCC_Exception : not null GCC_Exception_Access); 157 pragma No_Return (Unhandled_Except_Handler); 158 pragma Export (C, Unhandled_Except_Handler, 159 "__gnat_unhandled_except_handler"); 160 -- Called for handle unhandled exceptions, ie the last chance handler 161 -- on platforms (such as SEH) that never returns after throwing an 162 -- exception. Called directly by gigi. 163 164 function CleanupUnwind_Handler 165 (UW_Version : Integer; 166 UW_Phases : Unwind_Action; 167 UW_Eclass : Exception_Class; 168 UW_Exception : not null GCC_Exception_Access; 169 UW_Context : System.Address; 170 UW_Argument : System.Address) return Unwind_Reason_Code; 171 pragma Import (C, CleanupUnwind_Handler, 172 "__gnat_cleanupunwind_handler"); 173 -- Hook called at each step of the forced unwinding we perform to trigger 174 -- cleanups found during the propagation of an unhandled exception. 175 176 -- GCC runtime functions used. These are C non-void functions, actually, 177 -- but we ignore the return values. See raise.c as to why we are using 178 -- __gnat stubs for these. 179 180 procedure Unwind_RaiseException 181 (UW_Exception : not null GCC_Exception_Access); 182 pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); 183 184 procedure Unwind_ForcedUnwind 185 (UW_Exception : not null GCC_Exception_Access; 186 UW_Handler : System.Address; 187 UW_Argument : System.Address); 188 pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); 189 190 procedure Set_Exception_Parameter 191 (Excep : EOA; 192 GCC_Exception : not null GCC_Exception_Access); 193 pragma Export 194 (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); 195 -- Called inserted by gigi to set the exception choice parameter from the 196 -- gcc occurrence. 197 198 procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); 199 -- Utility routine to initialize occurrence Excep from a foreign exception 200 -- whose machine occurrence is Mo. The message is empty, the backtrace 201 -- is empty too and the exception identity is Foreign_Exception. 202 203 -- Hooks called when entering/leaving an exception handler for a 204 -- given occurrence. The calls are generated by gigi in 205 -- Exception_Handler_to_gnu_gcc. 206 207 -- Begin_Handler_v1, called when entering an exception handler, 208 -- claims responsibility for the handler to release the 209 -- GCC_Exception occurrence. End_Handler_v1, called when 210 -- leaving the handler, releases the occurrence, unless the 211 -- occurrence is propagating further up, or the handler is 212 -- dynamically nested in the context of another handler that 213 -- claimed responsibility for releasing that occurrence. 214 215 -- Responsibility is claimed by changing the Cleanup field to 216 -- Claimed_Cleanup, which enables claimed exceptions to be 217 -- recognized, and avoids accidental releases even by foreign 218 -- handlers. 219 220 function Begin_Handler_v1 221 (GCC_Exception : not null GCC_Exception_Access) 222 return System.Address; 223 pragma Export (C, Begin_Handler_v1, "__gnat_begin_handler_v1"); 224 -- Called when entering an exception handler. Claim 225 -- responsibility for releasing GCC_Exception, by setting the 226 -- cleanup/release function to Claimed_Cleanup, and return the 227 -- address of the previous cleanup/release function. 228 229 procedure End_Handler_v1 230 (GCC_Exception : not null GCC_Exception_Access; 231 Saved_Cleanup : System.Address; 232 Propagating_Exception : GCC_Exception_Access); 233 pragma Export (C, End_Handler_v1, "__gnat_end_handler_v1"); 234 -- Called when leaving an exception handler. Restore the 235 -- Saved_Cleanup in the GCC_Exception occurrence, and then release 236 -- it, unless it remains claimed by an enclosing handler, or 237 -- GCC_Exception and Propagating_Exception are the same 238 -- occurrence. Propagating_Exception could be either an 239 -- occurrence (re)raised within the handler of GCC_Exception, when 240 -- we're executing as an exceptional cleanup, or null, if we're 241 -- completing the handler of GCC_Exception normally. 242 243 procedure Claimed_Cleanup 244 (Reason : Unwind_Reason_Code; 245 GCC_Exception : not null GCC_Exception_Access); 246 pragma Export (C, Claimed_Cleanup, "__gnat_claimed_cleanup"); 247 -- A do-nothing placeholder installed as GCC_Exception.Cleanup 248 -- while handling GCC_Exception, to claim responsibility for 249 -- releasing it, and to stop it from being accidentally released. 250 251 -- The following are version 0 implementations of the version 1 252 -- hooks above. They remain in place for compatibility with the 253 -- output of compilers that still use version 0, such as those 254 -- used during bootstrap. They are interoperable with the v1 255 -- hooks, except that the older versions may malfunction when 256 -- handling foreign exceptions passed to Reraise_Occurrence. 257 258 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); 259 pragma Export (C, Begin_Handler, "__gnat_begin_handler"); 260 -- Called when entering an exception handler translated by an old 261 -- compiler. It does nothing. 262 263 procedure End_Handler (GCC_Exception : GCC_Exception_Access); 264 pragma Export (C, End_Handler, "__gnat_end_handler"); 265 -- Called when leaving an exception handler translated by an old 266 -- compiler. It releases GCC_Exception, unless it is null. It is 267 -- only ever null when the handler has a 'raise;' translated by a 268 -- v0-using compiler. The artificial handler variable passed to 269 -- End_Handler was set to null to tell End_Handler to refrain from 270 -- releasing the reraised exception. In v1 safer ways are used to 271 -- accomplish that. 272 273 -------------------------------------------------------------------- 274 -- Accessors to Basic Components of a GNAT Exception Data Pointer -- 275 -------------------------------------------------------------------- 276 277 -- As of today, these are only used by the C implementation of the GCC 278 -- propagation personality routine to avoid having to rely on a C 279 -- counterpart of the whole exception_data structure, which is both 280 -- painful and error prone. These subprograms could be moved to a more 281 -- widely visible location if need be. 282 283 function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool; 284 pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); 285 286 function Language_For (E : Exception_Data_Ptr) return Character; 287 pragma Export (C, Language_For, "__gnat_language_for"); 288 289 function Foreign_Data_For (E : Exception_Data_Ptr) return Address; 290 pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); 291 292 function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) 293 return Exception_Id; 294 pragma Export (C, EID_For, "__gnat_eid_for"); 295 296 --------------------------------------------------------------------------- 297 -- Objects to materialize "others" and "all others" in the GCC EH tables -- 298 --------------------------------------------------------------------------- 299 300 -- Currently, these only have their address taken and compared so there is 301 -- no real point having whole exception data blocks allocated. Note that 302 -- there are corresponding declarations in gigi (trans.c) which must be 303 -- kept properly synchronized. 304 305 Others_Value : constant Character := 'O'; 306 pragma Export (C, Others_Value, "__gnat_others_value"); 307 308 All_Others_Value : constant Character := 'A'; 309 pragma Export (C, All_Others_Value, "__gnat_all_others_value"); 310 311 Unhandled_Others_Value : constant Character := 'U'; 312 pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); 313 -- Special choice (emitted by gigi) to catch and notify unhandled 314 -- exceptions on targets which always handle exceptions (such as SEH). 315 -- The handler will simply call Unhandled_Except_Handler. 316 317 ------------------------- 318 -- Allocate_Occurrence -- 319 ------------------------- 320 321 function Allocate_Occurrence return EOA is 322 Res : GNAT_GCC_Exception_Access; 323 324 begin 325 Res := New_Occurrence; 326 Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address; 327 Res.Occurrence.Machine_Occurrence := Res.all'Address; 328 329 return Res.Occurrence'Access; 330 end Allocate_Occurrence; 331 332 -------------------------------- 333 -- GNAT_GCC_Exception_Cleanup -- 334 -------------------------------- 335 336 procedure GNAT_GCC_Exception_Cleanup 337 (Reason : Unwind_Reason_Code; 338 Excep : not null GNAT_GCC_Exception_Access) 339 is 340 pragma Unreferenced (Reason); 341 342 procedure Free is new Unchecked_Deallocation 343 (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); 344 345 Copy : GNAT_GCC_Exception_Access := Excep; 346 347 begin 348 -- Simply free the memory 349 350 Free (Copy); 351 end GNAT_GCC_Exception_Cleanup; 352 353 ---------------------------- 354 -- Set_Foreign_Occurrence -- 355 ---------------------------- 356 357 procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is 358 begin 359 Excep.all := ( 360 Id => Foreign_Exception'Access, 361 Machine_Occurrence => Mo, 362 Msg => <>, 363 Msg_Length => 0, 364 Exception_Raised => True, 365 Pid => Local_Partition_ID, 366 Num_Tracebacks => 0, 367 Tracebacks => <>); 368 end Set_Foreign_Occurrence; 369 370 ------------------------- 371 -- Setup_Current_Excep -- 372 ------------------------- 373 374 function Setup_Current_Excep 375 (GCC_Exception : not null GCC_Exception_Access; 376 Phase : Unwind_Action) return EOA 377 is 378 Excep : constant EOA := Get_Current_Excep.all; 379 380 begin 381 382 if GCC_Exception.Class = GNAT_Exception_Class then 383 384 -- Ada exception : latch the occurrence data in the Current 385 -- Exception Buffer if needed and return a pointer to the original 386 -- Ada exception object. This particular object was specifically 387 -- allocated for this raise and is thus more precise than the fixed 388 -- Current Exception Buffer address. 389 390 declare 391 GNAT_Occurrence : constant GNAT_GCC_Exception_Access := 392 To_GNAT_GCC_Exception (GCC_Exception); 393 begin 394 395 -- When reaching here during SEARCH_PHASE, no need to 396 -- replicate the copy performed at the propagation start. 397 398 if Phase /= UA_SEARCH_PHASE then 399 Excep.all := GNAT_Occurrence.Occurrence; 400 end if; 401 return GNAT_Occurrence.Occurrence'Access; 402 end; 403 404 else 405 406 -- Foreign exception (caught by Ada handler, reaching here from 407 -- personality routine) : The original exception object doesn't hold 408 -- an Ada occurrence info. Set the foreign data pointer in the 409 -- Current Exception Buffer and return the address of the latter. 410 411 Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); 412 413 return Excep; 414 end if; 415 end Setup_Current_Excep; 416 417 ---------------------- 418 -- Begin_Handler_v1 -- 419 ---------------------- 420 421 function Begin_Handler_v1 422 (GCC_Exception : not null GCC_Exception_Access) 423 return System.Address is 424 Saved_Cleanup : constant System.Address := GCC_Exception.Cleanup; 425 begin 426 -- Claim responsibility for releasing this exception, and stop 427 -- others from releasing it. 428 GCC_Exception.Cleanup := Claimed_Cleanup'Address; 429 return Saved_Cleanup; 430 end Begin_Handler_v1; 431 432 -------------------- 433 -- End_Handler_v1 -- 434 -------------------- 435 436 procedure End_Handler_v1 437 (GCC_Exception : not null GCC_Exception_Access; 438 Saved_Cleanup : System.Address; 439 Propagating_Exception : GCC_Exception_Access) is 440 begin 441 GCC_Exception.Cleanup := Saved_Cleanup; 442 -- Restore the Saved_Cleanup, so that it is either used to 443 -- release GCC_Exception below, or transferred to the next 444 -- handler of the Propagating_Exception occurrence. The 445 -- following test ensures that an occurrence is only released 446 -- once, even after reraises. 447 -- 448 -- The idea is that the GCC_Exception is not to be released 449 -- unless it had an unclaimed Cleanup when the handler started 450 -- (see Begin_Handler_v1 above), but if we propagate across its 451 -- handler a reraise of the same exception, we transfer to the 452 -- Propagating_Exception the responsibility for running the 453 -- Saved_Cleanup when its handler completes. 454 -- 455 -- This ownership transfer mechanism ensures safety, as in 456 -- single release and no dangling pointers, because there is no 457 -- way to hold on to the Machine_Occurrence of an 458 -- Exception_Occurrence: the only situations in which another 459 -- Exception_Occurrence gets the same Machine_Occurrence are 460 -- through Reraise_Occurrence, and plain reraise, and so we 461 -- have the following possibilities: 462 -- 463 -- - Reraise_Occurrence is handled within the running handler, 464 -- and so when completing the dynamically nested handler, we 465 -- must NOT release the exception. A Claimed_Cleanup upon 466 -- entry of the nested handler, installed when entering the 467 -- enclosing handler, ensures the exception will not be 468 -- released by the nested handler, but rather by the enclosing 469 -- handler. 470 -- 471 -- - Reraise_Occurrence/reraise escapes the running handler, 472 -- and we run as an exceptional cleanup for GCC_Exception. The 473 -- Saved_Cleanup was reinstalled, but since we're propagating 474 -- the same machine occurrence, we do not release it. Instead, 475 -- we transfer responsibility for releasing it to the eventual 476 -- handler of the propagating exception. 477 -- 478 -- - An unrelated exception propagates through the running 479 -- handler. We restored GCC_Exception.Saved_Cleanup above. 480 -- Since we're propagating a different exception, we proceed to 481 -- release GCC_Exception, unless Saved_Cleanup was 482 -- Claimed_Cleanup, because then we know we're not in the 483 -- outermost handler for GCC_Exception. 484 -- 485 -- - The handler completes normally, so it reinstalls the 486 -- Saved_Cleanup and runs it, unless it was Claimed_Cleanup. 487 -- If Saved_Cleanup is null, Unwind_DeleteException (currently) 488 -- has no effect, so we could skip it, but if it is ever 489 -- changed to do more in this case, we're ready for that, 490 -- calling it exactly once. 491 if Saved_Cleanup /= Claimed_Cleanup'Address 492 and then 493 Propagating_Exception /= GCC_Exception 494 then 495 declare 496 Current : constant EOA := Get_Current_Excep.all; 497 Cur_Occ : constant GCC_Exception_Access 498 := To_GCC_Exception (Current.Machine_Occurrence); 499 begin 500 -- If we are releasing the Machine_Occurrence of the current 501 -- exception, reset the access to it, so that it is no 502 -- longer accessible. 503 if Cur_Occ = GCC_Exception then 504 Current.Machine_Occurrence := System.Null_Address; 505 end if; 506 end; 507 Unwind_DeleteException (GCC_Exception); 508 end if; 509 end End_Handler_v1; 510 511 --------------------- 512 -- Claimed_Cleanup -- 513 --------------------- 514 515 procedure Claimed_Cleanup 516 (Reason : Unwind_Reason_Code; 517 GCC_Exception : not null GCC_Exception_Access) is 518 pragma Unreferenced (Reason); 519 pragma Unreferenced (GCC_Exception); 520 begin 521 -- This procedure should never run. If it does, it's either a 522 -- version 0 handler or a foreign handler, attempting to 523 -- release an exception while a version 1 handler that claimed 524 -- responsibility for releasing the exception remains still 525 -- active. This placeholder stops GCC_Exception from being 526 -- released by them. 527 528 -- We could get away with just Null_Address instead, with 529 -- nearly the same effect, but with this placeholder we can 530 -- detect and report unexpected releases, and we can tell apart 531 -- a GCC_Exception without a Cleanup, from one with another 532 -- active handler, so as to still call Unwind_DeleteException 533 -- exactly once: currently, Unwind_DeleteException does nothing 534 -- when the Cleanup is null, but should it ever be changed to 535 -- do more, we'll still be safe. 536 null; 537 end Claimed_Cleanup; 538 539 ------------------- 540 -- Begin_Handler -- 541 ------------------- 542 543 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is 544 pragma Unreferenced (GCC_Exception); 545 begin 546 null; 547 end Begin_Handler; 548 549 ----------------- 550 -- End_Handler -- 551 ----------------- 552 553 procedure End_Handler (GCC_Exception : GCC_Exception_Access) is 554 begin 555 if GCC_Exception /= null then 556 557 -- The exception might have been reraised, in this case the cleanup 558 -- mustn't be called. 559 560 Unwind_DeleteException (GCC_Exception); 561 end if; 562 end End_Handler; 563 564 ----------------------------- 565 -- Reraise_GCC_Exception -- 566 ----------------------------- 567 568 procedure Reraise_GCC_Exception 569 (GCC_Exception : not null GCC_Exception_Access) 570 is 571 begin 572 -- Simply propagate it 573 574 Propagate_GCC_Exception (GCC_Exception); 575 end Reraise_GCC_Exception; 576 577 ----------------------------- 578 -- Propagate_GCC_Exception -- 579 ----------------------------- 580 581 -- Call Unwind_RaiseException to actually throw, taking care of handling 582 -- the two phase scheme it implements. 583 584 procedure Propagate_GCC_Exception 585 (GCC_Exception : not null GCC_Exception_Access) 586 is 587 -- Acknowledge the current exception info now, before unwinding 588 -- starts so it is available even from C++ handlers involved before 589 -- our personality routine. 590 591 Excep : constant EOA := 592 Setup_Current_Excep (GCC_Exception, Phase => 0); 593 594 begin 595 -- Perform a standard raise first. If a regular handler is found, it 596 -- will be entered after all the intermediate cleanups have run. If 597 -- there is no regular handler, it will return. 598 599 Unwind_RaiseException (GCC_Exception); 600 601 -- If we get here we know the exception is not handled, as otherwise 602 -- Unwind_RaiseException arranges for the handler to be entered. Take 603 -- the necessary steps to enable the debugger to gain control while the 604 -- stack is still intact. 605 606 Notify_Unhandled_Exception (Excep); 607 608 -- Now, un a forced unwind to trigger cleanups. Control should not 609 -- resume there, if there are cleanups and in any cases as the 610 -- unwinding hook calls Unhandled_Exception_Terminate when end of 611 -- stack is reached. 612 613 Unwind_ForcedUnwind 614 (GCC_Exception, 615 CleanupUnwind_Handler'Address, 616 System.Null_Address); 617 618 -- We get here in case of error. The debugger has been notified before 619 -- the second step above. 620 621 Unhandled_Except_Handler (GCC_Exception); 622 end Propagate_GCC_Exception; 623 624 ------------------------- 625 -- Propagate_Exception -- 626 ------------------------- 627 628 procedure Propagate_Exception (Excep : Exception_Occurrence) is 629 begin 630 Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); 631 end Propagate_Exception; 632 633 ----------------------------- 634 -- Set_Exception_Parameter -- 635 ----------------------------- 636 637 procedure Set_Exception_Parameter 638 (Excep : EOA; 639 GCC_Exception : not null GCC_Exception_Access) 640 is 641 begin 642 -- Setup the exception occurrence 643 644 if GCC_Exception.Class = GNAT_Exception_Class then 645 646 -- From the GCC exception 647 648 declare 649 GNAT_Occurrence : constant GNAT_GCC_Exception_Access := 650 To_GNAT_GCC_Exception (GCC_Exception); 651 begin 652 Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); 653 end; 654 655 else 656 -- A default one 657 658 Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); 659 end if; 660 end Set_Exception_Parameter; 661 662 ------------------------------ 663 -- Unhandled_Except_Handler -- 664 ------------------------------ 665 666 procedure Unhandled_Except_Handler 667 (GCC_Exception : not null GCC_Exception_Access) 668 is 669 Excep : EOA; 670 begin 671 Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE); 672 Unhandled_Exception_Terminate (Excep); 673 end Unhandled_Except_Handler; 674 675 ------------- 676 -- EID_For -- 677 ------------- 678 679 function EID_For 680 (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id 681 is 682 begin 683 return GNAT_Exception.Occurrence.Id; 684 end EID_For; 685 686 ---------------------- 687 -- Foreign_Data_For -- 688 ---------------------- 689 690 function Foreign_Data_For (E : Exception_Data_Ptr) return Address is 691 begin 692 return E.Foreign_Data; 693 end Foreign_Data_For; 694 695 -------------------------- 696 -- Is_Handled_By_Others -- 697 -------------------------- 698 699 function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool is 700 begin 701 return not bool (E.all.Not_Handled_By_Others); 702 end Is_Handled_By_Others; 703 704 ------------------ 705 -- Language_For -- 706 ------------------ 707 708 function Language_For (E : Exception_Data_Ptr) return Character is 709 begin 710 return E.all.Lang; 711 end Language_For; 712 713end Exception_Propagation; 714