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