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-2013, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Compiler_Unit;
  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    begin
  71       loop
  72          if S1 (J) /= S2 (J) then
  73             return False;
  74          elsif S1 (J) = ASCII.NUL then
  75             return True;
  76          else
  77             J := J + 1;
  78          end if;
  79       end loop;
  80    end Equal;
  81
  82    -----------------
  83    -- Get_HT_Link --
  84    -----------------
  85
  86    function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
  87    begin
  88       return T.HTable_Ptr;
  89    end Get_HT_Link;
  90
  91    -------------
  92    -- Get_Key --
  93    -------------
  94
  95    function Get_Key (T : Exception_Data_Ptr) return System.Address is
  96    begin
  97       return T.Full_Name;
  98    end Get_Key;
  99
 100    -------------------------------
 101    -- Get_Registered_Exceptions --
 102    -------------------------------
 103
 104    procedure Get_Registered_Exceptions
 105      (List : out Exception_Data_Array;
 106       Last : out Integer)
 107    is
 108       Data : Exception_Data_Ptr := Exception_HTable.Get_First;
 109
 110    begin
 111       Lock_Task.all;
 112       Last := List'First - 1;
 113
 114       while Last < List'Last and then Data /= null loop
 115          Last := Last + 1;
 116          List (Last) := Data;
 117          Data := Exception_HTable.Get_Next;
 118       end loop;
 119
 120       Unlock_Task.all;
 121    end Get_Registered_Exceptions;
 122
 123    ----------
 124    -- Hash --
 125    ----------
 126
 127    function Hash (F : System.Address) return HTable_Headers is
 128       type S is mod 2**8;
 129
 130       Str  : constant Big_String_Ptr := To_Ptr (F);
 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 Str (J) = ASCII.NUL then
 139             return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
 140          else
 141             Tmp := Tmp xor S (Character'Pos (Str (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 (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             => Dyn_Copy.all'Address,
 179               HTable_Ptr            => null,
 180               Foreign_Data          => Null_Address,
 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;