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