OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-exctab.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--               S Y S T E M . E X C E P T I O N _ T A B L E                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1996-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
pragma Compiler_Unit;
33
 
34
with System.HTable;
35
with System.Soft_Links;   use System.Soft_Links;
36
 
37
package body System.Exception_Table is
38
 
39
   use System.Standard_Library;
40
 
41
   type HTable_Headers is range 1 .. 37;
42
 
43
   procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
44
   function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
45
 
46
   function Hash (F : System.Address) return HTable_Headers;
47
   function Equal (A, B : System.Address) return Boolean;
48
   function Get_Key (T : Exception_Data_Ptr) return System.Address;
49
 
50
   package Exception_HTable is new System.HTable.Static_HTable (
51
     Header_Num => HTable_Headers,
52
     Element    => Exception_Data,
53
     Elmt_Ptr   => Exception_Data_Ptr,
54
     Null_Ptr   => null,
55
     Set_Next   => Set_HT_Link,
56
     Next       => Get_HT_Link,
57
     Key        => System.Address,
58
     Get_Key    => Get_Key,
59
     Hash       => Hash,
60
     Equal      => Equal);
61
 
62
   -----------
63
   -- Equal --
64
   -----------
65
 
66
   function Equal (A, B : System.Address) return Boolean is
67
      S1 : constant Big_String_Ptr := To_Ptr (A);
68
      S2 : constant Big_String_Ptr := To_Ptr (B);
69
      J : Integer := 1;
70
 
71
   begin
72
      loop
73
         if S1 (J) /= S2 (J) then
74
            return False;
75
 
76
         elsif S1 (J) = ASCII.NUL then
77
            return True;
78
 
79
         else
80
            J := J + 1;
81
         end if;
82
      end loop;
83
   end Equal;
84
 
85
   -----------------
86
   -- Get_HT_Link --
87
   -----------------
88
 
89
   function  Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
90
   begin
91
      return T.HTable_Ptr;
92
   end Get_HT_Link;
93
 
94
   -------------
95
   -- Get_Key --
96
   -------------
97
 
98
   function Get_Key (T : Exception_Data_Ptr) return System.Address is
99
   begin
100
      return T.Full_Name;
101
   end Get_Key;
102
 
103
   -------------------------------
104
   -- Get_Registered_Exceptions --
105
   -------------------------------
106
 
107
   procedure Get_Registered_Exceptions
108
     (List : out Exception_Data_Array;
109
      Last : out Integer)
110
   is
111
      Data : Exception_Data_Ptr := Exception_HTable.Get_First;
112
 
113
   begin
114
      Lock_Task.all;
115
      Last := List'First - 1;
116
 
117
      while Last < List'Last and then Data /= null loop
118
         Last := Last + 1;
119
         List (Last) := Data;
120
         Data := Exception_HTable.Get_Next;
121
      end loop;
122
 
123
      Unlock_Task.all;
124
   end Get_Registered_Exceptions;
125
 
126
   ----------
127
   -- Hash --
128
   ----------
129
 
130
   function Hash (F : System.Address) return HTable_Headers is
131
      type S is mod 2**8;
132
 
133
      Str  : constant Big_String_Ptr := To_Ptr (F);
134
      Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
135
      Tmp  : S := 0;
136
      J    : Positive;
137
 
138
   begin
139
      J := 1;
140
      loop
141
         if Str (J) = ASCII.NUL then
142
            return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
143
         else
144
            Tmp := Tmp xor S (Character'Pos (Str (J)));
145
         end if;
146
         J := J + 1;
147
      end loop;
148
   end Hash;
149
 
150
   ------------------------
151
   -- Internal_Exception --
152
   ------------------------
153
 
154
   function Internal_Exception
155
     (X                   : String;
156
      Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
157
   is
158
      type String_Ptr is access all String;
159
 
160
      Copy     : aliased String (X'First .. X'Last + 1);
161
      Res      : Exception_Data_Ptr;
162
      Dyn_Copy : String_Ptr;
163
 
164
   begin
165
      Copy (X'Range) := X;
166
      Copy (Copy'Last) := ASCII.NUL;
167
      Res := Exception_HTable.Get (Copy'Address);
168
 
169
      --  If unknown exception, create it on the heap. This is a legitimate
170
      --  situation in the distributed case when an exception is defined only
171
      --  in a partition
172
 
173
      if Res = null and then Create_If_Not_Exist then
174
         Dyn_Copy := new String'(Copy);
175
 
176
         Res :=
177
           new Exception_Data'
178
             (Not_Handled_By_Others => False,
179
              Lang                  => 'A',
180
              Name_Length           => Copy'Length,
181
              Full_Name             => Dyn_Copy.all'Address,
182
              HTable_Ptr            => null,
183
              Import_Code           => 0,
184
              Raise_Hook            => null);
185
 
186
         Register_Exception (Res);
187
      end if;
188
 
189
      return Res;
190
   end Internal_Exception;
191
 
192
   ------------------------
193
   -- Register_Exception --
194
   ------------------------
195
 
196
   procedure Register_Exception (X : Exception_Data_Ptr) is
197
   begin
198
      Exception_HTable.Set (X);
199
   end Register_Exception;
200
 
201
   ---------------------------------
202
   -- Registered_Exceptions_Count --
203
   ---------------------------------
204
 
205
   function Registered_Exceptions_Count return Natural is
206
      Count : Natural := 0;
207
      Data  : Exception_Data_Ptr := Exception_HTable.Get_First;
208
 
209
   begin
210
      --  We need to lock the runtime in the meantime, to avoid concurrent
211
      --  access since we have only one iterator.
212
 
213
      Lock_Task.all;
214
 
215
      while Data /= null loop
216
         Count := Count + 1;
217
         Data := Exception_HTable.Get_Next;
218
      end loop;
219
 
220
      Unlock_Task.all;
221
      return Count;
222
   end Registered_Exceptions_Count;
223
 
224
   -----------------
225
   -- Set_HT_Link --
226
   -----------------
227
 
228
   procedure Set_HT_Link
229
     (T    : Exception_Data_Ptr;
230
      Next : Exception_Data_Ptr)
231
   is
232
   begin
233
      T.HTable_Ptr := Next;
234
   end Set_HT_Link;
235
 
236
--  Register the standard exceptions at elaboration time
237
 
238
begin
239
   Register_Exception (Abort_Signal_Def'Access);
240
   Register_Exception (Tasking_Error_Def'Access);
241
   Register_Exception (Storage_Error_Def'Access);
242
   Register_Exception (Program_Error_Def'Access);
243
   Register_Exception (Numeric_Error_Def'Access);
244
   Register_Exception (Constraint_Error_Def'Access);
245
 
246
end System.Exception_Table;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.