?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Change use to type-based pool allocator in
[official-gcc.git] / gcc / ada / a-except.adb
blob9d5aceea5721ff8f5d89ce079c5d564b9194f04e
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 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 pragma Compiler_Unit_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 -- Exception_Name: <exception name> (as in Exception_Name)
121 -- Message: <message> (only if Exception_Message is 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 -- Current_Target_Exception --
732 ------------------------------
733
734 function Current_Target_Exception return Exception_Occurrence is
735 begin
736 return Null_Occurrence;
737 end Current_Target_Exception;
738
739 -------------------
740 -- EId_To_String --
741 -------------------
742
743 function EId_To_String (X : Exception_Id) return String
744 renames Stream_Attributes.EId_To_String;
745
746 ------------------
747 -- EO_To_String --
748 ------------------
749
750 -- We use the null string to represent the null occurrence, otherwise we
751 -- output the Untailored_Exception_Information string for the occurrence.
752
753 function EO_To_String (X : Exception_Occurrence) return String
754 renames Stream_Attributes.EO_To_String;
755
756 ------------------------
757 -- Exception_Identity --
758 ------------------------
759
760 function Exception_Identity
761 (X : Exception_Occurrence) return Exception_Id
762 is
763 begin
764 -- Note that the following test used to be here for the original Ada 95
765 -- semantics, but these were modified by AI-241 to require returning
766 -- Null_Id instead of raising Constraint_Error.
767
768 -- if X.Id = Null_Id then
769 -- raise Constraint_Error;
770 -- end if;
771
772 return X.Id;
773 end Exception_Identity;
774
775 ---------------------------
776 -- Exception_Information --
777 ---------------------------
778
779 function Exception_Information (X : Exception_Occurrence) return String is
780 begin
781 if X.Id = Null_Id then
782 raise Constraint_Error;
783 else
784 return Exception_Data.Exception_Information (X);
785 end if;
786 end Exception_Information;
787
788 -----------------------
789 -- Exception_Message --
790 -----------------------
791
792 function Exception_Message (X : Exception_Occurrence) return String is
793 begin
794 if X.Id = Null_Id then
795 raise Constraint_Error;
796 end if;
797
798 return X.Msg (1 .. X.Msg_Length);
799 end Exception_Message;
800
801 --------------------
802 -- Exception_Name --
803 --------------------
804
805 function Exception_Name (Id : Exception_Id) return String is
806 begin
807 if Id = null then
808 raise Constraint_Error;
809 end if;
810
811 return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1);
812 end Exception_Name;
813
814 function Exception_Name (X : Exception_Occurrence) return String is
815 begin
816 return Exception_Name (X.Id);
817 end Exception_Name;
818
819 ---------------------------
820 -- Exception_Name_Simple --
821 ---------------------------
822
823 function Exception_Name_Simple (X : Exception_Occurrence) return String is
824 Name : constant String := Exception_Name (X);
825 P : Natural;
826
827 begin
828 P := Name'Length;
829 while P > 1 loop
830 exit when Name (P - 1) = '.';
831 P := P - 1;
832 end loop;
833
834 -- Return result making sure lower bound is 1
835
836 declare
837 subtype Rname is String (1 .. Name'Length - P + 1);
838 begin
839 return Rname (Name (P .. Name'Length));
840 end;
841 end Exception_Name_Simple;
842
843 --------------------
844 -- Exception_Data --
845 --------------------
846
847 package body Exception_Data is separate;
848 -- This package can be easily dummied out if we do not want the basic
849 -- support for exception messages (such as in Ada 83).
850
851 ----------------------
852 -- Exception_Traces --
853 ----------------------
854
855 package body Exception_Traces is separate;
856 -- Depending on the underlying support for IO the implementation will
857 -- differ. Moreover we would like to dummy out this package in case we do
858 -- not want any exception tracing support. This is why this package is
859 -- separated.
860
861 -----------------------
862 -- Stream Attributes --
863 -----------------------
864
865 package body Stream_Attributes is separate;
866 -- This package can be easily dummied out if we do not want the
867 -- support for streaming Exception_Ids and Exception_Occurrences.
868
869 -----------------------------
870 -- Process_Raise_Exception --
871 -----------------------------
872
873 procedure Process_Raise_Exception (E : Exception_Id) is
874 pragma Inspection_Point (E);
875 -- This is so the debugger can reliably inspect the parameter
876
877 Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
878 Excep : constant EOA := Get_Current_Excep.all;
879
880 procedure builtin_longjmp (buffer : Address; Flag : Integer);
881 pragma No_Return (builtin_longjmp);
882 pragma Import (C, builtin_longjmp, "_gnat_builtin_longjmp");
883
884 begin
885 -- WARNING: There should be no exception handler for this body because
886 -- this would cause gigi to prepend a setup for a new jmpbuf to the
887 -- sequence of statements in case of built-in sjljl. We would then
888 -- always get this new buf in Jumpbuf_Ptr instead of the one for the
889 -- exception we are handling, which would completely break the whole
890 -- design of this procedure.
891
892 -- If the jump buffer pointer is non-null, transfer control using it.
893 -- Otherwise announce an unhandled exception (note that this means that
894 -- we have no finalizations to do other than at the outer level).
895 -- Perform the necessary notification tasks in both cases.
896
897 if Jumpbuf_Ptr /= Null_Address then
898 if not Excep.Exception_Raised then
899 Excep.Exception_Raised := True;
900 Exception_Traces.Notify_Handled_Exception (Excep);
901 end if;
902
903 builtin_longjmp (Jumpbuf_Ptr, 1);
904
905 else
906 Exception_Traces.Notify_Unhandled_Exception (Excep);
907 Exception_Traces.Unhandled_Exception_Terminate (Excep);
908 end if;
909 end Process_Raise_Exception;
910
911 ----------------------------
912 -- Raise_Constraint_Error --
913 ----------------------------
914
915 procedure Raise_Constraint_Error
916 (File : System.Address;
917 Line : Integer)
918 is
919 begin
920 Raise_With_Location_And_Msg
921 (Constraint_Error_Def'Access, File, Line);
922 end Raise_Constraint_Error;
923
924 --------------------------------
925 -- Raise_Constraint_Error_Msg --
926 --------------------------------
927
928 procedure Raise_Constraint_Error_Msg
929 (File : System.Address;
930 Line : Integer;
931 Msg : System.Address)
932 is
933 begin
934 Raise_With_Location_And_Msg
935 (Constraint_Error_Def'Access, File, Line, Msg);
936 end Raise_Constraint_Error_Msg;
937
938 -------------------------
939 -- Raise_Current_Excep --
940 -------------------------
941
942 procedure Raise_Current_Excep (E : Exception_Id) is
943
944 pragma Inspection_Point (E);
945 -- This is so the debugger can reliably inspect the parameter when
946 -- inserting a breakpoint at the start of this procedure.
947
948 Id : Exception_Id := E;
949 pragma Volatile (Id);
950 pragma Warnings (Off, Id);
951 -- In order to provide support for breakpoints on unhandled exceptions,
952 -- the debugger will also need to be able to inspect the value of E from
953 -- another (inner) frame. So we need to make sure that if E is passed in
954 -- a register, its value is also spilled on stack. For this, we store
955 -- the parameter value in a local variable, and add a pragma Volatile to
956 -- make sure it is spilled. The pragma Warnings (Off) is needed because
957 -- the compiler knows that Id is not referenced and that this use of
958 -- pragma Volatile is peculiar.
959
960 begin
961 Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
962 Process_Raise_Exception (E);
963 end Raise_Current_Excep;
964
965 ---------------------
966 -- Raise_Exception --
967 ---------------------
968
969 procedure Raise_Exception
970 (E : Exception_Id;
971 Message : String := "")
972 is
973 EF : Exception_Id := E;
974 Excep : constant EOA := Get_Current_Excep.all;
975 begin
976 -- Raise CE if E = Null_ID (AI-446)
977
978 if E = null then
979 EF := Constraint_Error'Identity;
980 end if;
981
982 -- Go ahead and raise appropriate exception
983
984 Exception_Data.Set_Exception_Msg (Excep, EF, Message);
985 Abort_Defer.all;
986 Raise_Current_Excep (EF);
987 end Raise_Exception;
988
989 ----------------------------
990 -- Raise_Exception_Always --
991 ----------------------------
992
993 procedure Raise_Exception_Always
994 (E : Exception_Id;
995 Message : String := "")
996 is
997 Excep : constant EOA := Get_Current_Excep.all;
998 begin
999 Exception_Data.Set_Exception_Msg (Excep, E, Message);
1000 Abort_Defer.all;
1001 Raise_Current_Excep (E);
1002 end Raise_Exception_Always;
1003
1004 ------------------------------
1005 -- Raise_Exception_No_Defer --
1006 ------------------------------
1007
1008 procedure Raise_Exception_No_Defer
1009 (E : Exception_Id;
1010 Message : String := "")
1011 is
1012 Excep : constant EOA := Get_Current_Excep.all;
1013 begin
1014 Exception_Data.Set_Exception_Msg (Excep, E, Message);
1015
1016 -- Do not call Abort_Defer.all, as specified by the spec
1017
1018 Raise_Current_Excep (E);
1019 end Raise_Exception_No_Defer;
1020
1021 -------------------------------------
1022 -- Raise_From_Controlled_Operation --
1023 -------------------------------------
1024
1025 procedure Raise_From_Controlled_Operation
1026 (X : Ada.Exceptions.Exception_Occurrence)
1027 is
1028 Prefix : constant String := "adjust/finalize raised ";
1029 Orig_Msg : constant String := Exception_Message (X);
1030 Orig_Prefix_Length : constant Natural :=
1031 Integer'Min (Prefix'Length, Orig_Msg'Length);
1032 Orig_Prefix : String renames Orig_Msg
1033 (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
1034 begin
1035 -- Message already has proper prefix, just re-reraise
1036
1037 if Orig_Prefix = Prefix then
1038 Raise_Exception_No_Defer
1039 (E => Program_Error'Identity,
1040 Message => Orig_Msg);
1041
1042 else
1043 declare
1044 New_Msg : constant String := Prefix & Exception_Name (X);
1045
1046 begin
1047 -- No message present, just provide our own
1048
1049 if Orig_Msg = "" then
1050 Raise_Exception_No_Defer
1051 (E => Program_Error'Identity,
1052 Message => New_Msg);
1053
1054 -- Message present, add informational prefix
1055
1056 else
1057 Raise_Exception_No_Defer
1058 (E => Program_Error'Identity,
1059 Message => New_Msg & ": " & Orig_Msg);
1060 end if;
1061 end;
1062 end if;
1063 end Raise_From_Controlled_Operation;
1064
1065 -------------------------------
1066 -- Raise_From_Signal_Handler --
1067 -------------------------------
1068
1069 procedure Raise_From_Signal_Handler
1070 (E : Exception_Id;
1071 M : System.Address)
1072 is
1073 Excep : constant EOA := Get_Current_Excep.all;
1074 begin
1075 Exception_Data.Set_Exception_C_Msg (Excep, E, M);
1076 Abort_Defer.all;
1077 Process_Raise_Exception (E);
1078 end Raise_From_Signal_Handler;
1079
1080 -------------------------
1081 -- Raise_Program_Error --
1082 -------------------------
1083
1084 procedure Raise_Program_Error
1085 (File : System.Address;
1086 Line : Integer)
1087 is
1088 begin
1089 Raise_With_Location_And_Msg
1090 (Program_Error_Def'Access, File, Line);
1091 end Raise_Program_Error;
1092
1093 -----------------------------
1094 -- Raise_Program_Error_Msg --
1095 -----------------------------
1096
1097 procedure Raise_Program_Error_Msg
1098 (File : System.Address;
1099 Line : Integer;
1100 Msg : System.Address)
1101 is
1102 begin
1103 Raise_With_Location_And_Msg
1104 (Program_Error_Def'Access, File, Line, Msg);
1105 end Raise_Program_Error_Msg;
1106
1107 -------------------------
1108 -- Raise_Storage_Error --
1109 -------------------------
1110
1111 procedure Raise_Storage_Error
1112 (File : System.Address;
1113 Line : Integer)
1114 is
1115 begin
1116 Raise_With_Location_And_Msg
1117 (Storage_Error_Def'Access, File, Line);
1118 end Raise_Storage_Error;
1119
1120 -----------------------------
1121 -- Raise_Storage_Error_Msg --
1122 -----------------------------
1123
1124 procedure Raise_Storage_Error_Msg
1125 (File : System.Address;
1126 Line : Integer;
1127 Msg : System.Address)
1128 is
1129 begin
1130 Raise_With_Location_And_Msg
1131 (Storage_Error_Def'Access, File, Line, Msg);
1132 end Raise_Storage_Error_Msg;
1133
1134 ---------------------------------
1135 -- Raise_With_Location_And_Msg --
1136 ---------------------------------
1137
1138 procedure Raise_With_Location_And_Msg
1139 (E : Exception_Id;
1140 F : System.Address;
1141 L : Integer;
1142 M : System.Address := System.Null_Address)
1143 is
1144 Excep : constant EOA := Get_Current_Excep.all;
1145 begin
1146 Exception_Data.Set_Exception_C_Msg (Excep, E, F, L, Msg2 => M);
1147 Abort_Defer.all;
1148 Raise_Current_Excep (E);
1149 end Raise_With_Location_And_Msg;
1150
1151 --------------------
1152 -- Raise_With_Msg --
1153 --------------------
1154
1155 procedure Raise_With_Msg (E : Exception_Id) is
1156 Excep : constant EOA := Get_Current_Excep.all;
1157
1158 begin
1159 Excep.Exception_Raised := False;
1160 Excep.Id := E;
1161 Excep.Num_Tracebacks := 0;
1162 Excep.Pid := Local_Partition_ID;
1163 Abort_Defer.all;
1164 Raise_Current_Excep (E);
1165 end Raise_With_Msg;
1166
1167 -----------------------------------------
1168 -- Calls to Run-Time Check Subprograms --
1169 -----------------------------------------
1170
1171 procedure Rcheck_CE_Access_Check
1172 (File : System.Address; Line : Integer)
1173 is
1174 begin
1175 Raise_Constraint_Error_Msg (File, Line, Rmsg_00'Address);
1176 end Rcheck_CE_Access_Check;
1177
1178 procedure Rcheck_CE_Null_Access_Parameter
1179 (File : System.Address; Line : Integer)
1180 is
1181 begin
1182 Raise_Constraint_Error_Msg (File, Line, Rmsg_01'Address);
1183 end Rcheck_CE_Null_Access_Parameter;
1184
1185 procedure Rcheck_CE_Discriminant_Check
1186 (File : System.Address; Line : Integer)
1187 is
1188 begin
1189 Raise_Constraint_Error_Msg (File, Line, Rmsg_02'Address);
1190 end Rcheck_CE_Discriminant_Check;
1191
1192 procedure Rcheck_CE_Divide_By_Zero
1193 (File : System.Address; Line : Integer)
1194 is
1195 begin
1196 Raise_Constraint_Error_Msg (File, Line, Rmsg_03'Address);
1197 end Rcheck_CE_Divide_By_Zero;
1198
1199 procedure Rcheck_CE_Explicit_Raise
1200 (File : System.Address; Line : Integer)
1201 is
1202 begin
1203 Raise_Constraint_Error_Msg (File, Line, Rmsg_04'Address);
1204 end Rcheck_CE_Explicit_Raise;
1205
1206 procedure Rcheck_CE_Index_Check
1207 (File : System.Address; Line : Integer)
1208 is
1209 begin
1210 Raise_Constraint_Error_Msg (File, Line, Rmsg_05'Address);
1211 end Rcheck_CE_Index_Check;
1212
1213 procedure Rcheck_CE_Invalid_Data
1214 (File : System.Address; Line : Integer)
1215 is
1216 begin
1217 Raise_Constraint_Error_Msg (File, Line, Rmsg_06'Address);
1218 end Rcheck_CE_Invalid_Data;
1219
1220 procedure Rcheck_CE_Length_Check
1221 (File : System.Address; Line : Integer)
1222 is
1223 begin
1224 Raise_Constraint_Error_Msg (File, Line, Rmsg_07'Address);
1225 end Rcheck_CE_Length_Check;
1226
1227 procedure Rcheck_CE_Null_Exception_Id
1228 (File : System.Address; Line : Integer)
1229 is
1230 begin
1231 Raise_Constraint_Error_Msg (File, Line, Rmsg_08'Address);
1232 end Rcheck_CE_Null_Exception_Id;
1233
1234 procedure Rcheck_CE_Null_Not_Allowed
1235 (File : System.Address; Line : Integer)
1236 is
1237 begin
1238 Raise_Constraint_Error_Msg (File, Line, Rmsg_09'Address);
1239 end Rcheck_CE_Null_Not_Allowed;
1240
1241 procedure Rcheck_CE_Overflow_Check
1242 (File : System.Address; Line : Integer)
1243 is
1244 begin
1245 Raise_Constraint_Error_Msg (File, Line, Rmsg_10'Address);
1246 end Rcheck_CE_Overflow_Check;
1247
1248 procedure Rcheck_CE_Partition_Check
1249 (File : System.Address; Line : Integer)
1250 is
1251 begin
1252 Raise_Constraint_Error_Msg (File, Line, Rmsg_11'Address);
1253 end Rcheck_CE_Partition_Check;
1254
1255 procedure Rcheck_CE_Range_Check
1256 (File : System.Address; Line : Integer)
1257 is
1258 begin
1259 Raise_Constraint_Error_Msg (File, Line, Rmsg_12'Address);
1260 end Rcheck_CE_Range_Check;
1261
1262 procedure Rcheck_CE_Tag_Check
1263 (File : System.Address; Line : Integer)
1264 is
1265 begin
1266 Raise_Constraint_Error_Msg (File, Line, Rmsg_13'Address);
1267 end Rcheck_CE_Tag_Check;
1268
1269 procedure Rcheck_PE_Access_Before_Elaboration
1270 (File : System.Address; Line : Integer)
1271 is
1272 begin
1273 Raise_Program_Error_Msg (File, Line, Rmsg_14'Address);
1274 end Rcheck_PE_Access_Before_Elaboration;
1275
1276 procedure Rcheck_PE_Accessibility_Check
1277 (File : System.Address; Line : Integer)
1278 is
1279 begin
1280 Raise_Program_Error_Msg (File, Line, Rmsg_15'Address);
1281 end Rcheck_PE_Accessibility_Check;
1282
1283 procedure Rcheck_PE_Address_Of_Intrinsic
1284 (File : System.Address; Line : Integer)
1285 is
1286 begin
1287 Raise_Program_Error_Msg (File, Line, Rmsg_16'Address);
1288 end Rcheck_PE_Address_Of_Intrinsic;
1289
1290 procedure Rcheck_PE_Aliased_Parameters
1291 (File : System.Address; Line : Integer)
1292 is
1293 begin
1294 Raise_Program_Error_Msg (File, Line, Rmsg_17'Address);
1295 end Rcheck_PE_Aliased_Parameters;
1296
1297 procedure Rcheck_PE_All_Guards_Closed
1298 (File : System.Address; Line : Integer)
1299 is
1300 begin
1301 Raise_Program_Error_Msg (File, Line, Rmsg_18'Address);
1302 end Rcheck_PE_All_Guards_Closed;
1303
1304 procedure Rcheck_PE_Bad_Predicated_Generic_Type
1305 (File : System.Address; Line : Integer)
1306 is
1307 begin
1308 Raise_Program_Error_Msg (File, Line, Rmsg_19'Address);
1309 end Rcheck_PE_Bad_Predicated_Generic_Type;
1310
1311 procedure Rcheck_PE_Current_Task_In_Entry_Body
1312 (File : System.Address; Line : Integer)
1313 is
1314 begin
1315 Raise_Program_Error_Msg (File, Line, Rmsg_20'Address);
1316 end Rcheck_PE_Current_Task_In_Entry_Body;
1317
1318 procedure Rcheck_PE_Duplicated_Entry_Address
1319 (File : System.Address; Line : Integer)
1320 is
1321 begin
1322 Raise_Program_Error_Msg (File, Line, Rmsg_21'Address);
1323 end Rcheck_PE_Duplicated_Entry_Address;
1324
1325 procedure Rcheck_PE_Explicit_Raise
1326 (File : System.Address; Line : Integer)
1327 is
1328 begin
1329 Raise_Program_Error_Msg (File, Line, Rmsg_22'Address);
1330 end Rcheck_PE_Explicit_Raise;
1331
1332 procedure Rcheck_PE_Implicit_Return
1333 (File : System.Address; Line : Integer)
1334 is
1335 begin
1336 Raise_Program_Error_Msg (File, Line, Rmsg_24'Address);
1337 end Rcheck_PE_Implicit_Return;
1338
1339 procedure Rcheck_PE_Misaligned_Address_Value
1340 (File : System.Address; Line : Integer)
1341 is
1342 begin
1343 Raise_Program_Error_Msg (File, Line, Rmsg_25'Address);
1344 end Rcheck_PE_Misaligned_Address_Value;
1345
1346 procedure Rcheck_PE_Missing_Return
1347 (File : System.Address; Line : Integer)
1348 is
1349 begin
1350 Raise_Program_Error_Msg (File, Line, Rmsg_26'Address);
1351 end Rcheck_PE_Missing_Return;
1352
1353 procedure Rcheck_PE_Overlaid_Controlled_Object
1354 (File : System.Address; Line : Integer)
1355 is
1356 begin
1357 Raise_Program_Error_Msg (File, Line, Rmsg_27'Address);
1358 end Rcheck_PE_Overlaid_Controlled_Object;
1359
1360 procedure Rcheck_PE_Potentially_Blocking_Operation
1361 (File : System.Address; Line : Integer)
1362 is
1363 begin
1364 Raise_Program_Error_Msg (File, Line, Rmsg_28'Address);
1365 end Rcheck_PE_Potentially_Blocking_Operation;
1366
1367 procedure Rcheck_PE_Stubbed_Subprogram_Called
1368 (File : System.Address; Line : Integer)
1369 is
1370 begin
1371 Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
1372 end Rcheck_PE_Stubbed_Subprogram_Called;
1373
1374 procedure Rcheck_PE_Unchecked_Union_Restriction
1375 (File : System.Address; Line : Integer)
1376 is
1377 begin
1378 Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
1379 end Rcheck_PE_Unchecked_Union_Restriction;
1380
1381 procedure Rcheck_PE_Non_Transportable_Actual
1382 (File : System.Address; Line : Integer)
1383 is
1384 begin
1385 Raise_Program_Error_Msg (File, Line, Rmsg_31'Address);
1386 end Rcheck_PE_Non_Transportable_Actual;
1387
1388 procedure Rcheck_SE_Empty_Storage_Pool
1389 (File : System.Address; Line : Integer)
1390 is
1391 begin
1392 Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
1393 end Rcheck_SE_Empty_Storage_Pool;
1394
1395 procedure Rcheck_SE_Explicit_Raise
1396 (File : System.Address; Line : Integer)
1397 is
1398 begin
1399 Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
1400 end Rcheck_SE_Explicit_Raise;
1401
1402 procedure Rcheck_SE_Infinite_Recursion
1403 (File : System.Address; Line : Integer)
1404 is
1405 begin
1406 Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
1407 end Rcheck_SE_Infinite_Recursion;
1408
1409 procedure Rcheck_SE_Object_Too_Large
1410 (File : System.Address; Line : Integer)
1411 is
1412 begin
1413 Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address);
1414 end Rcheck_SE_Object_Too_Large;
1415
1416 procedure Rcheck_PE_Stream_Operation_Not_Allowed
1417 (File : System.Address; Line : Integer)
1418 is
1419 begin
1420 Raise_Program_Error_Msg (File, Line, Rmsg_36'Address);
1421 end Rcheck_PE_Stream_Operation_Not_Allowed;
1422
1423 procedure Rcheck_PE_Finalize_Raised_Exception
1424 (File : System.Address; Line : Integer)
1425 is
1426 E : constant Exception_Id := Program_Error_Def'Access;
1427 Excep : constant EOA := Get_Current_Excep.all;
1428
1429 begin
1430 -- This is "finalize/adjust raised exception". This subprogram is always
1431 -- called with abort deferred, unlike all other Rcheck_* subprograms,
1432 -- itneeds to call Raise_Exception_No_Defer.
1433
1434 -- This is consistent with Raise_From_Controlled_Operation
1435
1436 Exception_Data.Set_Exception_C_Msg (Excep, E, File, Line, 0,
1437 Rmsg_23'Address);
1438 Raise_Current_Excep (E);
1439 end Rcheck_PE_Finalize_Raised_Exception;
1440
1441 procedure Rcheck_00 (File : System.Address; Line : Integer)
1442 renames Rcheck_CE_Access_Check;
1443 procedure Rcheck_01 (File : System.Address; Line : Integer)
1444 renames Rcheck_CE_Null_Access_Parameter;
1445 procedure Rcheck_02 (File : System.Address; Line : Integer)
1446 renames Rcheck_CE_Discriminant_Check;
1447 procedure Rcheck_03 (File : System.Address; Line : Integer)
1448 renames Rcheck_CE_Divide_By_Zero;
1449 procedure Rcheck_04 (File : System.Address; Line : Integer)
1450 renames Rcheck_CE_Explicit_Raise;
1451 procedure Rcheck_05 (File : System.Address; Line : Integer)
1452 renames Rcheck_CE_Index_Check;
1453 procedure Rcheck_06 (File : System.Address; Line : Integer)
1454 renames Rcheck_CE_Invalid_Data;
1455 procedure Rcheck_07 (File : System.Address; Line : Integer)
1456 renames Rcheck_CE_Length_Check;
1457 procedure Rcheck_08 (File : System.Address; Line : Integer)
1458 renames Rcheck_CE_Null_Exception_Id;
1459 procedure Rcheck_09 (File : System.Address; Line : Integer)
1460 renames Rcheck_CE_Null_Not_Allowed;
1461 procedure Rcheck_10 (File : System.Address; Line : Integer)
1462 renames Rcheck_CE_Overflow_Check;
1463 procedure Rcheck_11 (File : System.Address; Line : Integer)
1464 renames Rcheck_CE_Partition_Check;
1465 procedure Rcheck_12 (File : System.Address; Line : Integer)
1466 renames Rcheck_CE_Range_Check;
1467 procedure Rcheck_13 (File : System.Address; Line : Integer)
1468 renames Rcheck_CE_Tag_Check;
1469 procedure Rcheck_14 (File : System.Address; Line : Integer)
1470 renames Rcheck_PE_Access_Before_Elaboration;
1471 procedure Rcheck_15 (File : System.Address; Line : Integer)
1472 renames Rcheck_PE_Accessibility_Check;
1473 procedure Rcheck_16 (File : System.Address; Line : Integer)
1474 renames Rcheck_PE_Address_Of_Intrinsic;
1475 procedure Rcheck_17 (File : System.Address; Line : Integer)
1476 renames Rcheck_PE_Aliased_Parameters;
1477 procedure Rcheck_18 (File : System.Address; Line : Integer)
1478 renames Rcheck_PE_All_Guards_Closed;
1479 procedure Rcheck_19 (File : System.Address; Line : Integer)
1480 renames Rcheck_PE_Bad_Predicated_Generic_Type;
1481 procedure Rcheck_20 (File : System.Address; Line : Integer)
1482 renames Rcheck_PE_Current_Task_In_Entry_Body;
1483 procedure Rcheck_21 (File : System.Address; Line : Integer)
1484 renames Rcheck_PE_Duplicated_Entry_Address;
1485 procedure Rcheck_22 (File : System.Address; Line : Integer)
1486 renames Rcheck_PE_Explicit_Raise;
1487 procedure Rcheck_23 (File : System.Address; Line : Integer)
1488 renames Rcheck_PE_Finalize_Raised_Exception;
1489 procedure Rcheck_24 (File : System.Address; Line : Integer)
1490 renames Rcheck_PE_Implicit_Return;
1491 procedure Rcheck_25 (File : System.Address; Line : Integer)
1492 renames Rcheck_PE_Misaligned_Address_Value;
1493 procedure Rcheck_26 (File : System.Address; Line : Integer)
1494 renames Rcheck_PE_Missing_Return;
1495 procedure Rcheck_27 (File : System.Address; Line : Integer)
1496 renames Rcheck_PE_Overlaid_Controlled_Object;
1497 procedure Rcheck_28 (File : System.Address; Line : Integer)
1498 renames Rcheck_PE_Potentially_Blocking_Operation;
1499 procedure Rcheck_29 (File : System.Address; Line : Integer)
1500 renames Rcheck_PE_Stubbed_Subprogram_Called;
1501 procedure Rcheck_30 (File : System.Address; Line : Integer)
1502 renames Rcheck_PE_Unchecked_Union_Restriction;
1503 procedure Rcheck_31 (File : System.Address; Line : Integer)
1504 renames Rcheck_PE_Non_Transportable_Actual;
1505 procedure Rcheck_32 (File : System.Address; Line : Integer)
1506 renames Rcheck_SE_Empty_Storage_Pool;
1507 procedure Rcheck_33 (File : System.Address; Line : Integer)
1508 renames Rcheck_SE_Explicit_Raise;
1509 procedure Rcheck_34 (File : System.Address; Line : Integer)
1510 renames Rcheck_SE_Infinite_Recursion;
1511 procedure Rcheck_35 (File : System.Address; Line : Integer)
1512 renames Rcheck_SE_Object_Too_Large;
1513 procedure Rcheck_36 (File : System.Address; Line : Integer)
1514 renames Rcheck_PE_Stream_Operation_Not_Allowed;
1515
1516 -------------
1517 -- Reraise --
1518 -------------
1519
1520 procedure Reraise is
1521 Excep : constant EOA := Get_Current_Excep.all;
1522
1523 begin
1524 Abort_Defer.all;
1525 Raise_Current_Excep (Excep.Id);
1526 end Reraise;
1527
1528 --------------------------------------
1529 -- Reraise_Library_Exception_If_Any --
1530 --------------------------------------
1531
1532 procedure Reraise_Library_Exception_If_Any is
1533 LE : Exception_Occurrence;
1534 begin
1535 if Library_Exception_Set then
1536 LE := Library_Exception;
1537 Raise_From_Controlled_Operation (LE);
1538 end if;
1539 end Reraise_Library_Exception_If_Any;
1540
1541 ------------------------
1542 -- Reraise_Occurrence --
1543 ------------------------
1544
1545 procedure Reraise_Occurrence (X : Exception_Occurrence) is
1546 begin
1547 if X.Id /= null then
1548 Abort_Defer.all;
1549 Save_Occurrence (Get_Current_Excep.all.all, X);
1550 Raise_Current_Excep (X.Id);
1551 end if;
1552 end Reraise_Occurrence;
1553
1554 -------------------------------
1555 -- Reraise_Occurrence_Always --
1556 -------------------------------
1557
1558 procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
1559 begin
1560 Abort_Defer.all;
1561 Save_Occurrence (Get_Current_Excep.all.all, X);
1562 Raise_Current_Excep (X.Id);
1563 end Reraise_Occurrence_Always;
1564
1565 ---------------------------------
1566 -- Reraise_Occurrence_No_Defer --
1567 ---------------------------------
1568
1569 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
1570 begin
1571 Save_Occurrence (Get_Current_Excep.all.all, X);
1572 Raise_Current_Excep (X.Id);
1573 end Reraise_Occurrence_No_Defer;
1574
1575 ---------------------
1576 -- Save_Occurrence --
1577 ---------------------
1578
1579 procedure Save_Occurrence
1580 (Target : out Exception_Occurrence;
1581 Source : Exception_Occurrence)
1582 is
1583 begin
1584 Target.Id := Source.Id;
1585 Target.Msg_Length := Source.Msg_Length;
1586 Target.Num_Tracebacks := Source.Num_Tracebacks;
1587 Target.Pid := Source.Pid;
1588
1589 Target.Msg (1 .. Target.Msg_Length) :=
1590 Source.Msg (1 .. Target.Msg_Length);
1591
1592 Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
1593 Source.Tracebacks (1 .. Target.Num_Tracebacks);
1594 end Save_Occurrence;
1595
1596 function Save_Occurrence (Source : Exception_Occurrence) return EOA is
1597 Target : constant EOA := new Exception_Occurrence;
1598 begin
1599 Save_Occurrence (Target.all, Source);
1600 return Target;
1601 end Save_Occurrence;
1602
1603 -------------------
1604 -- String_To_EId --
1605 -------------------
1606
1607 function String_To_EId (S : String) return Exception_Id
1608 renames Stream_Attributes.String_To_EId;
1609
1610 ------------------
1611 -- String_To_EO --
1612 ------------------
1613
1614 function String_To_EO (S : String) return Exception_Occurrence
1615 renames Stream_Attributes.String_To_EO;
1616
1617 ---------------
1618 -- To_Stderr --
1619 ---------------
1620
1621 procedure To_Stderr (C : Character) is
1622 type int is new Integer;
1623
1624 procedure put_char_stderr (C : int);
1625 pragma Import (C, put_char_stderr, "put_char_stderr");
1626
1627 begin
1628 put_char_stderr (Character'Pos (C));
1629 end To_Stderr;
1630
1631 procedure To_Stderr (S : String) is
1632 begin
1633 for J in S'Range loop
1634 if S (J) /= ASCII.CR then
1635 To_Stderr (S (J));
1636 end if;
1637 end loop;
1638 end To_Stderr;
1639
1640 -------------------------
1641 -- Transfer_Occurrence --
1642 -------------------------
1643
1644 procedure Transfer_Occurrence
1645 (Target : Exception_Occurrence_Access;
1646 Source : Exception_Occurrence)
1647 is
1648 begin
1649 Save_Occurrence (Target.all, Source);
1650 end Transfer_Occurrence;
1651
1652 ------------------------
1653 -- Triggered_By_Abort --
1654 ------------------------
1655
1656 function Triggered_By_Abort return Boolean is
1657 Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
1658 begin
1659 return Ex /= null
1660 and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;
1661 end Triggered_By_Abort;
1662
1663 end Ada.Exceptions;
Mirror of the offical gcc git repository hosted at gcc.gnu.org