Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-except.adb @ 111:04ced10e8804

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