File : g-excact.adb
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-2011, 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 -- --
19 -- --
20 -- --
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 with Ada.Unchecked_Conversion;
33 with System;
34 with System.Soft_Links; use System.Soft_Links;
35 with System.Standard_Library; use System.Standard_Library;
36 with System.Exception_Table; use System.Exception_Table;
37
38 package body GNAT.Exception_Actions is
39
40 Global_Action : Exception_Action;
41 pragma Import (C, Global_Action, "__gnat_exception_actions_global_action");
42 -- Imported from Ada.Exceptions. Any change in the external name needs to
43 -- be coordinated with a-except.adb
44
45 Raise_Hook_Initialized : Boolean;
46 pragma Import
47 (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
48
49 function To_Raise_Action is new Ada.Unchecked_Conversion
50 (Exception_Action, Raise_Action);
51
52 -- ??? Would be nice to have this in System.Standard_Library
53 function To_Data is new Ada.Unchecked_Conversion
54 (Exception_Id, Exception_Data_Ptr);
55 function To_Id is new Ada.Unchecked_Conversion
56 (Exception_Data_Ptr, Exception_Id);
57
58 ----------------------------
59 -- Register_Global_Action --
60 ----------------------------
61
62 procedure Register_Global_Action (Action : Exception_Action) is
63 begin
64 Lock_Task.all;
65 Global_Action := Action;
66 Unlock_Task.all;
67 end Register_Global_Action;
68
69 ------------------------
70 -- Register_Id_Action --
71 ------------------------
72
73 procedure Register_Id_Action
74 (Id : Exception_Id;
75 Action : Exception_Action)
76 is
77 begin
78 if Id = Null_Id then
79 raise Program_Error;
80 end if;
81
82 Lock_Task.all;
83 To_Data (Id).Raise_Hook := To_Raise_Action (Action);
84 Raise_Hook_Initialized := True;
85 Unlock_Task.all;
86 end Register_Id_Action;
87
88 ---------------
89 -- Core_Dump --
90 ---------------
91
92 procedure Core_Dump (Occurrence : Exception_Occurrence) is separate;
93
94 ----------------
95 -- Name_To_Id --
96 ----------------
97
98 function Name_To_Id (Name : String) return Exception_Id is
99 begin
100 return To_Id (Internal_Exception (Name, Create_If_Not_Exist => False));
101 end Name_To_Id;
102
103 ---------------------------------
104 -- Registered_Exceptions_Count --
105 ---------------------------------
106
107 function Registered_Exceptions_Count return Natural renames
108 System.Exception_Table.Registered_Exceptions_Count;
109
110 -------------------------------
111 -- Get_Registered_Exceptions --
112 -------------------------------
113 -- This subprogram isn't an iterator to avoid concurrency problems,
114 -- since the exceptions are registered dynamically. Since we have to lock
115 -- the runtime while computing this array, this means that any callback in
116 -- an active iterator would be unable to access the runtime.
117
118 procedure Get_Registered_Exceptions
119 (List : out Exception_Id_Array;
120 Last : out Integer)
121 is
122 Ids : Exception_Data_Array (List'Range);
123 begin
124 Get_Registered_Exceptions (Ids, Last);
125
126 for L in List'First .. Last loop
127 List (L) := To_Id (Ids (L));
128 end loop;
129 end Get_Registered_Exceptions;
130
131 end GNAT.Exception_Actions;