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