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-2009, 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);
36
37package body System.VMS_Exception_Table is
38
39   use type SSL.Exception_Code;
40
41   type HTable_Headers is range 1 .. 37;
42
43   type Exception_Code_Data;
44   type Exception_Code_Data_Ptr is access all Exception_Code_Data;
45
46   --  The following record maps an imported VMS condition to an
47   --  Ada exception.
48
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;
53   end record;
54
55   procedure Set_HT_Link
56     (T    : Exception_Code_Data_Ptr;
57      Next : Exception_Code_Data_Ptr);
58
59   function Get_HT_Link (T : Exception_Code_Data_Ptr)
60     return Exception_Code_Data_Ptr;
61
62   function Hash (F : SSL.Exception_Code) return HTable_Headers;
63   function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code;
64
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,
69     Null_Ptr   => null,
70     Set_Next   => Set_HT_Link,
71     Next       => Get_HT_Link,
72     Key        => SSL.Exception_Code,
73     Get_Key    => Get_Key,
74     Hash       => Hash,
75     Equal      => "=");
76
77   ------------------
78   -- Base_Code_In --
79   ------------------
80
81   function Base_Code_In
82     (Code : SSL.Exception_Code) return SSL.Exception_Code
83   is
84   begin
85      return Code and not 2#0111#;
86   end Base_Code_In;
87
88   ---------------------
89   -- Coded_Exception --
90   ---------------------
91
92   function Coded_Exception
93     (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr
94   is
95      Res : Exception_Code_Data_Ptr;
96
97   begin
98      Res := Exception_Code_HTable.Get (X);
99
100      if Res /= null  then
101         return Res.Except;
102      else
103         return null;
104      end if;
105
106   end Coded_Exception;
107
108   -----------------
109   -- Get_HT_Link --
110   -----------------
111
112   function Get_HT_Link
113     (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr
114   is
115   begin
116      return T.HTable_Ptr;
117   end Get_HT_Link;
118
119   -------------
120   -- Get_Key --
121   -------------
122
123   function Get_Key (T : Exception_Code_Data_Ptr)
124     return SSL.Exception_Code
125   is
126   begin
127      return T.Code;
128   end Get_Key;
129
130   ----------
131   -- Hash --
132   ----------
133
134   function Hash
135     (F : SSL.Exception_Code) return HTable_Headers
136   is
137      Headers_Magnitude : constant SSL.Exception_Code :=
138        SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
139
140   begin
141      return HTable_Headers (F mod Headers_Magnitude + 1);
142   end Hash;
143
144   ----------------------------
145   -- Register_VMS_Exception --
146   ----------------------------
147
148   procedure Register_VMS_Exception
149     (Code : SSL.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 SSL.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.Import_Code := 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