1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . C P P _ E X C E P T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2013-2018, 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------------------------------------------------------------------------------ 31 32with System; 33with System.Storage_Elements; 34with Interfaces.C; use Interfaces.C; 35with Ada.Unchecked_Conversion; 36with System.Standard_Library; use System.Standard_Library; 37 38package body GNAT.CPP_Exceptions is 39 40 -- Note: all functions prefixed by __cxa are part of the c++ ABI for 41 -- exception handling. As they are provided by the c++ library, there 42 -- must be no dependencies on it in the compiled code of this unit, but 43 -- there can be dependencies in instances. This is required to be able 44 -- to build the shared library without the c++ library. 45 46 function To_Exception_Data_Ptr is new 47 Ada.Unchecked_Conversion 48 (Exception_Id, Exception_Data_Ptr); 49 -- Convert an Exception_Id to its non-private type. This is used to get 50 -- the RTTI of a C++ exception 51 52 function Get_Exception_Machine_Occurrence 53 (X : Exception_Occurrence) return System.Address; 54 pragma Import (Ada, Get_Exception_Machine_Occurrence, 55 "__gnat_get_exception_machine_occurrence"); 56 -- Imported function (from Ada.Exceptions) that returns the machine 57 -- occurrence from an exception occurrence. 58 59 ------------------------- 60 -- Raise_Cpp_Exception -- 61 ------------------------- 62 63 procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T) 64 is 65 Id_Data : constant Exception_Data_Ptr := To_Exception_Data_Ptr (Id); 66 -- Get a non-private view on the exception 67 68 type T_Acc is access all T; 69 pragma Convention (C, T_Acc); 70 -- Access type to the object compatible with C 71 72 Occ : T_Acc; 73 -- The occurrence to propagate 74 75 function cxa_allocate_exception (Size : size_t) return T_Acc; 76 pragma Import (C, cxa_allocate_exception, "__cxa_allocate_exception"); 77 -- The C++ function to allocate an occurrence 78 79 procedure cxa_throw (Obj : T_Acc; Tinfo : System.Address; 80 Dest : System.Address); 81 pragma Import (C, cxa_throw, "__cxa_throw"); 82 pragma No_Return (cxa_throw); 83 -- The C++ function to raise an exception 84 begin 85 -- Check the exception was imported from C++ 86 87 if Id_Data.Lang /= 'C' then 88 raise Constraint_Error; 89 end if; 90 91 -- Allocate the C++ occurrence 92 93 Occ := cxa_allocate_exception (T'Size / System.Storage_Unit); 94 95 -- Set the object 96 97 Occ.all := Value; 98 99 -- Throw the exception 100 101 cxa_throw (Occ, Id_Data.Foreign_Data, System.Null_Address); 102 end Raise_Cpp_Exception; 103 104 ---------------- 105 -- Get_Object -- 106 ---------------- 107 108 function Get_Object (X : Exception_Occurrence) return T 109 is 110 use System; 111 use System.Storage_Elements; 112 113 Unwind_Exception_Size : Natural; 114 pragma Import (C, Unwind_Exception_Size, "__gnat_unwind_exception_size"); 115 -- Size in bytes of _Unwind_Exception 116 117 Exception_Addr : constant Address := 118 Get_Exception_Machine_Occurrence (X); 119 -- Machine occurrence of X 120 121 begin 122 -- Check the machine occurrence exists 123 124 if Exception_Addr = Null_Address then 125 raise Constraint_Error; 126 end if; 127 128 declare 129 -- Import the object from the occurrence 130 Result : T; 131 pragma Import (Ada, Result); 132 for Result'Address use 133 Exception_Addr + Storage_Offset (Unwind_Exception_Size); 134 begin 135 -- And return it 136 return Result; 137 end; 138 end Get_Object; 139end GNAT.CPP_Exceptions; 140