gcc/ada/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-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
  34 with Ada.Exceptions;       use Ada.Exceptions;
  35 with Ada.Unchecked_Conversion;
  36 with System;
  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;
  40
  41 package 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
 134 end GNAT.Exception_Actions;