1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . E X C E P T I O N _ A C T I O N S --
9 -- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada.Exceptions; use Ada.Exceptions;
35 with Ada.Unchecked_Conversion;
37 with System.Soft_Links; use System.Soft_Links;
38 with System.Standard_Library; use System.Standard_Library;
39 with System.Exception_Table; use System.Exception_Table;
41 package body GNAT.Exception_Actions is
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
48 Raise_Hook_Initialized : Boolean;
50 (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
52 function To_Raise_Action is new Ada.Unchecked_Conversion
53 (Exception_Action, Raise_Action);
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);
61 ----------------------------
62 -- Register_Global_Action --
63 ----------------------------
65 procedure Register_Global_Action (Action : Exception_Action) is
68 Global_Action := Action;
70 end Register_Global_Action;
72 ------------------------
73 -- Register_Id_Action --
74 ------------------------
76 procedure Register_Id_Action
78 Action : Exception_Action)
86 To_Data (Id).Raise_Hook := To_Raise_Action (Action);
87 Raise_Hook_Initialized := True;
89 end Register_Id_Action;
95 procedure Core_Dump (Occurrence : Exception_Occurrence) is separate;
101 function Name_To_Id (Name : String) return Exception_Id is
103 return To_Id (Internal_Exception (Name, False));
106 ---------------------------------
107 -- Registered_Exceptions_Count --
108 ---------------------------------
110 function Registered_Exceptions_Count return Natural renames
111 System.Exception_Table.Registered_Exceptions_Count;
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.
121 procedure Get_Registered_Exceptions
122 (List : out Exception_Id_Array;
125 Ids : Exception_Data_Array (List'Range);
127 Get_Registered_Exceptions (Ids, Last);
129 for L in List'First .. Last loop
130 List (L) := To_Id (Ids (L));
132 end Get_Registered_Exceptions;
134 end GNAT.Exception_Actions;