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