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-2012, 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 default version, using the __builtin_setjmp/longjmp EH 33-- mechanism. 34 35with Ada.Unchecked_Conversion; 36 37separate (Ada.Exceptions) 38package body Exception_Propagation is 39 40 -- Common binding to __builtin_longjmp for sjlj variants. 41 42 procedure builtin_longjmp (buffer : System.Address; Flag : Integer); 43 pragma No_Return (builtin_longjmp); 44 pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp"); 45 46 procedure Propagate_Continue (E : Exception_Id); 47 pragma No_Return (Propagate_Continue); 48 pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg"); 49 -- A call to this procedure is inserted automatically by GIGI, in order 50 -- to continue the propagation when the exception was not handled. 51 -- The linkage name is historical. 52 53 ------------------------- 54 -- Allocate_Occurrence -- 55 ------------------------- 56 57 function Allocate_Occurrence return EOA is 58 begin 59 return Get_Current_Excep.all; 60 end Allocate_Occurrence; 61 62 ------------------------- 63 -- Propagate_Exception -- 64 ------------------------- 65 66 procedure Propagate_Exception (Excep : EOA) is 67 Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; 68 69 begin 70 -- If the jump buffer pointer is non-null, transfer control using 71 -- it. Otherwise announce an unhandled exception (note that this 72 -- means that we have no finalizations to do other than at the outer 73 -- level). Perform the necessary notification tasks in both cases. 74 75 if Jumpbuf_Ptr /= Null_Address then 76 if not Excep.Exception_Raised then 77 Excep.Exception_Raised := True; 78 Exception_Traces.Notify_Handled_Exception (Excep); 79 end if; 80 81 builtin_longjmp (Jumpbuf_Ptr, 1); 82 83 else 84 Exception_Traces.Notify_Unhandled_Exception (Excep); 85 Exception_Traces.Unhandled_Exception_Terminate (Excep); 86 end if; 87 end Propagate_Exception; 88 89 ------------------------ 90 -- Propagate_Continue -- 91 ------------------------ 92 93 procedure Propagate_Continue (E : Exception_Id) is 94 pragma Unreferenced (E); 95 begin 96 Propagate_Exception (Get_Current_Excep.all); 97 end Propagate_Continue; 98 99end Exception_Propagation; 100