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-2013, 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
);
36 with System
.Storage_Elements
; use System
.Storage_Elements
;
38 package body System
.VMS_Exception_Table
is
40 type HTable_Headers
is range 1 .. 37;
42 type Exception_Code_Data
;
43 type Exception_Code_Data_Ptr
is access all Exception_Code_Data
;
45 -- The following record maps an imported VMS condition to an
48 type Exception_Code_Data
is record
49 Code
: Exception_Code
;
50 Except
: SSL
.Exception_Data_Ptr
;
51 HTable_Ptr
: Exception_Code_Data_Ptr
;
55 (T
: Exception_Code_Data_Ptr
;
56 Next
: Exception_Code_Data_Ptr
);
58 function Get_HT_Link
(T
: Exception_Code_Data_Ptr
)
59 return Exception_Code_Data_Ptr
;
61 function Hash
(F
: Exception_Code
) return HTable_Headers
;
62 function Get_Key
(T
: Exception_Code_Data_Ptr
) return Exception_Code
;
64 package Exception_Code_HTable
is new System
.HTable
.Static_HTable
(
65 Header_Num
=> HTable_Headers
,
66 Element
=> Exception_Code_Data
,
67 Elmt_Ptr
=> Exception_Code_Data_Ptr
,
69 Set_Next
=> Set_HT_Link
,
71 Key
=> Exception_Code
,
81 (Code
: Exception_Code
) return Exception_Code
84 return To_Address
(To_Integer
(Code
) and not 2#
0111#
);
91 function Coded_Exception
92 (X
: Exception_Code
) return SSL
.Exception_Data_Ptr
94 Res
: Exception_Code_Data_Ptr
;
97 Res
:= Exception_Code_HTable
.Get
(X
);
112 (T
: Exception_Code_Data_Ptr
) return Exception_Code_Data_Ptr
122 function Get_Key
(T
: Exception_Code_Data_Ptr
)
123 return Exception_Code
134 (F
: Exception_Code
) return HTable_Headers
136 Headers_Magnitude
: constant Exception_Code
:=
137 Exception_Code
(HTable_Headers
'Last - HTable_Headers
'First + 1);
140 return HTable_Headers
141 (To_Address
((To_Integer
(F
) mod To_Integer
(Headers_Magnitude
)) + 1));
144 ----------------------------
145 -- Register_VMS_Exception --
146 ----------------------------
148 procedure Register_VMS_Exception
149 (Code
: 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 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
.Foreign_Data
:= 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;