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