gcc/ada/s-exctab.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --               S Y S T E M . E X C E P T I O N _ T A B L E                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1996-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 System.HTable;
  35 with System.Soft_Links;   use System.Soft_Links;
  36
  37 package body System.Exception_Table is
  38
  39    use System.Standard_Library;
  40
  41    type HTable_Headers is range 1 .. 37;
  42
  43    procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
  44    function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
  45
  46    function Hash (F : System.Address) return HTable_Headers;
  47    function Equal (A, B : System.Address) return Boolean;
  48    function Get_Key (T : Exception_Data_Ptr) return System.Address;
  49
  50    package Exception_HTable is new System.HTable.Static_HTable (
  51      Header_Num => HTable_Headers,
  52      Element    => Exception_Data,
  53      Elmt_Ptr   => Exception_Data_Ptr,
  54      Null_Ptr   => null,
  55      Set_Next   => Set_HT_Link,
  56      Next       => Get_HT_Link,
  57      Key        => System.Address,
  58      Get_Key    => Get_Key,
  59      Hash       => Hash,
  60      Equal      => Equal);
  61
  62    -----------
  63    -- Equal --
  64    -----------
  65
  66    function Equal (A, B : System.Address) return Boolean is
  67       S1 : constant Big_String_Ptr := To_Ptr (A);
  68       S2 : constant Big_String_Ptr := To_Ptr (B);
  69       J : Integer := 1;
  70
  71    begin
  72       loop
  73          if S1 (J) /= S2 (J) then
  74             return False;
  75
  76          elsif S1 (J) = ASCII.NUL then
  77             return True;
  78
  79          else
  80             J := J + 1;
  81          end if;
  82       end loop;
  83    end Equal;
  84
  85    -----------------
  86    -- Get_HT_Link --
  87    -----------------
  88
  89    function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
  90    begin
  91       return T.HTable_Ptr;
  92    end Get_HT_Link;
  93
  94    -------------
  95    -- Get_Key --
  96    -------------
  97
  98    function Get_Key (T : Exception_Data_Ptr) return System.Address is
  99    begin
 100       return T.Full_Name;
 101    end Get_Key;
 102
 103    -------------------------------
 104    -- Get_Registered_Exceptions --
 105    -------------------------------
 106
 107    procedure Get_Registered_Exceptions
 108      (List : out Exception_Data_Array;
 109       Last : out Integer)
 110    is
 111       Data : Exception_Data_Ptr := Exception_HTable.Get_First;
 112
 113    begin
 114       Lock_Task.all;
 115       Last := List'First - 1;
 116
 117       while Last < List'Last and then Data /= null loop
 118          Last := Last + 1;
 119          List (Last) := Data;
 120          Data := Exception_HTable.Get_Next;
 121       end loop;
 122
 123       Unlock_Task.all;
 124    end Get_Registered_Exceptions;
 125
 126    ----------
 127    -- Hash --
 128    ----------
 129
 130    function Hash (F : System.Address) return HTable_Headers is
 131       type S is mod 2**8;
 132
 133       Str  : constant Big_String_Ptr := To_Ptr (F);
 134       Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
 135       Tmp  : S := 0;
 136       J    : Positive;
 137
 138    begin
 139       J := 1;
 140       loop
 141          if Str (J) = ASCII.NUL then
 142             return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
 143          else
 144             Tmp := Tmp xor S (Character'Pos (Str (J)));
 145          end if;
 146          J := J + 1;
 147       end loop;
 148    end Hash;
 149
 150    ------------------------
 151    -- Internal_Exception --
 152    ------------------------
 153
 154    function Internal_Exception
 155      (X                   : String;
 156       Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
 157    is
 158       type String_Ptr is access all String;
 159
 160       Copy     : aliased String (X'First .. X'Last + 1);
 161       Res      : Exception_Data_Ptr;
 162       Dyn_Copy : String_Ptr;
 163
 164    begin
 165       Copy (X'Range) := X;
 166       Copy (Copy'Last) := ASCII.NUL;
 167       Res := Exception_HTable.Get (Copy'Address);
 168
 169       --  If unknown exception, create it on the heap. This is a legitimate
 170       --  situation in the distributed case when an exception is defined only
 171       --  in a partition
 172
 173       if Res = null and then Create_If_Not_Exist then
 174          Dyn_Copy := new String'(Copy);
 175
 176          Res :=
 177            new Exception_Data'
 178              (Not_Handled_By_Others => False,
 179               Lang                  => 'A',
 180               Name_Length           => Copy'Length,
 181               Full_Name             => Dyn_Copy.all'Address,
 182               HTable_Ptr            => null,
 183               Import_Code           => 0,
 184               Raise_Hook            => null);
 185
 186          Register_Exception (Res);
 187       end if;
 188
 189       return Res;
 190    end Internal_Exception;
 191
 192    ------------------------
 193    -- Register_Exception --
 194    ------------------------
 195
 196    procedure Register_Exception (X : Exception_Data_Ptr) is
 197    begin
 198       Exception_HTable.Set (X);
 199    end Register_Exception;
 200
 201    ---------------------------------
 202    -- Registered_Exceptions_Count --
 203    ---------------------------------
 204
 205    function Registered_Exceptions_Count return Natural is
 206       Count : Natural := 0;
 207       Data  : Exception_Data_Ptr := Exception_HTable.Get_First;
 208
 209    begin
 210       --  We need to lock the runtime in the meantime, to avoid concurrent
 211       --  access since we have only one iterator.
 212
 213       Lock_Task.all;
 214
 215       while Data /= null loop
 216          Count := Count + 1;
 217          Data := Exception_HTable.Get_Next;
 218       end loop;
 219
 220       Unlock_Task.all;
 221       return Count;
 222    end Registered_Exceptions_Count;
 223
 224    -----------------
 225    -- Set_HT_Link --
 226    -----------------
 227
 228    procedure Set_HT_Link
 229      (T    : Exception_Data_Ptr;
 230       Next : Exception_Data_Ptr)
 231    is
 232    begin
 233       T.HTable_Ptr := Next;
 234    end Set_HT_Link;
 235
 236 --  Register the standard exceptions at elaboration time
 237
 238 begin
 239    Register_Exception (Abort_Signal_Def'Access);
 240    Register_Exception (Tasking_Error_Def'Access);
 241    Register_Exception (Storage_Error_Def'Access);
 242    Register_Exception (Program_Error_Def'Access);
 243    Register_Exception (Numeric_Error_Def'Access);
 244    Register_Exception (Constraint_Error_Def'Access);
 245
 246 end System.Exception_Table;