1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E --
9 -- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This is an Alpha/VMS package
35 pragma Elaborate_All (System.HTable);
37 package body System.VMS_Exception_Table is
39 use type SSL.Exception_Code;
41 type HTable_Headers is range 1 .. 37;
43 type Exception_Code_Data;
44 type Exception_Code_Data_Ptr is access all Exception_Code_Data;
46 -- The following record maps an imported VMS condition to an
49 type Exception_Code_Data is record
50 Code : SSL.Exception_Code;
51 Except : SSL.Exception_Data_Ptr;
52 HTable_Ptr : Exception_Code_Data_Ptr;
56 (T : Exception_Code_Data_Ptr;
57 Next : Exception_Code_Data_Ptr);
59 function Get_HT_Link (T : Exception_Code_Data_Ptr)
60 return Exception_Code_Data_Ptr;
62 function Hash (F : SSL.Exception_Code) return HTable_Headers;
63 function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code;
65 package Exception_Code_HTable is new System.HTable.Static_HTable (
66 Header_Num => HTable_Headers,
67 Element => Exception_Code_Data,
68 Elmt_Ptr => Exception_Code_Data_Ptr,
70 Set_Next => Set_HT_Link,
72 Key => SSL.Exception_Code,
82 (Code : SSL.Exception_Code) return SSL.Exception_Code
85 return Code and not 2#0111#;
92 function Coded_Exception
93 (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr
95 Res : Exception_Code_Data_Ptr;
98 Res := Exception_Code_HTable.Get (X);
113 (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr
123 function Get_Key (T : Exception_Code_Data_Ptr)
124 return SSL.Exception_Code
135 (F : SSL.Exception_Code) return HTable_Headers
137 Headers_Magnitude : constant SSL.Exception_Code :=
138 SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
141 return HTable_Headers (F mod Headers_Magnitude + 1);
144 ----------------------------
145 -- Register_VMS_Exception --
146 ----------------------------
148 procedure Register_VMS_Exception
149 (Code : SSL.Exception_Code;
150 E : SSL.Exception_Data_Ptr)
152 -- We bind the exception data with the base code found in the
153 -- input value, that is with the severity bits masked off.
155 Excode : constant SSL.Exception_Code := Base_Code_In (Code);
158 -- The exception data registered here is mostly filled prior to this
159 -- call and by __gnat_error_handler when the exception is raised. We
160 -- still need to fill a couple of components for exceptions that will
161 -- be used as propagation filters (exception data pointer registered
162 -- as choices in the unwind tables): in some import/export cases, the
163 -- exception pointers for the choice and the propagated occurrence may
164 -- indeed be different for a single import code, and the personality
165 -- routine attempts to match the import codes in this case.
168 E.Import_Code := Excode;
170 if Exception_Code_HTable.Get (Excode) = null then
171 Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null));
173 end Register_VMS_Exception;
179 procedure Set_HT_Link
180 (T : Exception_Code_Data_Ptr;
181 Next : Exception_Code_Data_Ptr)
184 T.HTable_Ptr := Next;
187 end System.VMS_Exception_Table;