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