|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . E X C E P T I O N S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1992-2017, 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 Style_Checks (All_Checks);
|
|
|
33 -- No subprogram ordering check, due to logical grouping
|
|
|
34
|
|
|
35 pragma Polling (Off);
|
|
|
36 -- We must turn polling off for this unit, because otherwise we get
|
|
|
37 -- elaboration circularities with System.Exception_Tables.
|
|
|
38
|
|
|
39 with System; use System;
|
|
|
40 with System.Exceptions; use System.Exceptions;
|
|
|
41 with System.Exceptions_Debug; use System.Exceptions_Debug;
|
|
|
42 with System.Standard_Library; use System.Standard_Library;
|
|
|
43 with System.Soft_Links; use System.Soft_Links;
|
|
|
44 with System.WCh_Con; use System.WCh_Con;
|
|
|
45 with System.WCh_StW; use System.WCh_StW;
|
|
|
46
|
|
|
47 pragma Warnings (Off);
|
|
|
48 -- Suppress complaints about Symbolic not being referenced, and about it not
|
|
|
49 -- having pragma Preelaborate.
|
|
|
50 with System.Traceback.Symbolic;
|
|
|
51 -- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version,
|
|
|
52 -- it will install symbolic tracebacks as the default decorator. Otherwise,
|
|
|
53 -- symbolic tracebacks are not supported, and we fall back to hexadecimal
|
|
|
54 -- addresses.
|
|
|
55 pragma Warnings (On);
|
|
|
56
|
|
|
57 package body Ada.Exceptions is
|
|
|
58
|
|
|
59 pragma Suppress (All_Checks);
|
|
|
60 -- We definitely do not want exceptions occurring within this unit, or
|
|
|
61 -- we are in big trouble. If an exceptional situation does occur, better
|
|
|
62 -- that it not be raised, since raising it can cause confusing chaos.
|
|
|
63
|
|
|
64 -----------------------
|
|
|
65 -- Local Subprograms --
|
|
|
66 -----------------------
|
|
|
67
|
|
|
68 -- Note: the exported subprograms in this package body are called directly
|
|
|
69 -- from C clients using the given external name, even though they are not
|
|
|
70 -- technically visible in the Ada sense.
|
|
|
71
|
|
|
72 function Code_Address_For_AAA return System.Address;
|
|
|
73 function Code_Address_For_ZZZ return System.Address;
|
|
|
74 -- Return start and end of procedures in this package
|
|
|
75 --
|
|
|
76 -- These procedures are used to provide exclusion bounds in
|
|
|
77 -- calls to Call_Chain at exception raise points from this unit. The
|
|
|
78 -- purpose is to arrange for the exception tracebacks not to include
|
|
|
79 -- frames from subprograms involved in the raise process, as these are
|
|
|
80 -- meaningless from the user's standpoint.
|
|
|
81 --
|
|
|
82 -- For these bounds to be meaningful, we need to ensure that the object
|
|
|
83 -- code for the subprograms involved in processing a raise is located
|
|
|
84 -- after the object code Code_Address_For_AAA and before the object
|
|
|
85 -- code Code_Address_For_ZZZ. This will indeed be the case as long as
|
|
|
86 -- the following rules are respected:
|
|
|
87 --
|
|
|
88 -- 1) The bodies of the subprograms involved in processing a raise
|
|
|
89 -- are located after the body of Code_Address_For_AAA and before the
|
|
|
90 -- body of Code_Address_For_ZZZ.
|
|
|
91 --
|
|
|
92 -- 2) No pragma Inline applies to any of these subprograms, as this
|
|
|
93 -- could delay the corresponding assembly output until the end of
|
|
|
94 -- the unit.
|
|
|
95
|
|
|
96 procedure Call_Chain (Excep : EOA);
|
|
|
97 -- Store up to Max_Tracebacks in Excep, corresponding to the current
|
|
|
98 -- call chain.
|
|
|
99
|
|
|
100 function Image (Index : Integer) return String;
|
|
|
101 -- Return string image corresponding to Index
|
|
|
102
|
|
|
103 procedure To_Stderr (S : String);
|
|
|
104 pragma Export (Ada, To_Stderr, "__gnat_to_stderr");
|
|
|
105 -- Little routine to output string to stderr that is also used
|
|
|
106 -- in the tasking run time.
|
|
|
107
|
|
|
108 procedure To_Stderr (C : Character);
|
|
|
109 pragma Inline (To_Stderr);
|
|
|
110 pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char");
|
|
|
111 -- Little routine to output a character to stderr, used by some of
|
|
|
112 -- the separate units below.
|
|
|
113
|
|
|
114 package Exception_Data is
|
|
|
115
|
|
|
116 -----------------------------------
|
|
|
117 -- Exception Message Subprograms --
|
|
|
118 -----------------------------------
|
|
|
119
|
|
|
120 procedure Set_Exception_C_Msg
|
|
|
121 (Excep : EOA;
|
|
|
122 Id : Exception_Id;
|
|
|
123 Msg1 : System.Address;
|
|
|
124 Line : Integer := 0;
|
|
|
125 Column : Integer := 0;
|
|
|
126 Msg2 : System.Address := System.Null_Address);
|
|
|
127 -- This routine is called to setup the exception referenced by X
|
|
|
128 -- to contain the indicated Id value and message. Msg1 is a null
|
|
|
129 -- terminated string which is generated as the exception message. If
|
|
|
130 -- line is non-zero, then a colon and the decimal representation of
|
|
|
131 -- this integer is appended to the message. Ditto for Column. When Msg2
|
|
|
132 -- is non-null, a space and this additional null terminated string is
|
|
|
133 -- added to the message.
|
|
|
134
|
|
|
135 procedure Set_Exception_Msg
|
|
|
136 (Excep : EOA;
|
|
|
137 Id : Exception_Id;
|
|
|
138 Message : String);
|
|
|
139 -- This routine is called to setup the exception referenced by X
|
|
|
140 -- to contain the indicated Id value and message. Message is a string
|
|
|
141 -- which is generated as the exception message.
|
|
|
142
|
|
|
143 ---------------------------------------
|
|
|
144 -- Exception Information Subprograms --
|
|
|
145 ---------------------------------------
|
|
|
146
|
|
|
147 function Untailored_Exception_Information
|
|
|
148 (X : Exception_Occurrence) return String;
|
|
|
149 -- This is used by Stream_Attributes.EO_To_String to convert an
|
|
|
150 -- Exception_Occurrence to a String for the stream attributes.
|
|
|
151 -- String_To_EO understands the format, as documented here.
|
|
|
152 --
|
|
|
153 -- The format of the string is as follows:
|
|
|
154 --
|
|
|
155 -- raised <exception name> : <message>
|
|
|
156 -- (" : <message>" is present only if Exception_Message is not empty)
|
|
|
157 -- PID=nnnn (only if nonzero)
|
|
|
158 -- Call stack traceback locations: (only if at least one location)
|
|
|
159 -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
|
|
|
160 --
|
|
|
161 -- The lines are separated by a ASCII.LF character.
|
|
|
162 -- The nnnn is the partition Id given as decimal digits.
|
|
|
163 -- The 0x... line represents traceback program counter locations, in
|
|
|
164 -- execution order with the first one being the exception location.
|
|
|
165 --
|
|
|
166 -- The Exception_Name and Message lines are omitted in the abort
|
|
|
167 -- signal case, since this is not really an exception.
|
|
|
168 --
|
|
|
169 -- Note: If the format of the generated string is changed, please note
|
|
|
170 -- that an equivalent modification to the routine String_To_EO must be
|
|
|
171 -- made to preserve proper functioning of the stream attributes.
|
|
|
172
|
|
|
173 function Exception_Information (X : Exception_Occurrence) return String;
|
|
|
174 -- This is the implementation of Ada.Exceptions.Exception_Information,
|
|
|
175 -- as defined in the Ada RM.
|
|
|
176 --
|
|
|
177 -- If no traceback decorator (see GNAT.Exception_Traces) is currently
|
|
|
178 -- in place, this is the same as Untailored_Exception_Information.
|
|
|
179 -- Otherwise, the decorator is used to produce a symbolic traceback
|
|
|
180 -- instead of hexadecimal addresses.
|
|
|
181 --
|
|
|
182 -- Note that unlike Untailored_Exception_Information, there is no need
|
|
|
183 -- to keep the output of Exception_Information stable for streaming
|
|
|
184 -- purposes, and in fact the output differs across platforms.
|
|
|
185
|
|
|
186 end Exception_Data;
|
|
|
187
|
|
|
188 package Exception_Traces is
|
|
|
189
|
|
|
190 -------------------------------------------------
|
|
|
191 -- Run-Time Exception Notification Subprograms --
|
|
|
192 -------------------------------------------------
|
|
|
193
|
|
|
194 -- These subprograms provide a common run-time interface to trigger the
|
|
|
195 -- actions required when an exception is about to be propagated (e.g.
|
|
|
196 -- user specified actions or output of exception information). They are
|
|
|
197 -- exported to be usable by the Ada exception handling personality
|
|
|
198 -- routine when the GCC 3 mechanism is used.
|
|
|
199
|
|
|
200 procedure Notify_Handled_Exception (Excep : EOA);
|
|
|
201 pragma Export
|
|
|
202 (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
|
|
|
203 -- This routine is called for a handled occurrence is about to be
|
|
|
204 -- propagated.
|
|
|
205
|
|
|
206 procedure Notify_Unhandled_Exception (Excep : EOA);
|
|
|
207 pragma Export
|
|
|
208 (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
|
|
|
209 -- This routine is called when an unhandled occurrence is about to be
|
|
|
210 -- propagated.
|
|
|
211
|
|
|
212 procedure Unhandled_Exception_Terminate (Excep : EOA);
|
|
|
213 pragma No_Return (Unhandled_Exception_Terminate);
|
|
|
214 -- This procedure is called to terminate execution following an
|
|
|
215 -- unhandled exception. The exception information, including
|
|
|
216 -- traceback if available is output, and execution is then
|
|
|
217 -- terminated. Note that at the point where this routine is
|
|
|
218 -- called, the stack has typically been destroyed.
|
|
|
219
|
|
|
220 end Exception_Traces;
|
|
|
221
|
|
|
222 package Exception_Propagation is
|
|
|
223
|
|
|
224 ---------------------------------------
|
|
|
225 -- Exception Propagation Subprograms --
|
|
|
226 ---------------------------------------
|
|
|
227
|
|
|
228 function Allocate_Occurrence return EOA;
|
|
|
229 -- Allocate an exception occurrence (as well as the machine occurrence)
|
|
|
230
|
|
|
231 procedure Propagate_Exception (Excep : EOA);
|
|
|
232 pragma No_Return (Propagate_Exception);
|
|
|
233 -- This procedure propagates the exception represented by Excep
|
|
|
234
|
|
|
235 end Exception_Propagation;
|
|
|
236
|
|
|
237 package Stream_Attributes is
|
|
|
238
|
|
|
239 ----------------------------------
|
|
|
240 -- Stream Attribute Subprograms --
|
|
|
241 ----------------------------------
|
|
|
242
|
|
|
243 function EId_To_String (X : Exception_Id) return String;
|
|
|
244 function String_To_EId (S : String) return Exception_Id;
|
|
|
245 -- Functions for implementing Exception_Id stream attributes
|
|
|
246
|
|
|
247 function EO_To_String (X : Exception_Occurrence) return String;
|
|
|
248 function String_To_EO (S : String) return Exception_Occurrence;
|
|
|
249 -- Functions for implementing Exception_Occurrence stream
|
|
|
250 -- attributes
|
|
|
251
|
|
|
252 end Stream_Attributes;
|
|
|
253
|
|
|
254 procedure Complete_Occurrence (X : EOA);
|
|
|
255 -- Finish building the occurrence: save the call chain and notify the
|
|
|
256 -- debugger.
|
|
|
257
|
|
|
258 procedure Complete_And_Propagate_Occurrence (X : EOA);
|
|
|
259 pragma No_Return (Complete_And_Propagate_Occurrence);
|
|
|
260 -- This is a simple wrapper to Complete_Occurrence and
|
|
|
261 -- Exception_Propagation.Propagate_Exception.
|
|
|
262
|
|
|
263 function Create_Occurrence_From_Signal_Handler
|
|
|
264 (E : Exception_Id;
|
|
|
265 M : System.Address) return EOA;
|
|
|
266 -- Create and build an exception occurrence using exception id E and
|
|
|
267 -- nul-terminated message M.
|
|
|
268
|
|
|
269 function Create_Machine_Occurrence_From_Signal_Handler
|
|
|
270 (E : Exception_Id;
|
|
|
271 M : System.Address) return System.Address;
|
|
|
272 pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler,
|
|
|
273 "__gnat_create_machine_occurrence_from_signal_handler");
|
|
|
274 -- Create and build an exception occurrence using exception id E and
|
|
|
275 -- nul-terminated message M. Return the machine occurrence.
|
|
|
276
|
|
|
277 procedure Raise_Exception_No_Defer
|
|
|
278 (E : Exception_Id;
|
|
|
279 Message : String := "");
|
|
|
280 pragma Export
|
|
|
281 (Ada, Raise_Exception_No_Defer,
|
|
|
282 "ada__exceptions__raise_exception_no_defer");
|
|
|
283 pragma No_Return (Raise_Exception_No_Defer);
|
|
|
284 -- Similar to Raise_Exception, but with no abort deferral
|
|
|
285
|
|
|
286 procedure Raise_With_Msg (E : Exception_Id);
|
|
|
287 pragma No_Return (Raise_With_Msg);
|
|
|
288 pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg");
|
|
|
289 -- Raises an exception with given exception id value. A message
|
|
|
290 -- is associated with the raise, and has already been stored in the
|
|
|
291 -- exception occurrence referenced by the Current_Excep in the TSD.
|
|
|
292 -- Abort is deferred before the raise call.
|
|
|
293
|
|
|
294 procedure Raise_With_Location_And_Msg
|
|
|
295 (E : Exception_Id;
|
|
|
296 F : System.Address;
|
|
|
297 L : Integer;
|
|
|
298 C : Integer := 0;
|
|
|
299 M : System.Address := System.Null_Address);
|
|
|
300 pragma No_Return (Raise_With_Location_And_Msg);
|
|
|
301 -- Raise an exception with given exception id value. A filename and line
|
|
|
302 -- number is associated with the raise and is stored in the exception
|
|
|
303 -- occurrence and in addition a column and a string message M may be
|
|
|
304 -- appended to this (if not null/0).
|
|
|
305
|
|
|
306 procedure Raise_Constraint_Error (File : System.Address; Line : Integer);
|
|
|
307 pragma No_Return (Raise_Constraint_Error);
|
|
|
308 pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
|
|
|
309 -- Raise constraint error with file:line information
|
|
|
310
|
|
|
311 procedure Raise_Constraint_Error_Msg
|
|
|
312 (File : System.Address;
|
|
|
313 Line : Integer;
|
|
|
314 Column : Integer;
|
|
|
315 Msg : System.Address);
|
|
|
316 pragma No_Return (Raise_Constraint_Error_Msg);
|
|
|
317 pragma Export
|
|
|
318 (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg");
|
|
|
319 -- Raise constraint error with file:line:col + msg information
|
|
|
320
|
|
|
321 procedure Raise_Program_Error (File : System.Address; Line : Integer);
|
|
|
322 pragma No_Return (Raise_Program_Error);
|
|
|
323 pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error");
|
|
|
324 -- Raise program error with file:line information
|
|
|
325
|
|
|
326 procedure Raise_Program_Error_Msg
|
|
|
327 (File : System.Address;
|
|
|
328 Line : Integer;
|
|
|
329 Msg : System.Address);
|
|
|
330 pragma No_Return (Raise_Program_Error_Msg);
|
|
|
331 pragma Export
|
|
|
332 (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg");
|
|
|
333 -- Raise program error with file:line + msg information
|
|
|
334
|
|
|
335 procedure Raise_Storage_Error (File : System.Address; Line : Integer);
|
|
|
336 pragma No_Return (Raise_Storage_Error);
|
|
|
337 pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error");
|
|
|
338 -- Raise storage error with file:line information
|
|
|
339
|
|
|
340 procedure Raise_Storage_Error_Msg
|
|
|
341 (File : System.Address;
|
|
|
342 Line : Integer;
|
|
|
343 Msg : System.Address);
|
|
|
344 pragma No_Return (Raise_Storage_Error_Msg);
|
|
|
345 pragma Export
|
|
|
346 (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg");
|
|
|
347 -- Raise storage error with file:line + reason msg information
|
|
|
348
|
|
|
349 -- The exception raising process and the automatic tracing mechanism rely
|
|
|
350 -- on some careful use of flags attached to the exception occurrence. The
|
|
|
351 -- graph below illustrates the relations between the Raise_ subprograms
|
|
|
352 -- and identifies the points where basic flags such as Exception_Raised
|
|
|
353 -- are initialized.
|
|
|
354
|
|
|
355 -- (i) signs indicate the flags initialization points. R stands for Raise,
|
|
|
356 -- W for With, and E for Exception.
|
|
|
357
|
|
|
358 -- R_No_Msg R_E R_Pe R_Ce R_Se
|
|
|
359 -- | | | | |
|
|
|
360 -- +--+ +--+ +---+ | +---+
|
|
|
361 -- | | | | |
|
|
|
362 -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc
|
|
|
363 -- | | | |
|
|
|
364 -- +------------+ | +-----------+ +--+
|
|
|
365 -- | | | |
|
|
|
366 -- | | | Set_E_C_Msg(i)
|
|
|
367 -- | | |
|
|
|
368 -- Complete_And_Propagate_Occurrence
|
|
|
369
|
|
|
370 procedure Reraise;
|
|
|
371 pragma No_Return (Reraise);
|
|
|
372 pragma Export (C, Reraise, "__gnat_reraise");
|
|
|
373 -- Reraises the exception referenced by the Current_Excep field
|
|
|
374 -- of the TSD (all fields of this exception occurrence are set).
|
|
|
375 -- Abort is deferred before the reraise operation. Called from
|
|
|
376 -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous
|
|
|
377
|
|
|
378 procedure Transfer_Occurrence
|
|
|
379 (Target : Exception_Occurrence_Access;
|
|
|
380 Source : Exception_Occurrence);
|
|
|
381 pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
|
|
|
382 -- Called from s-tasren.adb:Local_Complete_RendezVous and
|
|
|
383 -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
|
|
|
384 -- Source as an exception to be propagated in the caller task. Target is
|
|
|
385 -- expected to be a pointer to the fixed TSD occurrence for this task.
|
|
|
386
|
|
|
387 --------------------------------
|
|
|
388 -- Run-Time Check Subprograms --
|
|
|
389 --------------------------------
|
|
|
390
|
|
|
391 -- These subprograms raise a specific exception with a reason message
|
|
|
392 -- attached. The parameters are the file name and line number in each
|
|
|
393 -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
|
|
|
394
|
|
|
395 procedure Rcheck_CE_Access_Check
|
|
|
396 (File : System.Address; Line : Integer);
|
|
|
397 procedure Rcheck_CE_Null_Access_Parameter
|
|
|
398 (File : System.Address; Line : Integer);
|
|
|
399 procedure Rcheck_CE_Discriminant_Check
|
|
|
400 (File : System.Address; Line : Integer);
|
|
|
401 procedure Rcheck_CE_Divide_By_Zero
|
|
|
402 (File : System.Address; Line : Integer);
|
|
|
403 procedure Rcheck_CE_Explicit_Raise
|
|
|
404 (File : System.Address; Line : Integer);
|
|
|
405 procedure Rcheck_CE_Index_Check
|
|
|
406 (File : System.Address; Line : Integer);
|
|
|
407 procedure Rcheck_CE_Invalid_Data
|
|
|
408 (File : System.Address; Line : Integer);
|
|
|
409 procedure Rcheck_CE_Length_Check
|
|
|
410 (File : System.Address; Line : Integer);
|
|
|
411 procedure Rcheck_CE_Null_Exception_Id
|
|
|
412 (File : System.Address; Line : Integer);
|
|
|
413 procedure Rcheck_CE_Null_Not_Allowed
|
|
|
414 (File : System.Address; Line : Integer);
|
|
|
415 procedure Rcheck_CE_Overflow_Check
|
|
|
416 (File : System.Address; Line : Integer);
|
|
|
417 procedure Rcheck_CE_Partition_Check
|
|
|
418 (File : System.Address; Line : Integer);
|
|
|
419 procedure Rcheck_CE_Range_Check
|
|
|
420 (File : System.Address; Line : Integer);
|
|
|
421 procedure Rcheck_CE_Tag_Check
|
|
|
422 (File : System.Address; Line : Integer);
|
|
|
423 procedure Rcheck_PE_Access_Before_Elaboration
|
|
|
424 (File : System.Address; Line : Integer);
|
|
|
425 procedure Rcheck_PE_Accessibility_Check
|
|
|
426 (File : System.Address; Line : Integer);
|
|
|
427 procedure Rcheck_PE_Address_Of_Intrinsic
|
|
|
428 (File : System.Address; Line : Integer);
|
|
|
429 procedure Rcheck_PE_Aliased_Parameters
|
|
|
430 (File : System.Address; Line : Integer);
|
|
|
431 procedure Rcheck_PE_All_Guards_Closed
|
|
|
432 (File : System.Address; Line : Integer);
|
|
|
433 procedure Rcheck_PE_Bad_Predicated_Generic_Type
|
|
|
434 (File : System.Address; Line : Integer);
|
|
|
435 procedure Rcheck_PE_Current_Task_In_Entry_Body
|
|
|
436 (File : System.Address; Line : Integer);
|
|
|
437 procedure Rcheck_PE_Duplicated_Entry_Address
|
|
|
438 (File : System.Address; Line : Integer);
|
|
|
439 procedure Rcheck_PE_Explicit_Raise
|
|
|
440 (File : System.Address; Line : Integer);
|
|
|
441 procedure Rcheck_PE_Implicit_Return
|
|
|
442 (File : System.Address; Line : Integer);
|
|
|
443 procedure Rcheck_PE_Misaligned_Address_Value
|
|
|
444 (File : System.Address; Line : Integer);
|
|
|
445 procedure Rcheck_PE_Missing_Return
|
|
|
446 (File : System.Address; Line : Integer);
|
|
|
447 procedure Rcheck_PE_Non_Transportable_Actual
|
|
|
448 (File : System.Address; Line : Integer);
|
|
|
449 procedure Rcheck_PE_Overlaid_Controlled_Object
|
|
|
450 (File : System.Address; Line : Integer);
|
|
|
451 procedure Rcheck_PE_Potentially_Blocking_Operation
|
|
|
452 (File : System.Address; Line : Integer);
|
|
|
453 procedure Rcheck_PE_Stubbed_Subprogram_Called
|
|
|
454 (File : System.Address; Line : Integer);
|
|
|
455 procedure Rcheck_PE_Unchecked_Union_Restriction
|
|
|
456 (File : System.Address; Line : Integer);
|
|
|
457 procedure Rcheck_SE_Empty_Storage_Pool
|
|
|
458 (File : System.Address; Line : Integer);
|
|
|
459 procedure Rcheck_SE_Explicit_Raise
|
|
|
460 (File : System.Address; Line : Integer);
|
|
|
461 procedure Rcheck_SE_Infinite_Recursion
|
|
|
462 (File : System.Address; Line : Integer);
|
|
|
463 procedure Rcheck_SE_Object_Too_Large
|
|
|
464 (File : System.Address; Line : Integer);
|
|
|
465 procedure Rcheck_PE_Stream_Operation_Not_Allowed
|
|
|
466 (File : System.Address; Line : Integer);
|
|
|
467 procedure Rcheck_CE_Access_Check_Ext
|
|
|
468 (File : System.Address; Line, Column : Integer);
|
|
|
469 procedure Rcheck_CE_Index_Check_Ext
|
|
|
470 (File : System.Address; Line, Column, Index, First, Last : Integer);
|
|
|
471 procedure Rcheck_CE_Invalid_Data_Ext
|
|
|
472 (File : System.Address; Line, Column, Index, First, Last : Integer);
|
|
|
473 procedure Rcheck_CE_Range_Check_Ext
|
|
|
474 (File : System.Address; Line, Column, Index, First, Last : Integer);
|
|
|
475
|
|
|
476 procedure Rcheck_PE_Finalize_Raised_Exception
|
|
|
477 (File : System.Address; Line : Integer);
|
|
|
478 -- This routine is separated out because it has quite different behavior
|
|
|
479 -- from the others. This is the "finalize/adjust raised exception". This
|
|
|
480 -- subprogram is always called with abort deferred, unlike all other
|
|
|
481 -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer.
|
|
|
482
|
|
|
483 pragma Export (C, Rcheck_CE_Access_Check,
|
|
|
484 "__gnat_rcheck_CE_Access_Check");
|
|
|
485 pragma Export (C, Rcheck_CE_Null_Access_Parameter,
|
|
|
486 "__gnat_rcheck_CE_Null_Access_Parameter");
|
|
|
487 pragma Export (C, Rcheck_CE_Discriminant_Check,
|
|
|
488 "__gnat_rcheck_CE_Discriminant_Check");
|
|
|
489 pragma Export (C, Rcheck_CE_Divide_By_Zero,
|
|
|
490 "__gnat_rcheck_CE_Divide_By_Zero");
|
|
|
491 pragma Export (C, Rcheck_CE_Explicit_Raise,
|
|
|
492 "__gnat_rcheck_CE_Explicit_Raise");
|
|
|
493 pragma Export (C, Rcheck_CE_Index_Check,
|
|
|
494 "__gnat_rcheck_CE_Index_Check");
|
|
|
495 pragma Export (C, Rcheck_CE_Invalid_Data,
|
|
|
496 "__gnat_rcheck_CE_Invalid_Data");
|
|
|
497 pragma Export (C, Rcheck_CE_Length_Check,
|
|
|
498 "__gnat_rcheck_CE_Length_Check");
|
|
|
499 pragma Export (C, Rcheck_CE_Null_Exception_Id,
|
|
|
500 "__gnat_rcheck_CE_Null_Exception_Id");
|
|
|
501 pragma Export (C, Rcheck_CE_Null_Not_Allowed,
|
|
|
502 "__gnat_rcheck_CE_Null_Not_Allowed");
|
|
|
503 pragma Export (C, Rcheck_CE_Overflow_Check,
|
|
|
504 "__gnat_rcheck_CE_Overflow_Check");
|
|
|
505 pragma Export (C, Rcheck_CE_Partition_Check,
|
|
|
506 "__gnat_rcheck_CE_Partition_Check");
|
|
|
507 pragma Export (C, Rcheck_CE_Range_Check,
|
|
|
508 "__gnat_rcheck_CE_Range_Check");
|
|
|
509 pragma Export (C, Rcheck_CE_Tag_Check,
|
|
|
510 "__gnat_rcheck_CE_Tag_Check");
|
|
|
511 pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
|
|
|
512 "__gnat_rcheck_PE_Access_Before_Elaboration");
|
|
|
513 pragma Export (C, Rcheck_PE_Accessibility_Check,
|
|
|
514 "__gnat_rcheck_PE_Accessibility_Check");
|
|
|
515 pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
|
|
|
516 "__gnat_rcheck_PE_Address_Of_Intrinsic");
|
|
|
517 pragma Export (C, Rcheck_PE_Aliased_Parameters,
|
|
|
518 "__gnat_rcheck_PE_Aliased_Parameters");
|
|
|
519 pragma Export (C, Rcheck_PE_All_Guards_Closed,
|
|
|
520 "__gnat_rcheck_PE_All_Guards_Closed");
|
|
|
521 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
|
|
|
522 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
|
|
|
523 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
|
|
|
524 "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
|
|
|
525 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
|
|
|
526 "__gnat_rcheck_PE_Duplicated_Entry_Address");
|
|
|
527 pragma Export (C, Rcheck_PE_Explicit_Raise,
|
|
|
528 "__gnat_rcheck_PE_Explicit_Raise");
|
|
|
529 pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
|
|
|
530 "__gnat_rcheck_PE_Finalize_Raised_Exception");
|
|
|
531 pragma Export (C, Rcheck_PE_Implicit_Return,
|
|
|
532 "__gnat_rcheck_PE_Implicit_Return");
|
|
|
533 pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
|
|
|
534 "__gnat_rcheck_PE_Misaligned_Address_Value");
|
|
|
535 pragma Export (C, Rcheck_PE_Missing_Return,
|
|
|
536 "__gnat_rcheck_PE_Missing_Return");
|
|
|
537 pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
|
|
|
538 "__gnat_rcheck_PE_Non_Transportable_Actual");
|
|
|
539 pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
|
|
|
540 "__gnat_rcheck_PE_Overlaid_Controlled_Object");
|
|
|
541 pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
|
|
|
542 "__gnat_rcheck_PE_Potentially_Blocking_Operation");
|
|
|
543 pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
|
|
|
544 "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
|
|
|
545 pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
|
|
|
546 "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
|
|
|
547 pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
|
|
|
548 "__gnat_rcheck_PE_Unchecked_Union_Restriction");
|
|
|
549 pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
|
|
|
550 "__gnat_rcheck_SE_Empty_Storage_Pool");
|
|
|
551 pragma Export (C, Rcheck_SE_Explicit_Raise,
|
|
|
552 "__gnat_rcheck_SE_Explicit_Raise");
|
|
|
553 pragma Export (C, Rcheck_SE_Infinite_Recursion,
|
|
|
554 "__gnat_rcheck_SE_Infinite_Recursion");
|
|
|
555 pragma Export (C, Rcheck_SE_Object_Too_Large,
|
|
|
556 "__gnat_rcheck_SE_Object_Too_Large");
|
|
|
557
|
|
|
558 pragma Export (C, Rcheck_CE_Access_Check_Ext,
|
|
|
559 "__gnat_rcheck_CE_Access_Check_ext");
|
|
|
560 pragma Export (C, Rcheck_CE_Index_Check_Ext,
|
|
|
561 "__gnat_rcheck_CE_Index_Check_ext");
|
|
|
562 pragma Export (C, Rcheck_CE_Invalid_Data_Ext,
|
|
|
563 "__gnat_rcheck_CE_Invalid_Data_ext");
|
|
|
564 pragma Export (C, Rcheck_CE_Range_Check_Ext,
|
|
|
565 "__gnat_rcheck_CE_Range_Check_ext");
|
|
|
566
|
|
|
567 -- None of these procedures ever returns (they raise an exception). By
|
|
|
568 -- using pragma No_Return, we ensure that any junk code after the call,
|
|
|
569 -- such as normal return epilogue stuff, can be eliminated).
|
|
|
570
|
|
|
571 pragma No_Return (Rcheck_CE_Access_Check);
|
|
|
572 pragma No_Return (Rcheck_CE_Null_Access_Parameter);
|
|
|
573 pragma No_Return (Rcheck_CE_Discriminant_Check);
|
|
|
574 pragma No_Return (Rcheck_CE_Divide_By_Zero);
|
|
|
575 pragma No_Return (Rcheck_CE_Explicit_Raise);
|
|
|
576 pragma No_Return (Rcheck_CE_Index_Check);
|
|
|
577 pragma No_Return (Rcheck_CE_Invalid_Data);
|
|
|
578 pragma No_Return (Rcheck_CE_Length_Check);
|
|
|
579 pragma No_Return (Rcheck_CE_Null_Exception_Id);
|
|
|
580 pragma No_Return (Rcheck_CE_Null_Not_Allowed);
|
|
|
581 pragma No_Return (Rcheck_CE_Overflow_Check);
|
|
|
582 pragma No_Return (Rcheck_CE_Partition_Check);
|
|
|
583 pragma No_Return (Rcheck_CE_Range_Check);
|
|
|
584 pragma No_Return (Rcheck_CE_Tag_Check);
|
|
|
585 pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
|
|
|
586 pragma No_Return (Rcheck_PE_Accessibility_Check);
|
|
|
587 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
|
|
|
588 pragma No_Return (Rcheck_PE_Aliased_Parameters);
|
|
|
589 pragma No_Return (Rcheck_PE_All_Guards_Closed);
|
|
|
590 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
|
|
|
591 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
|
|
|
592 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
|
|
|
593 pragma No_Return (Rcheck_PE_Explicit_Raise);
|
|
|
594 pragma No_Return (Rcheck_PE_Implicit_Return);
|
|
|
595 pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
|
|
|
596 pragma No_Return (Rcheck_PE_Missing_Return);
|
|
|
597 pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
|
|
|
598 pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
|
|
|
599 pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
|
|
|
600 pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
|
|
|
601 pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
|
|
|
602 pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
|
|
|
603 pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
|
|
|
604 pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
|
|
|
605 pragma No_Return (Rcheck_SE_Explicit_Raise);
|
|
|
606 pragma No_Return (Rcheck_SE_Infinite_Recursion);
|
|
|
607 pragma No_Return (Rcheck_SE_Object_Too_Large);
|
|
|
608
|
|
|
609 pragma No_Return (Rcheck_CE_Access_Check_Ext);
|
|
|
610 pragma No_Return (Rcheck_CE_Index_Check_Ext);
|
|
|
611 pragma No_Return (Rcheck_CE_Invalid_Data_Ext);
|
|
|
612 pragma No_Return (Rcheck_CE_Range_Check_Ext);
|
|
|
613
|
|
|
614 ---------------------------------------------
|
|
|
615 -- Reason Strings for Run-Time Check Calls --
|
|
|
616 ---------------------------------------------
|
|
|
617
|
|
|
618 -- These strings are null-terminated and are used by Rcheck_nn. The
|
|
|
619 -- strings correspond to the definitions for Types.RT_Exception_Code.
|
|
|
620
|
|
|
621 use ASCII;
|
|
|
622
|
|
|
623 Rmsg_00 : constant String := "access check failed" & NUL;
|
|
|
624 Rmsg_01 : constant String := "access parameter is null" & NUL;
|
|
|
625 Rmsg_02 : constant String := "discriminant check failed" & NUL;
|
|
|
626 Rmsg_03 : constant String := "divide by zero" & NUL;
|
|
|
627 Rmsg_04 : constant String := "explicit raise" & NUL;
|
|
|
628 Rmsg_05 : constant String := "index check failed" & NUL;
|
|
|
629 Rmsg_06 : constant String := "invalid data" & NUL;
|
|
|
630 Rmsg_07 : constant String := "length check failed" & NUL;
|
|
|
631 Rmsg_08 : constant String := "null Exception_Id" & NUL;
|
|
|
632 Rmsg_09 : constant String := "null-exclusion check failed" & NUL;
|
|
|
633 Rmsg_10 : constant String := "overflow check failed" & NUL;
|
|
|
634 Rmsg_11 : constant String := "partition check failed" & NUL;
|
|
|
635 Rmsg_12 : constant String := "range check failed" & NUL;
|
|
|
636 Rmsg_13 : constant String := "tag check failed" & NUL;
|
|
|
637 Rmsg_14 : constant String := "access before elaboration" & NUL;
|
|
|
638 Rmsg_15 : constant String := "accessibility check failed" & NUL;
|
|
|
639 Rmsg_16 : constant String := "attempt to take address of" &
|
|
|
640 " intrinsic subprogram" & NUL;
|
|
|
641 Rmsg_17 : constant String := "aliased parameters" & NUL;
|
|
|
642 Rmsg_18 : constant String := "all guards closed" & NUL;
|
|
|
643 Rmsg_19 : constant String := "improper use of generic subtype" &
|
|
|
644 " with predicate" & NUL;
|
|
|
645 Rmsg_20 : constant String := "Current_Task referenced in entry" &
|
|
|
646 " body" & NUL;
|
|
|
647 Rmsg_21 : constant String := "duplicated entry address" & NUL;
|
|
|
648 Rmsg_22 : constant String := "explicit raise" & NUL;
|
|
|
649 Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL;
|
|
|
650 Rmsg_24 : constant String := "implicit return with No_Return" & NUL;
|
|
|
651 Rmsg_25 : constant String := "misaligned address value" & NUL;
|
|
|
652 Rmsg_26 : constant String := "missing return" & NUL;
|
|
|
653 Rmsg_27 : constant String := "overlaid controlled object" & NUL;
|
|
|
654 Rmsg_28 : constant String := "potentially blocking operation" & NUL;
|
|
|
655 Rmsg_29 : constant String := "stubbed subprogram called" & NUL;
|
|
|
656 Rmsg_30 : constant String := "unchecked union restriction" & NUL;
|
|
|
657 Rmsg_31 : constant String := "actual/returned class-wide" &
|
|
|
658 " value not transportable" & NUL;
|
|
|
659 Rmsg_32 : constant String := "empty storage pool" & NUL;
|
|
|
660 Rmsg_33 : constant String := "explicit raise" & NUL;
|
|
|
661 Rmsg_34 : constant String := "infinite recursion" & NUL;
|
|
|
662 Rmsg_35 : constant String := "object too large" & NUL;
|
|
|
663 Rmsg_36 : constant String := "stream operation not allowed" & NUL;
|
|
|
664
|
|
|
665 -----------------------
|
|
|
666 -- Polling Interface --
|
|
|
667 -----------------------
|
|
|
668
|
|
|
669 type Unsigned is mod 2 ** 32;
|
|
|
670
|
|
|
671 Counter : Unsigned := 0;
|
|
|
672 pragma Warnings (Off, Counter);
|
|
|
673 -- This counter is provided for convenience. It can be used in Poll to
|
|
|
674 -- perform periodic but not systematic operations.
|
|
|
675
|
|
|
676 procedure Poll is separate;
|
|
|
677 -- The actual polling routine is separate, so that it can easily be
|
|
|
678 -- replaced with a target dependent version.
|
|
|
679
|
|
|
680 --------------------------
|
|
|
681 -- Code_Address_For_AAA --
|
|
|
682 --------------------------
|
|
|
683
|
|
|
684 -- This function gives us the start of the PC range for addresses within
|
|
|
685 -- the exception unit itself. We hope that gigi/gcc keep all the procedures
|
|
|
686 -- in their original order.
|
|
|
687
|
|
|
688 function Code_Address_For_AAA return System.Address is
|
|
|
689 begin
|
|
|
690 -- We are using a label instead of Code_Address_For_AAA'Address because
|
|
|
691 -- on some platforms the latter does not yield the address we want, but
|
|
|
692 -- the address of a stub or of a descriptor instead. This is the case at
|
|
|
693 -- least on PA-HPUX.
|
|
|
694
|
|
|
695 <<Start_Of_AAA>>
|
|
|
696 return Start_Of_AAA'Address;
|
|
|
697 end Code_Address_For_AAA;
|
|
|
698
|
|
|
699 ----------------
|
|
|
700 -- Call_Chain --
|
|
|
701 ----------------
|
|
|
702
|
|
|
703 procedure Call_Chain (Excep : EOA) is separate;
|
|
|
704 -- The actual Call_Chain routine is separate, so that it can easily
|
|
|
705 -- be dummied out when no exception traceback information is needed.
|
|
|
706
|
|
|
707 -------------------
|
|
|
708 -- EId_To_String --
|
|
|
709 -------------------
|
|
|
710
|
|
|
711 function EId_To_String (X : Exception_Id) return String
|
|
|
712 renames Stream_Attributes.EId_To_String;
|
|
|
713
|
|
|
714 ------------------
|
|
|
715 -- EO_To_String --
|
|
|
716 ------------------
|
|
|
717
|
|
|
718 -- We use the null string to represent the null occurrence, otherwise we
|
|
|
719 -- output the Untailored_Exception_Information string for the occurrence.
|
|
|
720
|
|
|
721 function EO_To_String (X : Exception_Occurrence) return String
|
|
|
722 renames Stream_Attributes.EO_To_String;
|
|
|
723
|
|
|
724 ------------------------
|
|
|
725 -- Exception_Identity --
|
|
|
726 ------------------------
|
|
|
727
|
|
|
728 function Exception_Identity
|
|
|
729 (X : Exception_Occurrence) return Exception_Id
|
|
|
730 is
|
|
|
731 begin
|
|
|
732 -- Note that the following test used to be here for the original
|
|
|
733 -- Ada 95 semantics, but these were modified by AI-241 to require
|
|
|
734 -- returning Null_Id instead of raising Constraint_Error.
|
|
|
735
|
|
|
736 -- if X.Id = Null_Id then
|
|
|
737 -- raise Constraint_Error;
|
|
|
738 -- end if;
|
|
|
739
|
|
|
740 return X.Id;
|
|
|
741 end Exception_Identity;
|
|
|
742
|
|
|
743 ---------------------------
|
|
|
744 -- Exception_Information --
|
|
|
745 ---------------------------
|
|
|
746
|
|
|
747 function Exception_Information (X : Exception_Occurrence) return String is
|
|
|
748 begin
|
|
|
749 if X.Id = Null_Id then
|
|
|
750 raise Constraint_Error;
|
|
|
751 else
|
|
|
752 return Exception_Data.Exception_Information (X);
|
|
|
753 end if;
|
|
|
754 end Exception_Information;
|
|
|
755
|
|
|
756 -----------------------
|
|
|
757 -- Exception_Message --
|
|
|
758 -----------------------
|
|
|
759
|
|
|
760 function Exception_Message (X : Exception_Occurrence) return String is
|
|
|
761 begin
|
|
|
762 if X.Id = Null_Id then
|
|
|
763 raise Constraint_Error;
|
|
|
764 else
|
|
|
765 return X.Msg (1 .. X.Msg_Length);
|
|
|
766 end if;
|
|
|
767 end Exception_Message;
|
|
|
768
|
|
|
769 --------------------
|
|
|
770 -- Exception_Name --
|
|
|
771 --------------------
|
|
|
772
|
|
|
773 function Exception_Name (Id : Exception_Id) return String is
|
|
|
774 begin
|
|
|
775 if Id = null then
|
|
|
776 raise Constraint_Error;
|
|
|
777 else
|
|
|
778 return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
|
|
|
779 end if;
|
|
|
780 end Exception_Name;
|
|
|
781
|
|
|
782 function Exception_Name (X : Exception_Occurrence) return String is
|
|
|
783 begin
|
|
|
784 return Exception_Name (X.Id);
|
|
|
785 end Exception_Name;
|
|
|
786
|
|
|
787 ---------------------------
|
|
|
788 -- Exception_Name_Simple --
|
|
|
789 ---------------------------
|
|
|
790
|
|
|
791 function Exception_Name_Simple (X : Exception_Occurrence) return String is
|
|
|
792 Name : constant String := Exception_Name (X);
|
|
|
793 P : Natural;
|
|
|
794
|
|
|
795 begin
|
|
|
796 P := Name'Length;
|
|
|
797 while P > 1 loop
|
|
|
798 exit when Name (P - 1) = '.';
|
|
|
799 P := P - 1;
|
|
|
800 end loop;
|
|
|
801
|
|
|
802 -- Return result making sure lower bound is 1
|
|
|
803
|
|
|
804 declare
|
|
|
805 subtype Rname is String (1 .. Name'Length - P + 1);
|
|
|
806 begin
|
|
|
807 return Rname (Name (P .. Name'Length));
|
|
|
808 end;
|
|
|
809 end Exception_Name_Simple;
|
|
|
810
|
|
|
811 --------------------
|
|
|
812 -- Exception_Data --
|
|
|
813 --------------------
|
|
|
814
|
|
|
815 package body Exception_Data is separate;
|
|
|
816 -- This package can be easily dummied out if we do not want the basic
|
|
|
817 -- support for exception messages (such as in Ada 83).
|
|
|
818
|
|
|
819 ---------------------------
|
|
|
820 -- Exception_Propagation --
|
|
|
821 ---------------------------
|
|
|
822
|
|
|
823 package body Exception_Propagation is separate;
|
|
|
824 -- Depending on the actual exception mechanism used (front-end or
|
|
|
825 -- back-end based), the implementation will differ, which is why this
|
|
|
826 -- package is separated.
|
|
|
827
|
|
|
828 ----------------------
|
|
|
829 -- Exception_Traces --
|
|
|
830 ----------------------
|
|
|
831
|
|
|
832 package body Exception_Traces is separate;
|
|
|
833 -- Depending on the underlying support for IO the implementation will
|
|
|
834 -- differ. Moreover we would like to dummy out this package in case we
|
|
|
835 -- do not want any exception tracing support. This is why this package
|
|
|
836 -- is separated.
|
|
|
837
|
|
|
838 --------------------------------------
|
|
|
839 -- Get_Exception_Machine_Occurrence --
|
|
|
840 --------------------------------------
|
|
|
841
|
|
|
842 function Get_Exception_Machine_Occurrence
|
|
|
843 (X : Exception_Occurrence) return System.Address
|
|
|
844 is
|
|
|
845 begin
|
|
|
846 return X.Machine_Occurrence;
|
|
|
847 end Get_Exception_Machine_Occurrence;
|
|
|
848
|
|
|
849 -----------
|
|
|
850 -- Image --
|
|
|
851 -----------
|
|
|
852
|
|
|
853 function Image (Index : Integer) return String is
|
|
|
854 Result : constant String := Integer'Image (Index);
|
|
|
855 begin
|
|
|
856 if Result (1) = ' ' then
|
|
|
857 return Result (2 .. Result'Last);
|
|
|
858 else
|
|
|
859 return Result;
|
|
|
860 end if;
|
|
|
861 end Image;
|
|
|
862
|
|
|
863 -----------------------
|
|
|
864 -- Stream Attributes --
|
|
|
865 -----------------------
|
|
|
866
|
|
|
867 package body Stream_Attributes is separate;
|
|
|
868 -- This package can be easily dummied out if we do not want the
|
|
|
869 -- support for streaming Exception_Ids and Exception_Occurrences.
|
|
|
870
|
|
|
871 ----------------------------
|
|
|
872 -- Raise_Constraint_Error --
|
|
|
873 ----------------------------
|
|
|
874
|
|
|
875 procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
|
|
|
876 begin
|
|
|
877 Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line);
|
|
|
878 end Raise_Constraint_Error;
|
|
|
879
|
|
|
880 --------------------------------
|
|
|
881 -- Raise_Constraint_Error_Msg --
|
|
|
882 --------------------------------
|
|
|
883
|
|
|
884 procedure Raise_Constraint_Error_Msg
|
|
|
885 (File : System.Address;
|
|
|
886 Line : Integer;
|
|
|
887 Column : Integer;
|
|
|
888 Msg : System.Address)
|
|
|
889 is
|
|
|
890 begin
|
|
|
891 Raise_With_Location_And_Msg
|
|
|
892 (Constraint_Error_Def'Access, File, Line, Column, Msg);
|
|
|
893 end Raise_Constraint_Error_Msg;
|
|
|
894
|
|
|
895 -------------------------
|
|
|
896 -- Complete_Occurrence --
|
|
|
897 -------------------------
|
|
|
898
|
|
|
899 procedure Complete_Occurrence (X : EOA) is
|
|
|
900 begin
|
|
|
901 -- Compute the backtrace for this occurrence if the corresponding
|
|
|
902 -- binder option has been set. Call_Chain takes care of the reraise
|
|
|
903 -- case.
|
|
|
904
|
|
|
905 -- ??? Using Call_Chain here means we are going to walk up the stack
|
|
|
906 -- once only for backtracing purposes before doing it again for the
|
|
|
907 -- propagation per se.
|
|
|
908
|
|
|
909 -- The first inspection is much lighter, though, as it only requires
|
|
|
910 -- partial unwinding of each frame. Additionally, although we could use
|
|
|
911 -- the personality routine to record the addresses while propagating,
|
|
|
912 -- this method has two drawbacks:
|
|
|
913
|
|
|
914 -- 1) the trace is incomplete if the exception is handled since we
|
|
|
915 -- don't walk past the frame with the handler,
|
|
|
916
|
|
|
917 -- and
|
|
|
918
|
|
|
919 -- 2) we would miss the frames for which our personality routine is not
|
|
|
920 -- called, e.g. if C or C++ calls are on the way.
|
|
|
921
|
|
|
922 Call_Chain (X);
|
|
|
923
|
|
|
924 -- Notify the debugger
|
|
|
925 Debug_Raise_Exception
|
|
|
926 (E => SSL.Exception_Data_Ptr (X.Id),
|
|
|
927 Message => X.Msg (1 .. X.Msg_Length));
|
|
|
928 end Complete_Occurrence;
|
|
|
929
|
|
|
930 ---------------------------------------
|
|
|
931 -- Complete_And_Propagate_Occurrence --
|
|
|
932 ---------------------------------------
|
|
|
933
|
|
|
934 procedure Complete_And_Propagate_Occurrence (X : EOA) is
|
|
|
935 begin
|
|
|
936 Complete_Occurrence (X);
|
|
|
937 Exception_Propagation.Propagate_Exception (X);
|
|
|
938 end Complete_And_Propagate_Occurrence;
|
|
|
939
|
|
|
940 ---------------------
|
|
|
941 -- Raise_Exception --
|
|
|
942 ---------------------
|
|
|
943
|
|
|
944 procedure Raise_Exception
|
|
|
945 (E : Exception_Id;
|
|
|
946 Message : String := "")
|
|
|
947 is
|
|
|
948 EF : Exception_Id := E;
|
|
|
949 begin
|
|
|
950 -- Raise CE if E = Null_ID (AI-446)
|
|
|
951
|
|
|
952 if E = null then
|
|
|
953 EF := Constraint_Error'Identity;
|
|
|
954 end if;
|
|
|
955
|
|
|
956 -- Go ahead and raise appropriate exception
|
|
|
957
|
|
|
958 Raise_Exception_Always (EF, Message);
|
|
|
959 end Raise_Exception;
|
|
|
960
|
|
|
961 ----------------------------
|
|
|
962 -- Raise_Exception_Always --
|
|
|
963 ----------------------------
|
|
|
964
|
|
|
965 procedure Raise_Exception_Always
|
|
|
966 (E : Exception_Id;
|
|
|
967 Message : String := "")
|
|
|
968 is
|
|
|
969 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
970
|
|
|
971 begin
|
|
|
972 Exception_Data.Set_Exception_Msg (X, E, Message);
|
|
|
973
|
|
|
974 if not ZCX_By_Default then
|
|
|
975 Abort_Defer.all;
|
|
|
976 end if;
|
|
|
977
|
|
|
978 Complete_And_Propagate_Occurrence (X);
|
|
|
979 end Raise_Exception_Always;
|
|
|
980
|
|
|
981 ------------------------------
|
|
|
982 -- Raise_Exception_No_Defer --
|
|
|
983 ------------------------------
|
|
|
984
|
|
|
985 procedure Raise_Exception_No_Defer
|
|
|
986 (E : Exception_Id;
|
|
|
987 Message : String := "")
|
|
|
988 is
|
|
|
989 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
990
|
|
|
991 begin
|
|
|
992 Exception_Data.Set_Exception_Msg (X, E, Message);
|
|
|
993
|
|
|
994 -- Do not call Abort_Defer.all, as specified by the spec
|
|
|
995
|
|
|
996 Complete_And_Propagate_Occurrence (X);
|
|
|
997 end Raise_Exception_No_Defer;
|
|
|
998
|
|
|
999 -------------------------------------
|
|
|
1000 -- Raise_From_Controlled_Operation --
|
|
|
1001 -------------------------------------
|
|
|
1002
|
|
|
1003 procedure Raise_From_Controlled_Operation
|
|
|
1004 (X : Ada.Exceptions.Exception_Occurrence)
|
|
|
1005 is
|
|
|
1006 Prefix : constant String := "adjust/finalize raised ";
|
|
|
1007 Orig_Msg : constant String := Exception_Message (X);
|
|
|
1008 Orig_Prefix_Length : constant Natural :=
|
|
|
1009 Integer'Min (Prefix'Length, Orig_Msg'Length);
|
|
|
1010
|
|
|
1011 Orig_Prefix : String renames
|
|
|
1012 Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
|
|
|
1013
|
|
|
1014 begin
|
|
|
1015 -- Message already has the proper prefix, just re-raise
|
|
|
1016
|
|
|
1017 if Orig_Prefix = Prefix then
|
|
|
1018 Raise_Exception_No_Defer
|
|
|
1019 (E => Program_Error'Identity,
|
|
|
1020 Message => Orig_Msg);
|
|
|
1021
|
|
|
1022 else
|
|
|
1023 declare
|
|
|
1024 New_Msg : constant String := Prefix & Exception_Name (X);
|
|
|
1025
|
|
|
1026 begin
|
|
|
1027 -- No message present, just provide our own
|
|
|
1028
|
|
|
1029 if Orig_Msg = "" then
|
|
|
1030 Raise_Exception_No_Defer
|
|
|
1031 (E => Program_Error'Identity,
|
|
|
1032 Message => New_Msg);
|
|
|
1033
|
|
|
1034 -- Message present, add informational prefix
|
|
|
1035
|
|
|
1036 else
|
|
|
1037 Raise_Exception_No_Defer
|
|
|
1038 (E => Program_Error'Identity,
|
|
|
1039 Message => New_Msg & ": " & Orig_Msg);
|
|
|
1040 end if;
|
|
|
1041 end;
|
|
|
1042 end if;
|
|
|
1043 end Raise_From_Controlled_Operation;
|
|
|
1044
|
|
|
1045 -------------------------------------------
|
|
|
1046 -- Create_Occurrence_From_Signal_Handler --
|
|
|
1047 -------------------------------------------
|
|
|
1048
|
|
|
1049 function Create_Occurrence_From_Signal_Handler
|
|
|
1050 (E : Exception_Id;
|
|
|
1051 M : System.Address) return EOA
|
|
|
1052 is
|
|
|
1053 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1054
|
|
|
1055 begin
|
|
|
1056 Exception_Data.Set_Exception_C_Msg (X, E, M);
|
|
|
1057
|
|
|
1058 if not ZCX_By_Default then
|
|
|
1059 Abort_Defer.all;
|
|
|
1060 end if;
|
|
|
1061
|
|
|
1062 Complete_Occurrence (X);
|
|
|
1063 return X;
|
|
|
1064 end Create_Occurrence_From_Signal_Handler;
|
|
|
1065
|
|
|
1066 ---------------------------------------------------
|
|
|
1067 -- Create_Machine_Occurrence_From_Signal_Handler --
|
|
|
1068 ---------------------------------------------------
|
|
|
1069
|
|
|
1070 function Create_Machine_Occurrence_From_Signal_Handler
|
|
|
1071 (E : Exception_Id;
|
|
|
1072 M : System.Address) return System.Address
|
|
|
1073 is
|
|
|
1074 begin
|
|
|
1075 return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence;
|
|
|
1076 end Create_Machine_Occurrence_From_Signal_Handler;
|
|
|
1077
|
|
|
1078 -------------------------------
|
|
|
1079 -- Raise_From_Signal_Handler --
|
|
|
1080 -------------------------------
|
|
|
1081
|
|
|
1082 procedure Raise_From_Signal_Handler
|
|
|
1083 (E : Exception_Id;
|
|
|
1084 M : System.Address)
|
|
|
1085 is
|
|
|
1086 begin
|
|
|
1087 Exception_Propagation.Propagate_Exception
|
|
|
1088 (Create_Occurrence_From_Signal_Handler (E, M));
|
|
|
1089 end Raise_From_Signal_Handler;
|
|
|
1090
|
|
|
1091 -------------------------
|
|
|
1092 -- Raise_Program_Error --
|
|
|
1093 -------------------------
|
|
|
1094
|
|
|
1095 procedure Raise_Program_Error
|
|
|
1096 (File : System.Address;
|
|
|
1097 Line : Integer)
|
|
|
1098 is
|
|
|
1099 begin
|
|
|
1100 Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line);
|
|
|
1101 end Raise_Program_Error;
|
|
|
1102
|
|
|
1103 -----------------------------
|
|
|
1104 -- Raise_Program_Error_Msg --
|
|
|
1105 -----------------------------
|
|
|
1106
|
|
|
1107 procedure Raise_Program_Error_Msg
|
|
|
1108 (File : System.Address;
|
|
|
1109 Line : Integer;
|
|
|
1110 Msg : System.Address)
|
|
|
1111 is
|
|
|
1112 begin
|
|
|
1113 Raise_With_Location_And_Msg
|
|
|
1114 (Program_Error_Def'Access, File, Line, M => Msg);
|
|
|
1115 end Raise_Program_Error_Msg;
|
|
|
1116
|
|
|
1117 -------------------------
|
|
|
1118 -- Raise_Storage_Error --
|
|
|
1119 -------------------------
|
|
|
1120
|
|
|
1121 procedure Raise_Storage_Error
|
|
|
1122 (File : System.Address;
|
|
|
1123 Line : Integer)
|
|
|
1124 is
|
|
|
1125 begin
|
|
|
1126 Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line);
|
|
|
1127 end Raise_Storage_Error;
|
|
|
1128
|
|
|
1129 -----------------------------
|
|
|
1130 -- Raise_Storage_Error_Msg --
|
|
|
1131 -----------------------------
|
|
|
1132
|
|
|
1133 procedure Raise_Storage_Error_Msg
|
|
|
1134 (File : System.Address;
|
|
|
1135 Line : Integer;
|
|
|
1136 Msg : System.Address)
|
|
|
1137 is
|
|
|
1138 begin
|
|
|
1139 Raise_With_Location_And_Msg
|
|
|
1140 (Storage_Error_Def'Access, File, Line, M => Msg);
|
|
|
1141 end Raise_Storage_Error_Msg;
|
|
|
1142
|
|
|
1143 ---------------------------------
|
|
|
1144 -- Raise_With_Location_And_Msg --
|
|
|
1145 ---------------------------------
|
|
|
1146
|
|
|
1147 procedure Raise_With_Location_And_Msg
|
|
|
1148 (E : Exception_Id;
|
|
|
1149 F : System.Address;
|
|
|
1150 L : Integer;
|
|
|
1151 C : Integer := 0;
|
|
|
1152 M : System.Address := System.Null_Address)
|
|
|
1153 is
|
|
|
1154 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1155 begin
|
|
|
1156 Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M);
|
|
|
1157
|
|
|
1158 if not ZCX_By_Default then
|
|
|
1159 Abort_Defer.all;
|
|
|
1160 end if;
|
|
|
1161
|
|
|
1162 Complete_And_Propagate_Occurrence (X);
|
|
|
1163 end Raise_With_Location_And_Msg;
|
|
|
1164
|
|
|
1165 --------------------
|
|
|
1166 -- Raise_With_Msg --
|
|
|
1167 --------------------
|
|
|
1168
|
|
|
1169 procedure Raise_With_Msg (E : Exception_Id) is
|
|
|
1170 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1171 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
|
|
|
1172 begin
|
|
|
1173 Excep.Exception_Raised := False;
|
|
|
1174 Excep.Id := E;
|
|
|
1175 Excep.Num_Tracebacks := 0;
|
|
|
1176 Excep.Pid := Local_Partition_ID;
|
|
|
1177
|
|
|
1178 -- Copy the message from the current exception
|
|
|
1179 -- Change the interface to be called with an occurrence ???
|
|
|
1180
|
|
|
1181 Excep.Msg_Length := Ex.Msg_Length;
|
|
|
1182 Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length);
|
|
|
1183
|
|
|
1184 -- The following is a common pattern, should be abstracted
|
|
|
1185 -- into a procedure call ???
|
|
|
1186
|
|
|
1187 if not ZCX_By_Default then
|
|
|
1188 Abort_Defer.all;
|
|
|
1189 end if;
|
|
|
1190
|
|
|
1191 Complete_And_Propagate_Occurrence (Excep);
|
|
|
1192 end Raise_With_Msg;
|
|
|
1193
|
|
|
1194 -----------------------------------------
|
|
|
1195 -- Calls to Run-Time Check Subprograms --
|
|
|
1196 -----------------------------------------
|
|
|
1197
|
|
|
1198 procedure Rcheck_CE_Access_Check
|
|
|
1199 (File : System.Address; Line : Integer)
|
|
|
1200 is
|
|
|
1201 begin
|
|
|
1202 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address);
|
|
|
1203 end Rcheck_CE_Access_Check;
|
|
|
1204
|
|
|
1205 procedure Rcheck_CE_Null_Access_Parameter
|
|
|
1206 (File : System.Address; Line : Integer)
|
|
|
1207 is
|
|
|
1208 begin
|
|
|
1209 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address);
|
|
|
1210 end Rcheck_CE_Null_Access_Parameter;
|
|
|
1211
|
|
|
1212 procedure Rcheck_CE_Discriminant_Check
|
|
|
1213 (File : System.Address; Line : Integer)
|
|
|
1214 is
|
|
|
1215 begin
|
|
|
1216 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address);
|
|
|
1217 end Rcheck_CE_Discriminant_Check;
|
|
|
1218
|
|
|
1219 procedure Rcheck_CE_Divide_By_Zero
|
|
|
1220 (File : System.Address; Line : Integer)
|
|
|
1221 is
|
|
|
1222 begin
|
|
|
1223 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address);
|
|
|
1224 end Rcheck_CE_Divide_By_Zero;
|
|
|
1225
|
|
|
1226 procedure Rcheck_CE_Explicit_Raise
|
|
|
1227 (File : System.Address; Line : Integer)
|
|
|
1228 is
|
|
|
1229 begin
|
|
|
1230 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address);
|
|
|
1231 end Rcheck_CE_Explicit_Raise;
|
|
|
1232
|
|
|
1233 procedure Rcheck_CE_Index_Check
|
|
|
1234 (File : System.Address; Line : Integer)
|
|
|
1235 is
|
|
|
1236 begin
|
|
|
1237 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address);
|
|
|
1238 end Rcheck_CE_Index_Check;
|
|
|
1239
|
|
|
1240 procedure Rcheck_CE_Invalid_Data
|
|
|
1241 (File : System.Address; Line : Integer)
|
|
|
1242 is
|
|
|
1243 begin
|
|
|
1244 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address);
|
|
|
1245 end Rcheck_CE_Invalid_Data;
|
|
|
1246
|
|
|
1247 procedure Rcheck_CE_Length_Check
|
|
|
1248 (File : System.Address; Line : Integer)
|
|
|
1249 is
|
|
|
1250 begin
|
|
|
1251 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address);
|
|
|
1252 end Rcheck_CE_Length_Check;
|
|
|
1253
|
|
|
1254 procedure Rcheck_CE_Null_Exception_Id
|
|
|
1255 (File : System.Address; Line : Integer)
|
|
|
1256 is
|
|
|
1257 begin
|
|
|
1258 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address);
|
|
|
1259 end Rcheck_CE_Null_Exception_Id;
|
|
|
1260
|
|
|
1261 procedure Rcheck_CE_Null_Not_Allowed
|
|
|
1262 (File : System.Address; Line : Integer)
|
|
|
1263 is
|
|
|
1264 begin
|
|
|
1265 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address);
|
|
|
1266 end Rcheck_CE_Null_Not_Allowed;
|
|
|
1267
|
|
|
1268 procedure Rcheck_CE_Overflow_Check
|
|
|
1269 (File : System.Address; Line : Integer)
|
|
|
1270 is
|
|
|
1271 begin
|
|
|
1272 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address);
|
|
|
1273 end Rcheck_CE_Overflow_Check;
|
|
|
1274
|
|
|
1275 procedure Rcheck_CE_Partition_Check
|
|
|
1276 (File : System.Address; Line : Integer)
|
|
|
1277 is
|
|
|
1278 begin
|
|
|
1279 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address);
|
|
|
1280 end Rcheck_CE_Partition_Check;
|
|
|
1281
|
|
|
1282 procedure Rcheck_CE_Range_Check
|
|
|
1283 (File : System.Address; Line : Integer)
|
|
|
1284 is
|
|
|
1285 begin
|
|
|
1286 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address);
|
|
|
1287 end Rcheck_CE_Range_Check;
|
|
|
1288
|
|
|
1289 procedure Rcheck_CE_Tag_Check
|
|
|
1290 (File : System.Address; Line : Integer)
|
|
|
1291 is
|
|
|
1292 begin
|
|
|
1293 Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
|
|
|
1294 end Rcheck_CE_Tag_Check;
|
|
|
1295
|
|
|
1296 procedure Rcheck_PE_Access_Before_Elaboration
|
|
|
1297 (File : System.Address; Line : Integer)
|
|
|
1298 is
|
|
|
1299 begin
|
|
|
1300 Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
|
|
|
1301 end Rcheck_PE_Access_Before_Elaboration;
|
|
|
1302
|
|
|
1303 procedure Rcheck_PE_Accessibility_Check
|
|
|
1304 (File : System.Address; Line : Integer)
|
|
|
1305 is
|
|
|
1306 begin
|
|
|
1307 Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
|
|
|
1308 end Rcheck_PE_Accessibility_Check;
|
|
|
1309
|
|
|
1310 procedure Rcheck_PE_Address_Of_Intrinsic
|
|
|
1311 (File : System.Address; Line : Integer)
|
|
|
1312 is
|
|
|
1313 begin
|
|
|
1314 Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
|
|
|
1315 end Rcheck_PE_Address_Of_Intrinsic;
|
|
|
1316
|
|
|
1317 procedure Rcheck_PE_Aliased_Parameters
|
|
|
1318 (File : System.Address; Line : Integer)
|
|
|
1319 is
|
|
|
1320 begin
|
|
|
1321 Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
|
|
|
1322 end Rcheck_PE_Aliased_Parameters;
|
|
|
1323
|
|
|
1324 procedure Rcheck_PE_All_Guards_Closed
|
|
|
1325 (File : System.Address; Line : Integer)
|
|
|
1326 is
|
|
|
1327 begin
|
|
|
1328 Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
|
|
|
1329 end Rcheck_PE_All_Guards_Closed;
|
|
|
1330
|
|
|
1331 procedure Rcheck_PE_Bad_Predicated_Generic_Type
|
|
|
1332 (File : System.Address; Line : Integer)
|
|
|
1333 is
|
|
|
1334 begin
|
|
|
1335 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
|
|
|
1336 end Rcheck_PE_Bad_Predicated_Generic_Type;
|
|
|
1337
|
|
|
1338 procedure Rcheck_PE_Current_Task_In_Entry_Body
|
|
|
1339 (File : System.Address; Line : Integer)
|
|
|
1340 is
|
|
|
1341 begin
|
|
|
1342 Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
|
|
|
1343 end Rcheck_PE_Current_Task_In_Entry_Body;
|
|
|
1344
|
|
|
1345 procedure Rcheck_PE_Duplicated_Entry_Address
|
|
|
1346 (File : System.Address; Line : Integer)
|
|
|
1347 is
|
|
|
1348 begin
|
|
|
1349 Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
|
|
|
1350 end Rcheck_PE_Duplicated_Entry_Address;
|
|
|
1351
|
|
|
1352 procedure Rcheck_PE_Explicit_Raise
|
|
|
1353 (File : System.Address; Line : Integer)
|
|
|
1354 is
|
|
|
1355 begin
|
|
|
1356 Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
|
|
|
1357 end Rcheck_PE_Explicit_Raise;
|
|
|
1358
|
|
|
1359 procedure Rcheck_PE_Implicit_Return
|
|
|
1360 (File : System.Address; Line : Integer)
|
|
|
1361 is
|
|
|
1362 begin
|
|
|
1363 Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
|
|
|
1364 end Rcheck_PE_Implicit_Return;
|
|
|
1365
|
|
|
1366 procedure Rcheck_PE_Misaligned_Address_Value
|
|
|
1367 (File : System.Address; Line : Integer)
|
|
|
1368 is
|
|
|
1369 begin
|
|
|
1370 Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
|
|
|
1371 end Rcheck_PE_Misaligned_Address_Value;
|
|
|
1372
|
|
|
1373 procedure Rcheck_PE_Missing_Return
|
|
|
1374 (File : System.Address; Line : Integer)
|
|
|
1375 is
|
|
|
1376 begin
|
|
|
1377 Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
|
|
|
1378 end Rcheck_PE_Missing_Return;
|
|
|
1379
|
|
|
1380 procedure Rcheck_PE_Non_Transportable_Actual
|
|
|
1381 (File : System.Address; Line : Integer)
|
|
|
1382 is
|
|
|
1383 begin
|
|
|
1384 Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
|
|
|
1385 end Rcheck_PE_Non_Transportable_Actual;
|
|
|
1386
|
|
|
1387 procedure Rcheck_PE_Overlaid_Controlled_Object
|
|
|
1388 (File : System.Address; Line : Integer)
|
|
|
1389 is
|
|
|
1390 begin
|
|
|
1391 Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
|
|
|
1392 end Rcheck_PE_Overlaid_Controlled_Object;
|
|
|
1393
|
|
|
1394 procedure Rcheck_PE_Potentially_Blocking_Operation
|
|
|
1395 (File : System.Address; Line : Integer)
|
|
|
1396 is
|
|
|
1397 begin
|
|
|
1398 Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
|
|
|
1399 end Rcheck_PE_Potentially_Blocking_Operation;
|
|
|
1400
|
|
|
1401 procedure Rcheck_PE_Stream_Operation_Not_Allowed
|
|
|
1402 (File : System.Address; Line : Integer)
|
|
|
1403 is
|
|
|
1404 begin
|
|
|
1405 Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
|
|
|
1406 end Rcheck_PE_Stream_Operation_Not_Allowed;
|
|
|
1407
|
|
|
1408 procedure Rcheck_PE_Stubbed_Subprogram_Called
|
|
|
1409 (File : System.Address; Line : Integer)
|
|
|
1410 is
|
|
|
1411 begin
|
|
|
1412 Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
|
|
|
1413 end Rcheck_PE_Stubbed_Subprogram_Called;
|
|
|
1414
|
|
|
1415 procedure Rcheck_PE_Unchecked_Union_Restriction
|
|
|
1416 (File : System.Address; Line : Integer)
|
|
|
1417 is
|
|
|
1418 begin
|
|
|
1419 Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
|
|
|
1420 end Rcheck_PE_Unchecked_Union_Restriction;
|
|
|
1421
|
|
|
1422 procedure Rcheck_SE_Empty_Storage_Pool
|
|
|
1423 (File : System.Address; Line : Integer)
|
|
|
1424 is
|
|
|
1425 begin
|
|
|
1426 Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
|
|
|
1427 end Rcheck_SE_Empty_Storage_Pool;
|
|
|
1428
|
|
|
1429 procedure Rcheck_SE_Explicit_Raise
|
|
|
1430 (File : System.Address; Line : Integer)
|
|
|
1431 is
|
|
|
1432 begin
|
|
|
1433 Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
|
|
|
1434 end Rcheck_SE_Explicit_Raise;
|
|
|
1435
|
|
|
1436 procedure Rcheck_SE_Infinite_Recursion
|
|
|
1437 (File : System.Address; Line : Integer)
|
|
|
1438 is
|
|
|
1439 begin
|
|
|
1440 Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
|
|
|
1441 end Rcheck_SE_Infinite_Recursion;
|
|
|
1442
|
|
|
1443 procedure Rcheck_SE_Object_Too_Large
|
|
|
1444 (File : System.Address; Line : Integer)
|
|
|
1445 is
|
|
|
1446 begin
|
|
|
1447 Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
|
|
|
1448 end Rcheck_SE_Object_Too_Large;
|
|
|
1449
|
|
|
1450 procedure Rcheck_CE_Access_Check_Ext
|
|
|
1451 (File : System.Address; Line, Column : Integer)
|
|
|
1452 is
|
|
|
1453 begin
|
|
|
1454 Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);
|
|
|
1455 end Rcheck_CE_Access_Check_Ext;
|
|
|
1456
|
|
|
1457 procedure Rcheck_CE_Index_Check_Ext
|
|
|
1458 (File : System.Address; Line, Column, Index, First, Last : Integer)
|
|
|
1459 is
|
|
|
1460 Msg : constant String :=
|
|
|
1461 Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF
|
|
|
1462 & "index " & Image (Index) & " not in " & Image (First)
|
|
|
1463 & ".." & Image (Last) & ASCII.NUL;
|
|
|
1464 begin
|
|
|
1465 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
|
|
|
1466 end Rcheck_CE_Index_Check_Ext;
|
|
|
1467
|
|
|
1468 procedure Rcheck_CE_Invalid_Data_Ext
|
|
|
1469 (File : System.Address; Line, Column, Index, First, Last : Integer)
|
|
|
1470 is
|
|
|
1471 Msg : constant String :=
|
|
|
1472 Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF
|
|
|
1473 & "value " & Image (Index) & " not in " & Image (First)
|
|
|
1474 & ".." & Image (Last) & ASCII.NUL;
|
|
|
1475 begin
|
|
|
1476 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
|
|
|
1477 end Rcheck_CE_Invalid_Data_Ext;
|
|
|
1478
|
|
|
1479 procedure Rcheck_CE_Range_Check_Ext
|
|
|
1480 (File : System.Address; Line, Column, Index, First, Last : Integer)
|
|
|
1481 is
|
|
|
1482 Msg : constant String :=
|
|
|
1483 Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF
|
|
|
1484 & "value " & Image (Index) & " not in " & Image (First)
|
|
|
1485 & ".." & Image (Last) & ASCII.NUL;
|
|
|
1486 begin
|
|
|
1487 Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
|
|
|
1488 end Rcheck_CE_Range_Check_Ext;
|
|
|
1489
|
|
|
1490 procedure Rcheck_PE_Finalize_Raised_Exception
|
|
|
1491 (File : System.Address; Line : Integer)
|
|
|
1492 is
|
|
|
1493 X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1494
|
|
|
1495 begin
|
|
|
1496 -- This is "finalize/adjust raised exception". This subprogram is always
|
|
|
1497 -- called with abort deferred, unlike all other Rcheck_* subprograms, it
|
|
|
1498 -- needs to call Raise_Exception_No_Defer.
|
|
|
1499
|
|
|
1500 -- This is consistent with Raise_From_Controlled_Operation
|
|
|
1501
|
|
|
1502 Exception_Data.Set_Exception_C_Msg
|
|
|
1503 (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address);
|
|
|
1504 Complete_And_Propagate_Occurrence (X);
|
|
|
1505 end Rcheck_PE_Finalize_Raised_Exception;
|
|
|
1506
|
|
|
1507 -------------
|
|
|
1508 -- Reraise --
|
|
|
1509 -------------
|
|
|
1510
|
|
|
1511 procedure Reraise is
|
|
|
1512 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1513 Saved_MO : constant System.Address := Excep.Machine_Occurrence;
|
|
|
1514
|
|
|
1515 begin
|
|
|
1516 if not ZCX_By_Default then
|
|
|
1517 Abort_Defer.all;
|
|
|
1518 end if;
|
|
|
1519
|
|
|
1520 Save_Occurrence (Excep.all, Get_Current_Excep.all.all);
|
|
|
1521 Excep.Machine_Occurrence := Saved_MO;
|
|
|
1522 Complete_And_Propagate_Occurrence (Excep);
|
|
|
1523 end Reraise;
|
|
|
1524
|
|
|
1525 --------------------------------------
|
|
|
1526 -- Reraise_Library_Exception_If_Any --
|
|
|
1527 --------------------------------------
|
|
|
1528
|
|
|
1529 procedure Reraise_Library_Exception_If_Any is
|
|
|
1530 LE : Exception_Occurrence;
|
|
|
1531
|
|
|
1532 begin
|
|
|
1533 if Library_Exception_Set then
|
|
|
1534 LE := Library_Exception;
|
|
|
1535
|
|
|
1536 if LE.Id = Null_Id then
|
|
|
1537 Raise_Exception_No_Defer
|
|
|
1538 (E => Program_Error'Identity,
|
|
|
1539 Message => "finalize/adjust raised exception");
|
|
|
1540 else
|
|
|
1541 Raise_From_Controlled_Operation (LE);
|
|
|
1542 end if;
|
|
|
1543 end if;
|
|
|
1544 end Reraise_Library_Exception_If_Any;
|
|
|
1545
|
|
|
1546 ------------------------
|
|
|
1547 -- Reraise_Occurrence --
|
|
|
1548 ------------------------
|
|
|
1549
|
|
|
1550 procedure Reraise_Occurrence (X : Exception_Occurrence) is
|
|
|
1551 begin
|
|
|
1552 if X.Id = null then
|
|
|
1553 return;
|
|
|
1554 else
|
|
|
1555 Reraise_Occurrence_Always (X);
|
|
|
1556 end if;
|
|
|
1557 end Reraise_Occurrence;
|
|
|
1558
|
|
|
1559 -------------------------------
|
|
|
1560 -- Reraise_Occurrence_Always --
|
|
|
1561 -------------------------------
|
|
|
1562
|
|
|
1563 procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
|
|
|
1564 begin
|
|
|
1565 if not ZCX_By_Default then
|
|
|
1566 Abort_Defer.all;
|
|
|
1567 end if;
|
|
|
1568
|
|
|
1569 Reraise_Occurrence_No_Defer (X);
|
|
|
1570 end Reraise_Occurrence_Always;
|
|
|
1571
|
|
|
1572 ---------------------------------
|
|
|
1573 -- Reraise_Occurrence_No_Defer --
|
|
|
1574 ---------------------------------
|
|
|
1575
|
|
|
1576 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
|
|
|
1577 Excep : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
|
|
1578 Saved_MO : constant System.Address := Excep.Machine_Occurrence;
|
|
|
1579 begin
|
|
|
1580 Save_Occurrence (Excep.all, X);
|
|
|
1581 Excep.Machine_Occurrence := Saved_MO;
|
|
|
1582 Complete_And_Propagate_Occurrence (Excep);
|
|
|
1583 end Reraise_Occurrence_No_Defer;
|
|
|
1584
|
|
|
1585 ---------------------
|
|
|
1586 -- Save_Occurrence --
|
|
|
1587 ---------------------
|
|
|
1588
|
|
|
1589 procedure Save_Occurrence
|
|
|
1590 (Target : out Exception_Occurrence;
|
|
|
1591 Source : Exception_Occurrence)
|
|
|
1592 is
|
|
|
1593 begin
|
|
|
1594 -- As the machine occurrence might be a data that must be finalized
|
|
|
1595 -- (outside any Ada mechanism), do not copy it
|
|
|
1596
|
|
|
1597 Target.Id := Source.Id;
|
|
|
1598 Target.Machine_Occurrence := System.Null_Address;
|
|
|
1599 Target.Msg_Length := Source.Msg_Length;
|
|
|
1600 Target.Num_Tracebacks := Source.Num_Tracebacks;
|
|
|
1601 Target.Pid := Source.Pid;
|
|
|
1602
|
|
|
1603 Target.Msg (1 .. Target.Msg_Length) :=
|
|
|
1604 Source.Msg (1 .. Target.Msg_Length);
|
|
|
1605
|
|
|
1606 Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
|
|
|
1607 Source.Tracebacks (1 .. Target.Num_Tracebacks);
|
|
|
1608 end Save_Occurrence;
|
|
|
1609
|
|
|
1610 function Save_Occurrence (Source : Exception_Occurrence) return EOA is
|
|
|
1611 Target : constant EOA := new Exception_Occurrence;
|
|
|
1612 begin
|
|
|
1613 Save_Occurrence (Target.all, Source);
|
|
|
1614 return Target;
|
|
|
1615 end Save_Occurrence;
|
|
|
1616
|
|
|
1617 -------------------
|
|
|
1618 -- String_To_EId --
|
|
|
1619 -------------------
|
|
|
1620
|
|
|
1621 function String_To_EId (S : String) return Exception_Id
|
|
|
1622 renames Stream_Attributes.String_To_EId;
|
|
|
1623
|
|
|
1624 ------------------
|
|
|
1625 -- String_To_EO --
|
|
|
1626 ------------------
|
|
|
1627
|
|
|
1628 function String_To_EO (S : String) return Exception_Occurrence
|
|
|
1629 renames Stream_Attributes.String_To_EO;
|
|
|
1630
|
|
|
1631 ---------------
|
|
|
1632 -- To_Stderr --
|
|
|
1633 ---------------
|
|
|
1634
|
|
|
1635 procedure To_Stderr (C : Character) is
|
|
|
1636 procedure Put_Char_Stderr (C : Character);
|
|
|
1637 pragma Import (C, Put_Char_Stderr, "put_char_stderr");
|
|
|
1638 begin
|
|
|
1639 Put_Char_Stderr (C);
|
|
|
1640 end To_Stderr;
|
|
|
1641
|
|
|
1642 procedure To_Stderr (S : String) is
|
|
|
1643 begin
|
|
|
1644 for J in S'Range loop
|
|
|
1645 if S (J) /= ASCII.CR then
|
|
|
1646 To_Stderr (S (J));
|
|
|
1647 end if;
|
|
|
1648 end loop;
|
|
|
1649 end To_Stderr;
|
|
|
1650
|
|
|
1651 -------------------------
|
|
|
1652 -- Transfer_Occurrence --
|
|
|
1653 -------------------------
|
|
|
1654
|
|
|
1655 procedure Transfer_Occurrence
|
|
|
1656 (Target : Exception_Occurrence_Access;
|
|
|
1657 Source : Exception_Occurrence)
|
|
|
1658 is
|
|
|
1659 begin
|
|
|
1660 Save_Occurrence (Target.all, Source);
|
|
|
1661 end Transfer_Occurrence;
|
|
|
1662
|
|
|
1663 ------------------------
|
|
|
1664 -- Triggered_By_Abort --
|
|
|
1665 ------------------------
|
|
|
1666
|
|
|
1667 function Triggered_By_Abort return Boolean is
|
|
|
1668 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
|
|
|
1669 begin
|
|
|
1670 return Ex /= null
|
|
|
1671 and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
|
|
|
1672 end Triggered_By_Abort;
|
|
|
1673
|
|
|
1674 -------------------------
|
|
|
1675 -- Wide_Exception_Name --
|
|
|
1676 -------------------------
|
|
|
1677
|
|
|
1678 WC_Encoding : Character;
|
|
|
1679 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
|
|
|
1680 -- Encoding method for source, as exported by binder
|
|
|
1681
|
|
|
1682 function Wide_Exception_Name
|
|
|
1683 (Id : Exception_Id) return Wide_String
|
|
|
1684 is
|
|
|
1685 S : constant String := Exception_Name (Id);
|
|
|
1686 W : Wide_String (1 .. S'Length);
|
|
|
1687 L : Natural;
|
|
|
1688 begin
|
|
|
1689 String_To_Wide_String
|
|
|
1690 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1691 return W (1 .. L);
|
|
|
1692 end Wide_Exception_Name;
|
|
|
1693
|
|
|
1694 function Wide_Exception_Name
|
|
|
1695 (X : Exception_Occurrence) return Wide_String
|
|
|
1696 is
|
|
|
1697 S : constant String := Exception_Name (X);
|
|
|
1698 W : Wide_String (1 .. S'Length);
|
|
|
1699 L : Natural;
|
|
|
1700 begin
|
|
|
1701 String_To_Wide_String
|
|
|
1702 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1703 return W (1 .. L);
|
|
|
1704 end Wide_Exception_Name;
|
|
|
1705
|
|
|
1706 ----------------------------
|
|
|
1707 -- Wide_Wide_Exception_Name --
|
|
|
1708 -----------------------------
|
|
|
1709
|
|
|
1710 function Wide_Wide_Exception_Name
|
|
|
1711 (Id : Exception_Id) return Wide_Wide_String
|
|
|
1712 is
|
|
|
1713 S : constant String := Exception_Name (Id);
|
|
|
1714 W : Wide_Wide_String (1 .. S'Length);
|
|
|
1715 L : Natural;
|
|
|
1716 begin
|
|
|
1717 String_To_Wide_Wide_String
|
|
|
1718 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1719 return W (1 .. L);
|
|
|
1720 end Wide_Wide_Exception_Name;
|
|
|
1721
|
|
|
1722 function Wide_Wide_Exception_Name
|
|
|
1723 (X : Exception_Occurrence) return Wide_Wide_String
|
|
|
1724 is
|
|
|
1725 S : constant String := Exception_Name (X);
|
|
|
1726 W : Wide_Wide_String (1 .. S'Length);
|
|
|
1727 L : Natural;
|
|
|
1728 begin
|
|
|
1729 String_To_Wide_Wide_String
|
|
|
1730 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
|
|
|
1731 return W (1 .. L);
|
|
|
1732 end Wide_Wide_Exception_Name;
|
|
|
1733
|
|
|
1734 --------------------------
|
|
|
1735 -- Code_Address_For_ZZZ --
|
|
|
1736 --------------------------
|
|
|
1737
|
|
|
1738 -- This function gives us the end of the PC range for addresses
|
|
|
1739 -- within the exception unit itself. We hope that gigi/gcc keeps all the
|
|
|
1740 -- procedures in their original order.
|
|
|
1741
|
|
|
1742 function Code_Address_For_ZZZ return System.Address is
|
|
|
1743 begin
|
|
|
1744 <<Start_Of_ZZZ>>
|
|
|
1745 return Start_Of_ZZZ'Address;
|
|
|
1746 end Code_Address_For_ZZZ;
|
|
|
1747
|
|
|
1748 end Ada.Exceptions;
|
