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-- 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 Ada.Unchecked_Conversion;
33with System;
34with System.Soft_Links;       use System.Soft_Links;
35with System.Standard_Library; use System.Standard_Library;
36with System.Exception_Table;  use System.Exception_Table;
37
38package 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
131end GNAT.Exception_Actions;
132