gcc/ada/libgnat/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-2023, 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 with System.Soft_Links; use System.Soft_Links;
  33
  34 package body System.Exception_Table is
  35
  36    use System.Standard_Library;
  37
  38    type Hash_Val is mod 2 ** 8;
  39    subtype Hash_Idx is Hash_Val range 1 .. 37;
  40
  41    HTable : array (Hash_Idx) of aliased Exception_Data_Ptr;
  42    --  Actual hash table containing all registered exceptions
  43    --
  44    --  The table is very small and the hash function weak, as looking up
  45    --  registered exceptions is rare and minimizing space and time overhead
  46    --  of registration is more important. In addition, it is expected that the
  47    --  exceptions that need to be looked up are registered dynamically, and
  48    --  therefore will be at the begin of the hash chains.
  49    --
  50    --  The table differs from System.HTable.Static_HTable in that the final
  51    --  element of each chain is not marked by null, but by a pointer to self.
  52    --  This way it is possible to defend against the same entry being inserted
  53    --  twice, without having to do a lookup which is relatively expensive for
  54    --  programs with large number
  55    --
  56    --  All non-local subprograms use the global Task_Lock to protect against
  57    --  concurrent use of the exception table. This is needed as local
  58    --  exceptions may be declared concurrently with those declared at the
  59    --  library level.
  60
  61    --  Local Subprograms
  62
  63    generic
  64       with procedure Process (T : Exception_Data_Ptr; More : out Boolean);
  65    procedure Iterate;
  66    --  Iterate over all
  67
  68    function Lookup  (Name : String) return Exception_Data_Ptr;
  69    --  Find and return the Exception_Data of the exception with the given Name
  70    --  (which must be in all uppercase), or null if none was registered.
  71
  72    procedure Register (Item : Exception_Data_Ptr);
  73    --  Register an exception with the given Exception_Data in the table.
  74
  75    function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean;
  76    --  Return True iff Item.Full_Name and Name are equal. Both names are
  77    --  assumed to be in all uppercase and end with ASCII.NUL.
  78
  79    function Hash (S : String) return Hash_Idx;
  80    --  Return the index in the hash table for S, which is assumed to be all
  81    --  uppercase and end with ASCII.NUL.
  82
  83    --------------
  84    -- Has_Name --
  85    --------------
  86
  87    function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean
  88    is
  89       S : constant Big_String_Ptr := To_Ptr (Item.Full_Name);
  90       J : Integer := S'First;
  91
  92    begin
  93       for K in Name'Range loop
  94
  95          --  Note that as both items are terminated with ASCII.NUL, the
  96          --  comparison below must fail for strings of different lengths.
  97
  98          if S (J) /= Name (K) then
  99             return False;
 100          end if;
 101
 102          J := J + 1;
 103       end loop;
 104
 105       return True;
 106    end Has_Name;
 107
 108    ------------
 109    -- Lookup --
 110    ------------
 111
 112    function Lookup (Name : String) return Exception_Data_Ptr is
 113       Prev   : Exception_Data_Ptr;
 114       Curr   : Exception_Data_Ptr;
 115
 116    begin
 117       Curr := HTable (Hash (Name));
 118       Prev := null;
 119       while Curr /= Prev loop
 120          if Has_Name (Curr, Name) then
 121             return Curr;
 122          end if;
 123
 124          Prev := Curr;
 125          Curr := Curr.HTable_Ptr;
 126       end loop;
 127
 128       return null;
 129    end Lookup;
 130
 131    ----------
 132    -- Hash --
 133    ----------
 134
 135    function Hash (S : String) return Hash_Idx is
 136       Hash : Hash_Val := 0;
 137
 138    begin
 139       for J in S'Range loop
 140          exit when S (J) = ASCII.NUL;
 141          Hash := Hash xor Character'Pos (S (J));
 142       end loop;
 143
 144       return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1);
 145    end Hash;
 146
 147    -------------
 148    -- Iterate --
 149    -------------
 150
 151    procedure Iterate is
 152       More : Boolean;
 153       Prev, Curr : Exception_Data_Ptr;
 154
 155    begin
 156       Outer : for Idx in HTable'Range loop
 157          Prev   := null;
 158          Curr   := HTable (Idx);
 159
 160          while Curr /= Prev loop
 161                Process (Curr, More);
 162
 163                exit Outer when not More;
 164
 165                Prev := Curr;
 166                Curr := Curr.HTable_Ptr;
 167          end loop;
 168       end loop Outer;
 169    end Iterate;
 170
 171    --------------
 172    -- Register --
 173    --------------
 174
 175    procedure Register (Item : Exception_Data_Ptr) is
 176    begin
 177       if Item.HTable_Ptr = null then
 178          Prepend_To_Chain : declare
 179             Chain : Exception_Data_Ptr
 180                       renames HTable (Hash (To_Ptr (Item.Full_Name).all));
 181
 182          begin
 183             if Chain = null then
 184                Item.HTable_Ptr := Item;
 185             else
 186                Item.HTable_Ptr := Chain;
 187             end if;
 188
 189             Chain := Item;
 190          end Prepend_To_Chain;
 191       end if;
 192    end Register;
 193
 194    -------------------------------
 195    -- Get_Registered_Exceptions --
 196    -------------------------------
 197
 198    procedure Get_Registered_Exceptions
 199      (List : out Exception_Data_Array;
 200       Last : out Integer)
 201    is
 202       procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean);
 203       --  Add Item to List (List'First .. Last) by first incrementing Last
 204       --  and storing Item in List (Last). Last should be in List'First - 1
 205       --  and List'Last.
 206
 207       procedure Get_All is new Iterate (Get_One);
 208       --  Store all registered exceptions in List, updating Last
 209
 210       -------------
 211       -- Get_One --
 212       -------------
 213
 214       procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is
 215       begin
 216          if Last < List'Last then
 217             Last := Last + 1;
 218             List (Last) := Item;
 219             More := True;
 220
 221          else
 222             More := False;
 223          end if;
 224       end Get_One;
 225
 226    begin
 227       --  In this routine the invariant is that List (List'First .. Last)
 228       --  contains the registered exceptions retrieved so far.
 229
 230       Last := List'First - 1;
 231
 232       Lock_Task.all;
 233       Get_All;
 234       Unlock_Task.all;
 235    end Get_Registered_Exceptions;
 236
 237    ------------------------
 238    -- Internal_Exception --
 239    ------------------------
 240
 241    function Internal_Exception
 242      (X                   : String;
 243       Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
 244    is
 245       --  If X was not yet registered and Create_if_Not_Exist is True,
 246       --  dynamically allocate and register a new exception.
 247
 248       type String_Ptr is access all String;
 249
 250       Dyn_Copy : String_Ptr;
 251       Copy     : aliased String (X'First .. X'Last + 1);
 252       Result   : Exception_Data_Ptr;
 253
 254    begin
 255       Lock_Task.all;
 256
 257       Copy (X'Range) := X;
 258       Copy (Copy'Last) := ASCII.NUL;
 259       Result := Lookup (Copy);
 260
 261       --  If unknown exception, create it on the heap. This is a legitimate
 262       --  situation in the distributed case when an exception is defined
 263       --  only in a partition
 264
 265       if Result = null and then Create_If_Not_Exist then
 266          Dyn_Copy := new String'(Copy);
 267
 268          Result :=
 269            new Exception_Data'
 270              (Not_Handled_By_Others => False,
 271               Lang                  => 'A',
 272               Name_Length           => Copy'Length,
 273               Full_Name             => Dyn_Copy.all'Address,
 274               HTable_Ptr            => null,
 275               Foreign_Data          => Null_Address,
 276               Raise_Hook            => null);
 277
 278          Register (Result);
 279       end if;
 280
 281       Unlock_Task.all;
 282
 283       return Result;
 284    end Internal_Exception;
 285
 286    ------------------------
 287    -- Register_Exception --
 288    ------------------------
 289
 290    procedure Register_Exception (X : Exception_Data_Ptr) is
 291    begin
 292       Lock_Task.all;
 293       Register (X);
 294       Unlock_Task.all;
 295    end Register_Exception;
 296
 297    ---------------------------------
 298    -- Registered_Exceptions_Count --
 299    ---------------------------------
 300
 301    function Registered_Exceptions_Count return Natural is
 302       Count : Natural := 0;
 303
 304       procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean);
 305       --  Update Count for given Item
 306
 307       procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is
 308          pragma Unreferenced (Item);
 309       begin
 310          Count := Count + 1;
 311          More := Count < Natural'Last;
 312       end Count_Item;
 313
 314       procedure Count_All is new Iterate (Count_Item);
 315
 316    begin
 317       Lock_Task.all;
 318       Count_All;
 319       Unlock_Task.all;
 320
 321       return Count;
 322    end Registered_Exceptions_Count;
 323
 324 begin
 325    --  Register the standard exceptions at elaboration time
 326
 327    --  We don't need to use the locking version here as the elaboration
 328    --  will not be concurrent and no tasks can call any subprograms of this
 329    --  unit before it has been elaborated.
 330
 331    Register (Abort_Signal_Def'Access);
 332    Register (Tasking_Error_Def'Access);
 333    Register (Storage_Error_Def'Access);
 334    Register (Program_Error_Def'Access);
 335    Register (Numeric_Error_Def'Access);
 336    Register (Constraint_Error_Def'Access);
 337 end System.Exception_Table;