aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.0/gcc/ada/s-exctab.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-exctab.adb')
-rw-r--r--gcc-4.4.0/gcc/ada/s-exctab.adb248
1 files changed, 248 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-exctab.adb b/gcc-4.4.0/gcc/ada/s-exctab.adb
new file mode 100644
index 000000000..ddf1dfa65
--- /dev/null
+++ b/gcc-4.4.0/gcc/ada/s-exctab.adb
@@ -0,0 +1,248 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N _ T A B L E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Warnings (Off);
+pragma Compiler_Unit;
+pragma Warnings (On);
+
+with System.HTable;
+with System.Soft_Links; use System.Soft_Links;
+
+package body System.Exception_Table is
+
+ use System.Standard_Library;
+
+ type HTable_Headers is range 1 .. 37;
+
+ procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
+ function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
+
+ function Hash (F : System.Address) return HTable_Headers;
+ function Equal (A, B : System.Address) return Boolean;
+ function Get_Key (T : Exception_Data_Ptr) return System.Address;
+
+ package Exception_HTable is new System.HTable.Static_HTable (
+ Header_Num => HTable_Headers,
+ Element => Exception_Data,
+ Elmt_Ptr => Exception_Data_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_HT_Link,
+ Next => Get_HT_Link,
+ Key => System.Address,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (A, B : System.Address) return Boolean is
+ S1 : constant Big_String_Ptr := To_Ptr (A);
+ S2 : constant Big_String_Ptr := To_Ptr (B);
+ J : Integer := 1;
+
+ begin
+ loop
+ if S1 (J) /= S2 (J) then
+ return False;
+
+ elsif S1 (J) = ASCII.NUL then
+ return True;
+
+ else
+ J := J + 1;
+ end if;
+ end loop;
+ end Equal;
+
+ -----------------
+ -- Get_HT_Link --
+ -----------------
+
+ function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
+ begin
+ return T.HTable_Ptr;
+ end Get_HT_Link;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (T : Exception_Data_Ptr) return System.Address is
+ begin
+ return T.Full_Name;
+ end Get_Key;
+
+ -------------------------------
+ -- Get_Registered_Exceptions --
+ -------------------------------
+
+ procedure Get_Registered_Exceptions
+ (List : out Exception_Data_Array;
+ Last : out Integer)
+ is
+ Data : Exception_Data_Ptr := Exception_HTable.Get_First;
+
+ begin
+ Lock_Task.all;
+ Last := List'First - 1;
+
+ while Last < List'Last and then Data /= null loop
+ Last := Last + 1;
+ List (Last) := Data;
+ Data := Exception_HTable.Get_Next;
+ end loop;
+
+ Unlock_Task.all;
+ end Get_Registered_Exceptions;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : System.Address) return HTable_Headers is
+ type S is mod 2**8;
+
+ Str : constant Big_String_Ptr := To_Ptr (F);
+ Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
+ Tmp : S := 0;
+ J : Positive;
+
+ begin
+ J := 1;
+ loop
+ if Str (J) = ASCII.NUL then
+ return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
+ else
+ Tmp := Tmp xor S (Character'Pos (Str (J)));
+ end if;
+ J := J + 1;
+ end loop;
+ end Hash;
+
+ ------------------------
+ -- Internal_Exception --
+ ------------------------
+
+ function Internal_Exception
+ (X : String;
+ Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
+ is
+ type String_Ptr is access all String;
+
+ Copy : aliased String (X'First .. X'Last + 1);
+ Res : Exception_Data_Ptr;
+ Dyn_Copy : String_Ptr;
+
+ begin
+ Copy (X'Range) := X;
+ Copy (Copy'Last) := ASCII.NUL;
+ Res := Exception_HTable.Get (Copy'Address);
+
+ -- If unknown exception, create it on the heap. This is a legitimate
+ -- situation in the distributed case when an exception is defined only
+ -- in a partition
+
+ if Res = null and then Create_If_Not_Exist then
+ Dyn_Copy := new String'(Copy);
+
+ Res :=
+ new Exception_Data'
+ (Not_Handled_By_Others => False,
+ Lang => 'A',
+ Name_Length => Copy'Length,
+ Full_Name => Dyn_Copy.all'Address,
+ HTable_Ptr => null,
+ Import_Code => 0,
+ Raise_Hook => null);
+
+ Register_Exception (Res);
+ end if;
+
+ return Res;
+ end Internal_Exception;
+
+ ------------------------
+ -- Register_Exception --
+ ------------------------
+
+ procedure Register_Exception (X : Exception_Data_Ptr) is
+ begin
+ Exception_HTable.Set (X);
+ end Register_Exception;
+
+ ---------------------------------
+ -- Registered_Exceptions_Count --
+ ---------------------------------
+
+ function Registered_Exceptions_Count return Natural is
+ Count : Natural := 0;
+ Data : Exception_Data_Ptr := Exception_HTable.Get_First;
+
+ begin
+ -- We need to lock the runtime in the meantime, to avoid concurrent
+ -- access since we have only one iterator.
+
+ Lock_Task.all;
+
+ while Data /= null loop
+ Count := Count + 1;
+ Data := Exception_HTable.Get_Next;
+ end loop;
+
+ Unlock_Task.all;
+ return Count;
+ end Registered_Exceptions_Count;
+
+ -----------------
+ -- Set_HT_Link --
+ -----------------
+
+ procedure Set_HT_Link
+ (T : Exception_Data_Ptr;
+ Next : Exception_Data_Ptr)
+ is
+ begin
+ T.HTable_Ptr := Next;
+ end Set_HT_Link;
+
+-- Register the standard exceptions at elaboration time
+
+begin
+ Register_Exception (Abort_Signal_Def'Access);
+ Register_Exception (Tasking_Error_Def'Access);
+ Register_Exception (Storage_Error_Def'Access);
+ Register_Exception (Program_Error_Def'Access);
+ Register_Exception (Numeric_Error_Def'Access);
+ Register_Exception (Constraint_Error_Def'Access);
+
+end System.Exception_Table;