1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . E X C E P T I O N _ A C T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2003 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with Ada.Exceptions; use Ada.Exceptions; 35with Ada.Unchecked_Conversion; 36with System; 37with System.Soft_Links; use System.Soft_Links; 38with System.Standard_Library; use System.Standard_Library; 39with System.Exception_Table; use System.Exception_Table; 40 41package body GNAT.Exception_Actions is 42 43 Global_Action : Exception_Action; 44 pragma Import (C, Global_Action, "__gnat_exception_actions_global_action"); 45 -- Imported from Ada.Exceptions. Any change in the external name needs to 46 -- be coordinated with a-except.adb 47 48 Raise_Hook_Initialized : Boolean; 49 pragma Import 50 (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); 51 52 function To_Raise_Action is new Ada.Unchecked_Conversion 53 (Exception_Action, Raise_Action); 54 55 -- ??? Would be nice to have this in System.Standard_Library 56 function To_Data is new Ada.Unchecked_Conversion 57 (Exception_Id, Exception_Data_Ptr); 58 function To_Id is new Ada.Unchecked_Conversion 59 (Exception_Data_Ptr, Exception_Id); 60 61 ---------------------------- 62 -- Register_Global_Action -- 63 ---------------------------- 64 65 procedure Register_Global_Action (Action : Exception_Action) is 66 begin 67 Lock_Task.all; 68 Global_Action := Action; 69 Unlock_Task.all; 70 end Register_Global_Action; 71 72 ------------------------ 73 -- Register_Id_Action -- 74 ------------------------ 75 76 procedure Register_Id_Action 77 (Id : Exception_Id; 78 Action : Exception_Action) 79 is 80 begin 81 if Id = Null_Id then 82 raise Program_Error; 83 end if; 84 85 Lock_Task.all; 86 To_Data (Id).Raise_Hook := To_Raise_Action (Action); 87 Raise_Hook_Initialized := True; 88 Unlock_Task.all; 89 end Register_Id_Action; 90 91 --------------- 92 -- Core_Dump -- 93 --------------- 94 95 procedure Core_Dump (Occurrence : Exception_Occurrence) is separate; 96 97 ---------------- 98 -- Name_To_Id -- 99 ---------------- 100 101 function Name_To_Id (Name : String) return Exception_Id is 102 begin 103 return To_Id (Internal_Exception (Name, False)); 104 end Name_To_Id; 105 106 --------------------------------- 107 -- Registered_Exceptions_Count -- 108 --------------------------------- 109 110 function Registered_Exceptions_Count return Natural renames 111 System.Exception_Table.Registered_Exceptions_Count; 112 113 ------------------------------- 114 -- Get_Registered_Exceptions -- 115 ------------------------------- 116 -- This subprogram isn't an iterator to avoid concurrency problems, 117 -- since the exceptions are registered dynamically. Since we have to lock 118 -- the runtime while computing this array, this means that any callback in 119 -- an active iterator would be unable to access the runtime. 120 121 procedure Get_Registered_Exceptions 122 (List : out Exception_Id_Array; 123 Last : out Integer) 124 is 125 Ids : Exception_Data_Array (List'Range); 126 begin 127 Get_Registered_Exceptions (Ids, Last); 128 129 for L in List'First .. Last loop 130 List (L) := To_Id (Ids (L)); 131 end loop; 132 end Get_Registered_Exceptions; 133 134end GNAT.Exception_Actions; 135