1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--           S Y S T E M . V M S _ E X C E P T I O N _ T A B L E            --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1997-2013, 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--  This is an Alpha/VMS package
33
34with System.HTable;
35pragma Elaborate_All (System.HTable);
36with System.Storage_Elements; use System.Storage_Elements;
37
38package body System.VMS_Exception_Table is
39
40   type HTable_Headers is range 1 .. 37;
41
42   type Exception_Code_Data;
43   type Exception_Code_Data_Ptr is access all Exception_Code_Data;
44
45   --  The following record maps an imported VMS condition to an
46   --  Ada exception.
47
48   type Exception_Code_Data is record
49      Code       : Exception_Code;
50      Except     : SSL.Exception_Data_Ptr;
51      HTable_Ptr : Exception_Code_Data_Ptr;
52   end record;
53
54   procedure Set_HT_Link
55     (T    : Exception_Code_Data_Ptr;
56      Next : Exception_Code_Data_Ptr);
57
58   function Get_HT_Link (T : Exception_Code_Data_Ptr)
59     return Exception_Code_Data_Ptr;
60
61   function Hash (F : Exception_Code) return HTable_Headers;
62   function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code;
63
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,
68     Null_Ptr   => null,
69     Set_Next   => Set_HT_Link,
70     Next       => Get_HT_Link,
71     Key        => Exception_Code,
72     Get_Key    => Get_Key,
73     Hash       => Hash,
74     Equal      => "=");
75
76   ------------------
77   -- Base_Code_In --
78   ------------------
79
80   function Base_Code_In
81     (Code : Exception_Code) return Exception_Code
82   is
83   begin
84      return To_Address (To_Integer (Code) and not 2#0111#);
85   end Base_Code_In;
86
87   ---------------------
88   -- Coded_Exception --
89   ---------------------
90
91   function Coded_Exception
92     (X : Exception_Code) return SSL.Exception_Data_Ptr
93   is
94      Res : Exception_Code_Data_Ptr;
95
96   begin
97      Res := Exception_Code_HTable.Get (X);
98
99      if Res /= null  then
100         return Res.Except;
101      else
102         return null;
103      end if;
104
105   end Coded_Exception;
106
107   -----------------
108   -- Get_HT_Link --
109   -----------------
110
111   function Get_HT_Link
112     (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr
113   is
114   begin
115      return T.HTable_Ptr;
116   end Get_HT_Link;
117
118   -------------
119   -- Get_Key --
120   -------------
121
122   function Get_Key (T : Exception_Code_Data_Ptr)
123     return Exception_Code
124   is
125   begin
126      return T.Code;
127   end Get_Key;
128
129   ----------
130   -- Hash --
131   ----------
132
133   function Hash
134     (F : Exception_Code) return HTable_Headers
135   is
136      Headers_Magnitude : constant Exception_Code :=
137        Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
138
139   begin
140      return HTable_Headers
141        (To_Address ((To_Integer (F) mod To_Integer (Headers_Magnitude)) + 1));
142   end Hash;
143
144   ----------------------------
145   -- Register_VMS_Exception --
146   ----------------------------
147
148   procedure Register_VMS_Exception
149     (Code : Exception_Code;
150      E    : SSL.Exception_Data_Ptr)
151   is
152      --  We bind the exception data with the base code found in the
153      --  input value, that is with the severity bits masked off.
154
155      Excode : constant Exception_Code := Base_Code_In (Code);
156
157   begin
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.
166
167      E.Lang := 'V';
168      E.Foreign_Data := Excode;
169
170      if Exception_Code_HTable.Get (Excode) = null then
171         Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null));
172      end if;
173   end Register_VMS_Exception;
174
175   -----------------
176   -- Set_HT_Link --
177   -----------------
178
179   procedure Set_HT_Link
180     (T    : Exception_Code_Data_Ptr;
181      Next : Exception_Code_Data_Ptr)
182   is
183   begin
184      T.HTable_Ptr := Next;
185   end Set_HT_Link;
186
187end System.VMS_Exception_Table;
188