1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- A D A . E X C E P T I O N S --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005.
33 -- It is used in all situations except for the build of the compiler and
34 -- other basic tools. For these latter builds, we use an Ada 95-only version.
36 -- The reason for this splitting off of a separate version is that bootstrap
37 -- compilers often will be used that do not support Ada 2005 features, and
38 -- Ada.Exceptions is part of the compiler sources.
40 pragma Style_Checks
(All_Checks
);
41 -- No subprogram ordering check, due to logical grouping
44 -- We must turn polling off for this unit, because otherwise we get
45 -- elaboration circularities with System.Exception_Tables.
47 with System
; use System
;
48 with System
.Exceptions
; use System
.Exceptions
;
49 with System
.Exceptions_Debug
; use System
.Exceptions_Debug
;
50 with System
.Standard_Library
; use System
.Standard_Library
;
51 with System
.Soft_Links
; use System
.Soft_Links
;
52 with System
.WCh_Con
; use System
.WCh_Con
;
53 with System
.WCh_StW
; use System
.WCh_StW
;
55 package body Ada
.Exceptions
is
57 pragma Suppress
(All_Checks
);
58 -- We definitely do not want exceptions occurring within this unit, or
59 -- we are in big trouble. If an exceptional situation does occur, better
60 -- that it not be raised, since raising it can cause confusing chaos.
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
66 -- Note: the exported subprograms in this package body are called directly
67 -- from C clients using the given external name, even though they are not
68 -- technically visible in the Ada sense.
70 function Code_Address_For_AAA
return System
.Address
;
71 function Code_Address_For_ZZZ
return System
.Address
;
72 -- Return start and end of procedures in this package
74 -- These procedures are used to provide exclusion bounds in
75 -- calls to Call_Chain at exception raise points from this unit. The
76 -- purpose is to arrange for the exception tracebacks not to include
77 -- frames from routines involved in the raise process, as these are
78 -- meaningless from the user's standpoint.
80 -- For these bounds to be meaningful, we need to ensure that the object
81 -- code for the routines involved in processing a raise is located after
82 -- the object code Code_Address_For_AAA and before the object code
83 -- Code_Address_For_ZZZ. This will indeed be the case as long as the
84 -- following rules are respected:
86 -- 1) The bodies of the subprograms involved in processing a raise
87 -- are located after the body of Code_Address_For_AAA and before the
88 -- body of Code_Address_For_ZZZ.
90 -- 2) No pragma Inline applies to any of these subprograms, as this
91 -- could delay the corresponding assembly output until the end of
94 procedure Call_Chain
(Excep
: EOA
);
95 -- Store up to Max_Tracebacks in Excep, corresponding to the current
98 function Image
(Index
: Integer) return String;
99 -- Return string image corresponding to Index
101 procedure To_Stderr
(S
: String);
102 pragma Export
(Ada
, To_Stderr
, "__gnat_to_stderr");
103 -- Little routine to output string to stderr that is also used
104 -- in the tasking run time.
106 procedure To_Stderr
(C
: Character);
107 pragma Inline
(To_Stderr
);
108 pragma Export
(Ada
, To_Stderr
, "__gnat_to_stderr_char");
109 -- Little routine to output a character to stderr, used by some of
110 -- the separate units below.
112 package Exception_Data
is
114 ---------------------------------
115 -- Exception messages routines --
116 ---------------------------------
118 procedure Set_Exception_C_Msg
121 Msg1
: System
.Address
;
123 Column
: Integer := 0;
124 Msg2
: System
.Address
:= System
.Null_Address
);
125 -- This routine is called to setup the exception referenced by X
126 -- to contain the indicated Id value and message. Msg1 is a null
127 -- terminated string which is generated as the exception message. If
128 -- line is non-zero, then a colon and the decimal representation of
129 -- this integer is appended to the message. Ditto for Column. When Msg2
130 -- is non-null, a space and this additional null terminated string is
131 -- added to the message.
133 procedure Set_Exception_Msg
137 -- This routine is called to setup the exception referenced by X
138 -- to contain the indicated Id value and message. Message is a string
139 -- which is generated as the exception message.
141 --------------------------------------
142 -- Exception information subprogram --
143 --------------------------------------
145 function Exception_Information
(X
: Exception_Occurrence
) return String;
146 -- The format of the exception information is as follows:
148 -- Exception_Name: <exception name> (as in Exception_Name)
149 -- Message: <message> (only if Exception_Message is empty)
150 -- PID=nnnn (only if != 0)
151 -- Call stack traceback locations: (only if at least one location)
152 -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded)
154 -- The lines are separated by a ASCII.LF character.
155 -- The nnnn is the partition Id given as decimal digits.
156 -- The 0x... line represents traceback program counter locations, in
157 -- execution order with the first one being the exception location. It
160 -- The Exception_Name and Message lines are omitted in the abort
161 -- signal case, since this is not really an exception.
163 -- !! If the format of the generated string is changed, please note
164 -- !! that an equivalent modification to the routine String_To_EO must
165 -- !! be made to preserve proper functioning of the stream attributes.
167 ---------------------------------------
168 -- Exception backtracing subprograms --
169 ---------------------------------------
171 -- What is automatically output when exception tracing is on is the
172 -- usual exception information with the call chain backtrace possibly
173 -- tailored by a backtrace decorator. Modifying Exception_Information
174 -- itself is not a good idea because the decorated output is completely
175 -- out of control and would break all our code related to the streaming
176 -- of exceptions. We then provide an alternative function to compute
177 -- the possibly tailored output, which is equivalent if no decorator is
180 function Tailored_Exception_Information
181 (X
: Exception_Occurrence
) return String;
182 -- Exception information to be output in the case of automatic tracing
183 -- requested through GNAT.Exception_Traces.
185 -- This is the same as Exception_Information if no backtrace decorator
186 -- is currently in place. Otherwise, this is Exception_Information with
187 -- the call chain raw addresses replaced by the result of a call to the
188 -- current decorator provided with the call chain addresses.
191 (Ada
, Tailored_Exception_Information
,
192 "__gnat_tailored_exception_information");
193 -- This is currently used by System.Tasking.Stages
197 package Exception_Traces
is
200 -- Imports Tailored_Exception_Information
202 ----------------------------------------------
203 -- Run-Time Exception Notification Routines --
204 ----------------------------------------------
206 -- These subprograms provide a common run-time interface to trigger the
207 -- actions required when an exception is about to be propagated (e.g.
208 -- user specified actions or output of exception information). They are
209 -- exported to be usable by the Ada exception handling personality
210 -- routine when the GCC 3 mechanism is used.
212 procedure Notify_Handled_Exception
(Excep
: EOA
);
214 (C
, Notify_Handled_Exception
, "__gnat_notify_handled_exception");
215 -- This routine is called for a handled occurrence is about to be
218 procedure Notify_Unhandled_Exception
(Excep
: EOA
);
220 (C
, Notify_Unhandled_Exception
, "__gnat_notify_unhandled_exception");
221 -- This routine is called when an unhandled occurrence is about to be
224 procedure Unhandled_Exception_Terminate
(Excep
: EOA
);
225 pragma No_Return
(Unhandled_Exception_Terminate
);
226 -- This procedure is called to terminate execution following an
227 -- unhandled exception. The exception information, including
228 -- traceback if available is output, and execution is then
229 -- terminated. Note that at the point where this routine is
230 -- called, the stack has typically been destroyed.
232 end Exception_Traces
;
234 package Exception_Propagation
is
236 ------------------------------------
237 -- Exception propagation routines --
238 ------------------------------------
240 function Allocate_Occurrence
return EOA
;
241 -- Allocate an exception occurence (as well as the machine occurence)
243 procedure Propagate_Exception
(Excep
: EOA
);
244 pragma No_Return
(Propagate_Exception
);
245 -- This procedure propagates the exception represented by Excep
247 end Exception_Propagation
;
249 package Stream_Attributes
is
251 --------------------------------
252 -- Stream attributes routines --
253 --------------------------------
255 function EId_To_String
(X
: Exception_Id
) return String;
256 function String_To_EId
(S
: String) return Exception_Id
;
257 -- Functions for implementing Exception_Id stream attributes
259 function EO_To_String
(X
: Exception_Occurrence
) return String;
260 function String_To_EO
(S
: String) return Exception_Occurrence
;
261 -- Functions for implementing Exception_Occurrence stream
264 end Stream_Attributes
;
266 procedure Complete_Occurrence
(X
: EOA
);
267 -- Finish building the occurrence: save the call chain and notify the
270 procedure Complete_And_Propagate_Occurrence
(X
: EOA
);
271 pragma No_Return
(Complete_And_Propagate_Occurrence
);
272 -- This is a simple wrapper to Complete_Occurrence and
273 -- Exception_Propagation.Propagate_Exception.
275 function Create_Occurrence_From_Signal_Handler
277 M
: System
.Address
) return EOA
;
278 -- Create and build an exception occurrence using exception id E and
279 -- nul-terminated message M.
281 function Create_Machine_Occurrence_From_Signal_Handler
283 M
: System
.Address
) return System
.Address
;
284 pragma Export
(C
, Create_Machine_Occurrence_From_Signal_Handler
,
285 "__gnat_create_machine_occurrence_from_signal_handler");
286 -- Create and build an exception occurrence using exception id E and
287 -- nul-terminated message M. Return the machine occurrence.
289 procedure Raise_Exception_No_Defer
291 Message
: String := "");
293 (Ada
, Raise_Exception_No_Defer
,
294 "ada__exceptions__raise_exception_no_defer");
295 pragma No_Return
(Raise_Exception_No_Defer
);
296 -- Similar to Raise_Exception, but with no abort deferral
298 procedure Raise_With_Msg
(E
: Exception_Id
);
299 pragma No_Return
(Raise_With_Msg
);
300 pragma Export
(C
, Raise_With_Msg
, "__gnat_raise_with_msg");
301 -- Raises an exception with given exception id value. A message
302 -- is associated with the raise, and has already been stored in the
303 -- exception occurrence referenced by the Current_Excep in the TSD.
304 -- Abort is deferred before the raise call.
306 procedure Raise_With_Location_And_Msg
311 M
: System
.Address
:= System
.Null_Address
);
312 pragma No_Return
(Raise_With_Location_And_Msg
);
313 -- Raise an exception with given exception id value. A filename and line
314 -- number is associated with the raise and is stored in the exception
315 -- occurrence and in addition a column and a string message M may be
316 -- appended to this (if not null/0).
318 procedure Raise_Constraint_Error
319 (File
: System
.Address
;
321 pragma No_Return
(Raise_Constraint_Error
);
323 (C
, Raise_Constraint_Error
, "__gnat_raise_constraint_error");
324 -- Raise constraint error with file:line information
326 procedure Raise_Constraint_Error_Msg
327 (File
: System
.Address
;
330 Msg
: System
.Address
);
331 pragma No_Return
(Raise_Constraint_Error_Msg
);
333 (C
, Raise_Constraint_Error_Msg
, "__gnat_raise_constraint_error_msg");
334 -- Raise constraint error with file:line:col + msg information
336 procedure Raise_Program_Error
337 (File
: System
.Address
;
339 pragma No_Return
(Raise_Program_Error
);
341 (C
, Raise_Program_Error
, "__gnat_raise_program_error");
342 -- Raise program error with file:line information
344 procedure Raise_Program_Error_Msg
345 (File
: System
.Address
;
347 Msg
: System
.Address
);
348 pragma No_Return
(Raise_Program_Error_Msg
);
350 (C
, Raise_Program_Error_Msg
, "__gnat_raise_program_error_msg");
351 -- Raise program error with file:line + msg information
353 procedure Raise_Storage_Error
354 (File
: System
.Address
;
356 pragma No_Return
(Raise_Storage_Error
);
358 (C
, Raise_Storage_Error
, "__gnat_raise_storage_error");
359 -- Raise storage error with file:line information
361 procedure Raise_Storage_Error_Msg
362 (File
: System
.Address
;
364 Msg
: System
.Address
);
365 pragma No_Return
(Raise_Storage_Error_Msg
);
367 (C
, Raise_Storage_Error_Msg
, "__gnat_raise_storage_error_msg");
368 -- Raise storage error with file:line + reason msg information
370 -- The exception raising process and the automatic tracing mechanism rely
371 -- on some careful use of flags attached to the exception occurrence. The
372 -- graph below illustrates the relations between the Raise_ subprograms
373 -- and identifies the points where basic flags such as Exception_Raised
376 -- (i) signs indicate the flags initialization points. R stands for Raise,
377 -- W for With, and E for Exception.
379 -- R_No_Msg R_E R_Pe R_Ce R_Se
381 -- +--+ +--+ +---+ | +---+
383 -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc
385 -- +------------+ | +-----------+ +--+
387 -- | | | Set_E_C_Msg(i)
389 -- Complete_And_Propagate_Occurrence
392 pragma No_Return
(Reraise
);
393 pragma Export
(C
, Reraise
, "__gnat_reraise");
394 -- Reraises the exception referenced by the Current_Excep field of
395 -- the TSD (all fields of this exception occurrence are set). Abort
396 -- is deferred before the reraise operation.
397 -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
399 procedure Transfer_Occurrence
400 (Target
: Exception_Occurrence_Access
;
401 Source
: Exception_Occurrence
);
402 pragma Export
(C
, Transfer_Occurrence
, "__gnat_transfer_occurrence");
403 -- Called from s-tasren.adb:Local_Complete_RendezVous and
404 -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
405 -- Source as an exception to be propagated in the caller task. Target is
406 -- expected to be a pointer to the fixed TSD occurrence for this task.
408 -----------------------------
409 -- Run-Time Check Routines --
410 -----------------------------
412 -- These routines raise a specific exception with a reason message
413 -- attached. The parameters are the file name and line number in each
414 -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
416 procedure Rcheck_CE_Access_Check
417 (File
: System
.Address
; Line
: Integer);
418 procedure Rcheck_CE_Null_Access_Parameter
419 (File
: System
.Address
; Line
: Integer);
420 procedure Rcheck_CE_Discriminant_Check
421 (File
: System
.Address
; Line
: Integer);
422 procedure Rcheck_CE_Divide_By_Zero
423 (File
: System
.Address
; Line
: Integer);
424 procedure Rcheck_CE_Explicit_Raise
425 (File
: System
.Address
; Line
: Integer);
426 procedure Rcheck_CE_Index_Check
427 (File
: System
.Address
; Line
: Integer);
428 procedure Rcheck_CE_Invalid_Data
429 (File
: System
.Address
; Line
: Integer);
430 procedure Rcheck_CE_Length_Check
431 (File
: System
.Address
; Line
: Integer);
432 procedure Rcheck_CE_Null_Exception_Id
433 (File
: System
.Address
; Line
: Integer);
434 procedure Rcheck_CE_Null_Not_Allowed
435 (File
: System
.Address
; Line
: Integer);
436 procedure Rcheck_CE_Overflow_Check
437 (File
: System
.Address
; Line
: Integer);
438 procedure Rcheck_CE_Partition_Check
439 (File
: System
.Address
; Line
: Integer);
440 procedure Rcheck_CE_Range_Check
441 (File
: System
.Address
; Line
: Integer);
442 procedure Rcheck_CE_Tag_Check
443 (File
: System
.Address
; Line
: Integer);
444 procedure Rcheck_PE_Access_Before_Elaboration
445 (File
: System
.Address
; Line
: Integer);
446 procedure Rcheck_PE_Accessibility_Check
447 (File
: System
.Address
; Line
: Integer);
448 procedure Rcheck_PE_Address_Of_Intrinsic
449 (File
: System
.Address
; Line
: Integer);
450 procedure Rcheck_PE_All_Guards_Closed
451 (File
: System
.Address
; Line
: Integer);
452 procedure Rcheck_PE_Bad_Predicated_Generic_Type
453 (File
: System
.Address
; Line
: Integer);
454 procedure Rcheck_PE_Current_Task_In_Entry_Body
455 (File
: System
.Address
; Line
: Integer);
456 procedure Rcheck_PE_Duplicated_Entry_Address
457 (File
: System
.Address
; Line
: Integer);
458 procedure Rcheck_PE_Explicit_Raise
459 (File
: System
.Address
; Line
: Integer);
460 procedure Rcheck_PE_Implicit_Return
461 (File
: System
.Address
; Line
: Integer);
462 procedure Rcheck_PE_Misaligned_Address_Value
463 (File
: System
.Address
; Line
: Integer);
464 procedure Rcheck_PE_Missing_Return
465 (File
: System
.Address
; Line
: Integer);
466 procedure Rcheck_PE_Overlaid_Controlled_Object
467 (File
: System
.Address
; Line
: Integer);
468 procedure Rcheck_PE_Potentially_Blocking_Operation
469 (File
: System
.Address
; Line
: Integer);
470 procedure Rcheck_PE_Stubbed_Subprogram_Called
471 (File
: System
.Address
; Line
: Integer);
472 procedure Rcheck_PE_Unchecked_Union_Restriction
473 (File
: System
.Address
; Line
: Integer);
474 procedure Rcheck_PE_Non_Transportable_Actual
475 (File
: System
.Address
; Line
: Integer);
476 procedure Rcheck_SE_Empty_Storage_Pool
477 (File
: System
.Address
; Line
: Integer);
478 procedure Rcheck_SE_Explicit_Raise
479 (File
: System
.Address
; Line
: Integer);
480 procedure Rcheck_SE_Infinite_Recursion
481 (File
: System
.Address
; Line
: Integer);
482 procedure Rcheck_SE_Object_Too_Large
483 (File
: System
.Address
; Line
: Integer);
485 procedure Rcheck_CE_Access_Check_Ext
486 (File
: System
.Address
; Line
, Column
: Integer);
487 procedure Rcheck_CE_Index_Check_Ext
488 (File
: System
.Address
; Line
, Column
, Index
, First
, Last
: Integer);
489 procedure Rcheck_CE_Invalid_Data_Ext
490 (File
: System
.Address
; Line
, Column
, Index
, First
, Last
: Integer);
491 procedure Rcheck_CE_Range_Check_Ext
492 (File
: System
.Address
; Line
, Column
, Index
, First
, Last
: Integer);
494 procedure Rcheck_PE_Finalize_Raised_Exception
495 (File
: System
.Address
; Line
: Integer);
496 -- This routine is separated out because it has quite different behavior
497 -- from the others. This is the "finalize/adjust raised exception". This
498 -- subprogram is always called with abort deferred, unlike all other
499 -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer.
501 pragma Export
(C
, Rcheck_CE_Access_Check
,
502 "__gnat_rcheck_CE_Access_Check");
503 pragma Export
(C
, Rcheck_CE_Null_Access_Parameter
,
504 "__gnat_rcheck_CE_Null_Access_Parameter");
505 pragma Export
(C
, Rcheck_CE_Discriminant_Check
,
506 "__gnat_rcheck_CE_Discriminant_Check");
507 pragma Export
(C
, Rcheck_CE_Divide_By_Zero
,
508 "__gnat_rcheck_CE_Divide_By_Zero");
509 pragma Export
(C
, Rcheck_CE_Explicit_Raise
,
510 "__gnat_rcheck_CE_Explicit_Raise");
511 pragma Export
(C
, Rcheck_CE_Index_Check
,
512 "__gnat_rcheck_CE_Index_Check");
513 pragma Export
(C
, Rcheck_CE_Invalid_Data
,
514 "__gnat_rcheck_CE_Invalid_Data");
515 pragma Export
(C
, Rcheck_CE_Length_Check
,
516 "__gnat_rcheck_CE_Length_Check");
517 pragma Export
(C
, Rcheck_CE_Null_Exception_Id
,
518 "__gnat_rcheck_CE_Null_Exception_Id");
519 pragma Export
(C
, Rcheck_CE_Null_Not_Allowed
,
520 "__gnat_rcheck_CE_Null_Not_Allowed");
521 pragma Export
(C
, Rcheck_CE_Overflow_Check
,
522 "__gnat_rcheck_CE_Overflow_Check");
523 pragma Export
(C
, Rcheck_CE_Partition_Check
,
524 "__gnat_rcheck_CE_Partition_Check");
525 pragma Export
(C
, Rcheck_CE_Range_Check
,
526 "__gnat_rcheck_CE_Range_Check");
527 pragma Export
(C
, Rcheck_CE_Tag_Check
,
528 "__gnat_rcheck_CE_Tag_Check");
529 pragma Export
(C
, Rcheck_PE_Access_Before_Elaboration
,
530 "__gnat_rcheck_PE_Access_Before_Elaboration");
531 pragma Export
(C
, Rcheck_PE_Accessibility_Check
,
532 "__gnat_rcheck_PE_Accessibility_Check");
533 pragma Export
(C
, Rcheck_PE_Address_Of_Intrinsic
,
534 "__gnat_rcheck_PE_Address_Of_Intrinsic");
535 pragma Export
(C
, Rcheck_PE_All_Guards_Closed
,
536 "__gnat_rcheck_PE_All_Guards_Closed");
537 pragma Export
(C
, Rcheck_PE_Bad_Predicated_Generic_Type
,
538 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
539 pragma Export
(C
, Rcheck_PE_Current_Task_In_Entry_Body
,
540 "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
541 pragma Export
(C
, Rcheck_PE_Duplicated_Entry_Address
,
542 "__gnat_rcheck_PE_Duplicated_Entry_Address");
543 pragma Export
(C
, Rcheck_PE_Explicit_Raise
,
544 "__gnat_rcheck_PE_Explicit_Raise");
545 pragma Export
(C
, Rcheck_PE_Finalize_Raised_Exception
,
546 "__gnat_rcheck_PE_Finalize_Raised_Exception");
547 pragma Export
(C
, Rcheck_PE_Implicit_Return
,
548 "__gnat_rcheck_PE_Implicit_Return");
549 pragma Export
(C
, Rcheck_PE_Misaligned_Address_Value
,
550 "__gnat_rcheck_PE_Misaligned_Address_Value");
551 pragma Export
(C
, Rcheck_PE_Missing_Return
,
552 "__gnat_rcheck_PE_Missing_Return");
553 pragma Export
(C
, Rcheck_PE_Overlaid_Controlled_Object
,
554 "__gnat_rcheck_PE_Overlaid_Controlled_Object");
555 pragma Export
(C
, Rcheck_PE_Potentially_Blocking_Operation
,
556 "__gnat_rcheck_PE_Potentially_Blocking_Operation");
557 pragma Export
(C
, Rcheck_PE_Stubbed_Subprogram_Called
,
558 "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
559 pragma Export
(C
, Rcheck_PE_Unchecked_Union_Restriction
,
560 "__gnat_rcheck_PE_Unchecked_Union_Restriction");
561 pragma Export
(C
, Rcheck_PE_Non_Transportable_Actual
,
562 "__gnat_rcheck_PE_Non_Transportable_Actual");
563 pragma Export
(C
, Rcheck_SE_Empty_Storage_Pool
,
564 "__gnat_rcheck_SE_Empty_Storage_Pool");
565 pragma Export
(C
, Rcheck_SE_Explicit_Raise
,
566 "__gnat_rcheck_SE_Explicit_Raise");
567 pragma Export
(C
, Rcheck_SE_Infinite_Recursion
,
568 "__gnat_rcheck_SE_Infinite_Recursion");
569 pragma Export
(C
, Rcheck_SE_Object_Too_Large
,
570 "__gnat_rcheck_SE_Object_Too_Large");
572 pragma Export
(C
, Rcheck_CE_Access_Check_Ext
,
573 "__gnat_rcheck_CE_Access_Check_ext");
574 pragma Export
(C
, Rcheck_CE_Index_Check_Ext
,
575 "__gnat_rcheck_CE_Index_Check_ext");
576 pragma Export
(C
, Rcheck_CE_Invalid_Data_Ext
,
577 "__gnat_rcheck_CE_Invalid_Data_ext");
578 pragma Export
(C
, Rcheck_CE_Range_Check_Ext
,
579 "__gnat_rcheck_CE_Range_Check_ext");
581 -- None of these procedures ever returns (they raise an exception!). By
582 -- using pragma No_Return, we ensure that any junk code after the call,
583 -- such as normal return epilog stuff, can be eliminated).
585 pragma No_Return
(Rcheck_CE_Access_Check
);
586 pragma No_Return
(Rcheck_CE_Null_Access_Parameter
);
587 pragma No_Return
(Rcheck_CE_Discriminant_Check
);
588 pragma No_Return
(Rcheck_CE_Divide_By_Zero
);
589 pragma No_Return
(Rcheck_CE_Explicit_Raise
);
590 pragma No_Return
(Rcheck_CE_Index_Check
);
591 pragma No_Return
(Rcheck_CE_Invalid_Data
);
592 pragma No_Return
(Rcheck_CE_Length_Check
);
593 pragma No_Return
(Rcheck_CE_Null_Exception_Id
);
594 pragma No_Return
(Rcheck_CE_Null_Not_Allowed
);
595 pragma No_Return
(Rcheck_CE_Overflow_Check
);
596 pragma No_Return
(Rcheck_CE_Partition_Check
);
597 pragma No_Return
(Rcheck_CE_Range_Check
);
598 pragma No_Return
(Rcheck_CE_Tag_Check
);
599 pragma No_Return
(Rcheck_PE_Access_Before_Elaboration
);
600 pragma No_Return
(Rcheck_PE_Accessibility_Check
);
601 pragma No_Return
(Rcheck_PE_Address_Of_Intrinsic
);
602 pragma No_Return
(Rcheck_PE_All_Guards_Closed
);
603 pragma No_Return
(Rcheck_PE_Bad_Predicated_Generic_Type
);
604 pragma No_Return
(Rcheck_PE_Current_Task_In_Entry_Body
);
605 pragma No_Return
(Rcheck_PE_Duplicated_Entry_Address
);
606 pragma No_Return
(Rcheck_PE_Explicit_Raise
);
607 pragma No_Return
(Rcheck_PE_Implicit_Return
);
608 pragma No_Return
(Rcheck_PE_Misaligned_Address_Value
);
609 pragma No_Return
(Rcheck_PE_Missing_Return
);
610 pragma No_Return
(Rcheck_PE_Overlaid_Controlled_Object
);
611 pragma No_Return
(Rcheck_PE_Potentially_Blocking_Operation
);
612 pragma No_Return
(Rcheck_PE_Stubbed_Subprogram_Called
);
613 pragma No_Return
(Rcheck_PE_Unchecked_Union_Restriction
);
614 pragma No_Return
(Rcheck_PE_Non_Transportable_Actual
);
615 pragma No_Return
(Rcheck_PE_Finalize_Raised_Exception
);
616 pragma No_Return
(Rcheck_SE_Empty_Storage_Pool
);
617 pragma No_Return
(Rcheck_SE_Explicit_Raise
);
618 pragma No_Return
(Rcheck_SE_Infinite_Recursion
);
619 pragma No_Return
(Rcheck_SE_Object_Too_Large
);
621 pragma No_Return
(Rcheck_CE_Access_Check_Ext
);
622 pragma No_Return
(Rcheck_CE_Index_Check_Ext
);
623 pragma No_Return
(Rcheck_CE_Invalid_Data_Ext
);
624 pragma No_Return
(Rcheck_CE_Range_Check_Ext
);
626 ---------------------------------------------
627 -- Reason Strings for Run-Time Check Calls --
628 ---------------------------------------------
630 -- These strings are null-terminated and are used by Rcheck_nn. The
631 -- strings correspond to the definitions for Types.RT_Exception_Code.
635 Rmsg_00
: constant String := "access check failed" & NUL
;
636 Rmsg_01
: constant String := "access parameter is null" & NUL
;
637 Rmsg_02
: constant String := "discriminant check failed" & NUL
;
638 Rmsg_03
: constant String := "divide by zero" & NUL
;
639 Rmsg_04
: constant String := "explicit raise" & NUL
;
640 Rmsg_05
: constant String := "index check failed" & NUL
;
641 Rmsg_06
: constant String := "invalid data" & NUL
;
642 Rmsg_07
: constant String := "length check failed" & NUL
;
643 Rmsg_08
: constant String := "null Exception_Id" & NUL
;
644 Rmsg_09
: constant String := "null-exclusion check failed" & NUL
;
645 Rmsg_10
: constant String := "overflow check failed" & NUL
;
646 Rmsg_11
: constant String := "partition check failed" & NUL
;
647 Rmsg_12
: constant String := "range check failed" & NUL
;
648 Rmsg_13
: constant String := "tag check failed" & NUL
;
649 Rmsg_14
: constant String := "access before elaboration" & NUL
;
650 Rmsg_15
: constant String := "accessibility check failed" & NUL
;
651 Rmsg_16
: constant String := "attempt to take address of" &
652 " intrinsic subprogram" & NUL
;
653 Rmsg_17
: constant String := "all guards closed" & NUL
;
654 Rmsg_18
: constant String := "improper use of generic subtype" &
655 " with predicate" & NUL
;
656 Rmsg_19
: constant String := "Current_Task referenced in entry" &
658 Rmsg_20
: constant String := "duplicated entry address" & NUL
;
659 Rmsg_21
: constant String := "explicit raise" & NUL
;
660 Rmsg_22
: constant String := "finalize/adjust raised exception" & NUL
;
661 Rmsg_23
: constant String := "implicit return with No_Return" & NUL
;
662 Rmsg_24
: constant String := "misaligned address value" & NUL
;
663 Rmsg_25
: constant String := "missing return" & NUL
;
664 Rmsg_26
: constant String := "overlaid controlled object" & NUL
;
665 Rmsg_27
: constant String := "potentially blocking operation" & NUL
;
666 Rmsg_28
: constant String := "stubbed subprogram called" & NUL
;
667 Rmsg_29
: constant String := "unchecked union restriction" & NUL
;
668 Rmsg_30
: constant String := "actual/returned class-wide" &
669 " value not transportable" & NUL
;
670 Rmsg_31
: constant String := "empty storage pool" & NUL
;
671 Rmsg_32
: constant String := "explicit raise" & NUL
;
672 Rmsg_33
: constant String := "infinite recursion" & NUL
;
673 Rmsg_34
: constant String := "object too large" & NUL
;
675 -----------------------
676 -- Polling Interface --
677 -----------------------
679 type Unsigned
is mod 2 ** 32;
681 Counter
: Unsigned
:= 0;
682 pragma Warnings
(Off
, Counter
);
683 -- This counter is provided for convenience. It can be used in Poll to
684 -- perform periodic but not systematic operations.
686 procedure Poll
is separate;
687 -- The actual polling routine is separate, so that it can easily
688 -- be replaced with a target dependent version.
690 --------------------------
691 -- Code_Address_For_AAA --
692 --------------------------
694 -- This function gives us the start of the PC range for addresses
695 -- within the exception unit itself. We hope that gigi/gcc keep all the
696 -- procedures in their original order!
698 function Code_Address_For_AAA
return System
.Address
is
700 -- We are using a label instead of merely using
701 -- Code_Address_For_AAA'Address because on some platforms the latter
702 -- does not yield the address we want, but the address of a stub or of
703 -- a descriptor instead. This is the case at least on Alpha-VMS and
707 return Start_Of_AAA
'Address;
708 end Code_Address_For_AAA
;
714 procedure Call_Chain
(Excep
: EOA
) is separate;
715 -- The actual Call_Chain routine is separate, so that it can easily
716 -- be dummied out when no exception traceback information is needed.
718 ------------------------------
719 -- Current_Target_Exception --
720 ------------------------------
722 function Current_Target_Exception
return Exception_Occurrence
is
724 return Null_Occurrence
;
725 end Current_Target_Exception
;
731 function EId_To_String
(X
: Exception_Id
) return String
732 renames Stream_Attributes
.EId_To_String
;
738 -- We use the null string to represent the null occurrence, otherwise
739 -- we output the Exception_Information string for the occurrence.
741 function EO_To_String
(X
: Exception_Occurrence
) return String
742 renames Stream_Attributes
.EO_To_String
;
744 ------------------------
745 -- Exception_Identity --
746 ------------------------
748 function Exception_Identity
749 (X
: Exception_Occurrence
) return Exception_Id
752 -- Note that the following test used to be here for the original
753 -- Ada 95 semantics, but these were modified by AI-241 to require
754 -- returning Null_Id instead of raising Constraint_Error.
756 -- if X.Id = Null_Id then
757 -- raise Constraint_Error;
761 end Exception_Identity
;
763 ---------------------------
764 -- Exception_Information --
765 ---------------------------
767 function Exception_Information
(X
: Exception_Occurrence
) return String is
769 if X
.Id
= Null_Id
then
770 raise Constraint_Error
;
773 return Exception_Data
.Exception_Information
(X
);
774 end Exception_Information
;
776 -----------------------
777 -- Exception_Message --
778 -----------------------
780 function Exception_Message
(X
: Exception_Occurrence
) return String is
782 if X
.Id
= Null_Id
then
783 raise Constraint_Error
;
786 return X
.Msg
(1 .. X
.Msg_Length
);
787 end Exception_Message
;
793 function Exception_Name
(Id
: Exception_Id
) return String is
796 raise Constraint_Error
;
799 return To_Ptr
(Id
.Full_Name
) (1 .. Id
.Name_Length
- 1);
802 function Exception_Name
(X
: Exception_Occurrence
) return String is
804 return Exception_Name
(X
.Id
);
807 ---------------------------
808 -- Exception_Name_Simple --
809 ---------------------------
811 function Exception_Name_Simple
(X
: Exception_Occurrence
) return String is
812 Name
: constant String := Exception_Name
(X
);
818 exit when Name
(P
- 1) = '.';
822 -- Return result making sure lower bound is 1
825 subtype Rname
is String (1 .. Name
'Length - P
+ 1);
827 return Rname
(Name
(P
.. Name
'Length));
829 end Exception_Name_Simple
;
835 package body Exception_Data
is separate;
836 -- This package can be easily dummied out if we do not want the
837 -- basic support for exception messages (such as in Ada 83).
839 ---------------------------
840 -- Exception_Propagation --
841 ---------------------------
843 package body Exception_Propagation
is separate;
844 -- Depending on the actual exception mechanism used (front-end or
845 -- back-end based), the implementation will differ, which is why this
846 -- package is separated.
848 ----------------------
849 -- Exception_Traces --
850 ----------------------
852 package body Exception_Traces
is separate;
853 -- Depending on the underlying support for IO the implementation
854 -- will differ. Moreover we would like to dummy out this package
855 -- in case we do not want any exception tracing support. This is
856 -- why this package is separated.
862 function Image
(Index
: Integer) return String is
863 Result
: constant String := Integer'Image (Index
);
865 if Result
(1) = ' ' then
866 return Result
(2 .. Result
'Last);
872 -----------------------
873 -- Stream Attributes --
874 -----------------------
876 package body Stream_Attributes
is separate;
877 -- This package can be easily dummied out if we do not want the
878 -- support for streaming Exception_Ids and Exception_Occurrences.
880 ----------------------------
881 -- Raise_Constraint_Error --
882 ----------------------------
884 procedure Raise_Constraint_Error
(File
: System
.Address
; Line
: Integer) is
886 Raise_With_Location_And_Msg
(Constraint_Error_Def
'Access, File
, Line
);
887 end Raise_Constraint_Error
;
889 --------------------------------
890 -- Raise_Constraint_Error_Msg --
891 --------------------------------
893 procedure Raise_Constraint_Error_Msg
894 (File
: System
.Address
;
897 Msg
: System
.Address
)
900 Raise_With_Location_And_Msg
901 (Constraint_Error_Def
'Access, File
, Line
, Column
, Msg
);
902 end Raise_Constraint_Error_Msg
;
904 -------------------------
905 -- Complete_Occurrence --
906 -------------------------
908 procedure Complete_Occurrence
(X
: EOA
) is
910 -- Compute the backtrace for this occurrence if the corresponding
911 -- binder option has been set. Call_Chain takes care of the reraise
914 -- ??? Using Call_Chain here means we are going to walk up the stack
915 -- once only for backtracing purposes before doing it again for the
916 -- propagation per se.
918 -- The first inspection is much lighter, though, as it only requires
919 -- partial unwinding of each frame. Additionally, although we could use
920 -- the personality routine to record the addresses while propagating,
921 -- this method has two drawbacks:
923 -- 1) the trace is incomplete if the exception is handled since we
924 -- don't walk past the frame with the handler,
928 -- 2) we would miss the frames for which our personality routine is not
929 -- called, e.g. if C or C++ calls are on the way.
933 -- Notify the debugger
934 Debug_Raise_Exception
(E
=> SSL
.Exception_Data_Ptr
(X
.Id
));
935 end Complete_Occurrence
;
937 ---------------------------------------
938 -- Complete_And_Propagate_Occurrence --
939 ---------------------------------------
941 procedure Complete_And_Propagate_Occurrence
(X
: EOA
) is
943 Complete_Occurrence
(X
);
944 Exception_Propagation
.Propagate_Exception
(X
);
945 end Complete_And_Propagate_Occurrence
;
947 ---------------------
948 -- Raise_Exception --
949 ---------------------
951 procedure Raise_Exception
953 Message
: String := "")
955 EF
: Exception_Id
:= E
;
957 -- Raise CE if E = Null_ID (AI-446)
960 EF
:= Constraint_Error
'Identity;
963 -- Go ahead and raise appropriate exception
965 Raise_Exception_Always
(EF
, Message
);
968 ----------------------------
969 -- Raise_Exception_Always --
970 ----------------------------
972 procedure Raise_Exception_Always
974 Message
: String := "")
976 X
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
978 Exception_Data
.Set_Exception_Msg
(X
, E
, Message
);
979 if not ZCX_By_Default
then
982 Complete_And_Propagate_Occurrence
(X
);
983 end Raise_Exception_Always
;
985 ------------------------------
986 -- Raise_Exception_No_Defer --
987 ------------------------------
989 procedure Raise_Exception_No_Defer
991 Message
: String := "")
993 X
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
995 Exception_Data
.Set_Exception_Msg
(X
, E
, Message
);
997 -- Do not call Abort_Defer.all, as specified by the spec
999 Complete_And_Propagate_Occurrence
(X
);
1000 end Raise_Exception_No_Defer
;
1002 -------------------------------------
1003 -- Raise_From_Controlled_Operation --
1004 -------------------------------------
1006 procedure Raise_From_Controlled_Operation
1007 (X
: Ada
.Exceptions
.Exception_Occurrence
)
1009 Prefix
: constant String := "adjust/finalize raised ";
1010 Orig_Msg
: constant String := Exception_Message
(X
);
1011 Orig_Prefix_Length
: constant Natural :=
1012 Integer'Min (Prefix
'Length, Orig_Msg
'Length);
1013 Orig_Prefix
: String renames Orig_Msg
1015 Orig_Msg
'First + Orig_Prefix_Length
- 1);
1017 -- Message already has the proper prefix, just re-raise
1019 if Orig_Prefix
= Prefix
then
1020 Raise_Exception_No_Defer
1021 (E
=> Program_Error
'Identity,
1022 Message
=> Orig_Msg
);
1026 New_Msg
: constant String := Prefix
& Exception_Name
(X
);
1029 -- No message present, just provide our own
1031 if Orig_Msg
= "" then
1032 Raise_Exception_No_Defer
1033 (E
=> Program_Error
'Identity,
1034 Message
=> New_Msg
);
1036 -- Message present, add informational prefix
1039 Raise_Exception_No_Defer
1040 (E
=> Program_Error
'Identity,
1041 Message
=> New_Msg
& ": " & Orig_Msg
);
1045 end Raise_From_Controlled_Operation
;
1047 -------------------------------------------
1048 -- Create_Occurrence_From_Signal_Handler --
1049 -------------------------------------------
1051 function Create_Occurrence_From_Signal_Handler
1053 M
: System
.Address
) return EOA
1055 X
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
1058 Exception_Data
.Set_Exception_C_Msg
(X
, E
, M
);
1060 if not ZCX_By_Default
then
1064 Complete_Occurrence
(X
);
1066 end Create_Occurrence_From_Signal_Handler
;
1068 ---------------------------------------------------
1069 -- Create_Machine_Occurrence_From_Signal_Handler --
1070 ---------------------------------------------------
1072 function Create_Machine_Occurrence_From_Signal_Handler
1074 M
: System
.Address
) return System
.Address
1077 return Create_Occurrence_From_Signal_Handler
(E
, M
).Machine_Occurrence
;
1078 end Create_Machine_Occurrence_From_Signal_Handler
;
1080 -------------------------------
1081 -- Raise_From_Signal_Handler --
1082 -------------------------------
1084 procedure Raise_From_Signal_Handler
1089 Exception_Propagation
.Propagate_Exception
1090 (Create_Occurrence_From_Signal_Handler
(E
, M
));
1091 end Raise_From_Signal_Handler
;
1093 -------------------------
1094 -- Raise_Program_Error --
1095 -------------------------
1097 procedure Raise_Program_Error
1098 (File
: System
.Address
;
1102 Raise_With_Location_And_Msg
(Program_Error_Def
'Access, File
, Line
);
1103 end Raise_Program_Error
;
1105 -----------------------------
1106 -- Raise_Program_Error_Msg --
1107 -----------------------------
1109 procedure Raise_Program_Error_Msg
1110 (File
: System
.Address
;
1112 Msg
: System
.Address
)
1115 Raise_With_Location_And_Msg
1116 (Program_Error_Def
'Access, File
, Line
, M
=> Msg
);
1117 end Raise_Program_Error_Msg
;
1119 -------------------------
1120 -- Raise_Storage_Error --
1121 -------------------------
1123 procedure Raise_Storage_Error
1124 (File
: System
.Address
;
1128 Raise_With_Location_And_Msg
(Storage_Error_Def
'Access, File
, Line
);
1129 end Raise_Storage_Error
;
1131 -----------------------------
1132 -- Raise_Storage_Error_Msg --
1133 -----------------------------
1135 procedure Raise_Storage_Error_Msg
1136 (File
: System
.Address
;
1138 Msg
: System
.Address
)
1141 Raise_With_Location_And_Msg
1142 (Storage_Error_Def
'Access, File
, Line
, M
=> Msg
);
1143 end Raise_Storage_Error_Msg
;
1145 ---------------------------------
1146 -- Raise_With_Location_And_Msg --
1147 ---------------------------------
1149 procedure Raise_With_Location_And_Msg
1154 M
: System
.Address
:= System
.Null_Address
)
1156 X
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
1158 Exception_Data
.Set_Exception_C_Msg
(X
, E
, F
, L
, C
, M
);
1160 if not ZCX_By_Default
then
1164 Complete_And_Propagate_Occurrence
(X
);
1165 end Raise_With_Location_And_Msg
;
1167 --------------------
1168 -- Raise_With_Msg --
1169 --------------------
1171 procedure Raise_With_Msg
(E
: Exception_Id
) is
1172 Excep
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
1173 Ex
: constant Exception_Occurrence_Access
:= Get_Current_Excep
.all;
1175 Excep
.Exception_Raised
:= False;
1177 Excep
.Num_Tracebacks
:= 0;
1178 Excep
.Pid
:= Local_Partition_ID
;
1180 -- Copy the message from the current exception
1181 -- Change the interface to be called with an occurrence ???
1183 Excep
.Msg_Length
:= Ex
.Msg_Length
;
1184 Excep
.Msg
(1 .. Excep
.Msg_Length
) := Ex
.Msg
(1 .. Ex
.Msg_Length
);
1186 -- The following is a common pattern, should be abstracted
1187 -- into a procedure call ???
1189 if not ZCX_By_Default
then
1193 Complete_And_Propagate_Occurrence
(Excep
);
1196 --------------------------------------
1197 -- Calls to Run-Time Check Routines --
1198 --------------------------------------
1200 procedure Rcheck_CE_Access_Check
1201 (File
: System
.Address
; Line
: Integer)
1204 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_00
'Address);
1205 end Rcheck_CE_Access_Check
;
1207 procedure Rcheck_CE_Null_Access_Parameter
1208 (File
: System
.Address
; Line
: Integer)
1211 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_01
'Address);
1212 end Rcheck_CE_Null_Access_Parameter
;
1214 procedure Rcheck_CE_Discriminant_Check
1215 (File
: System
.Address
; Line
: Integer)
1218 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_02
'Address);
1219 end Rcheck_CE_Discriminant_Check
;
1221 procedure Rcheck_CE_Divide_By_Zero
1222 (File
: System
.Address
; Line
: Integer)
1225 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_03
'Address);
1226 end Rcheck_CE_Divide_By_Zero
;
1228 procedure Rcheck_CE_Explicit_Raise
1229 (File
: System
.Address
; Line
: Integer)
1232 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_04
'Address);
1233 end Rcheck_CE_Explicit_Raise
;
1235 procedure Rcheck_CE_Index_Check
1236 (File
: System
.Address
; Line
: Integer)
1239 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_05
'Address);
1240 end Rcheck_CE_Index_Check
;
1242 procedure Rcheck_CE_Invalid_Data
1243 (File
: System
.Address
; Line
: Integer)
1246 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_06
'Address);
1247 end Rcheck_CE_Invalid_Data
;
1249 procedure Rcheck_CE_Length_Check
1250 (File
: System
.Address
; Line
: Integer)
1253 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_07
'Address);
1254 end Rcheck_CE_Length_Check
;
1256 procedure Rcheck_CE_Null_Exception_Id
1257 (File
: System
.Address
; Line
: Integer)
1260 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_08
'Address);
1261 end Rcheck_CE_Null_Exception_Id
;
1263 procedure Rcheck_CE_Null_Not_Allowed
1264 (File
: System
.Address
; Line
: Integer)
1267 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_09
'Address);
1268 end Rcheck_CE_Null_Not_Allowed
;
1270 procedure Rcheck_CE_Overflow_Check
1271 (File
: System
.Address
; Line
: Integer)
1274 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_10
'Address);
1275 end Rcheck_CE_Overflow_Check
;
1277 procedure Rcheck_CE_Partition_Check
1278 (File
: System
.Address
; Line
: Integer)
1281 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_11
'Address);
1282 end Rcheck_CE_Partition_Check
;
1284 procedure Rcheck_CE_Range_Check
1285 (File
: System
.Address
; Line
: Integer)
1288 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_12
'Address);
1289 end Rcheck_CE_Range_Check
;
1291 procedure Rcheck_CE_Tag_Check
1292 (File
: System
.Address
; Line
: Integer)
1295 Raise_Constraint_Error_Msg
(File
, Line
, 0, Rmsg_13
'Address);
1296 end Rcheck_CE_Tag_Check
;
1298 procedure Rcheck_PE_Access_Before_Elaboration
1299 (File
: System
.Address
; Line
: Integer)
1302 Raise_Program_Error_Msg
(File
, Line
, Rmsg_14
'Address);
1303 end Rcheck_PE_Access_Before_Elaboration
;
1305 procedure Rcheck_PE_Accessibility_Check
1306 (File
: System
.Address
; Line
: Integer)
1309 Raise_Program_Error_Msg
(File
, Line
, Rmsg_15
'Address);
1310 end Rcheck_PE_Accessibility_Check
;
1312 procedure Rcheck_PE_Address_Of_Intrinsic
1313 (File
: System
.Address
; Line
: Integer)
1316 Raise_Program_Error_Msg
(File
, Line
, Rmsg_16
'Address);
1317 end Rcheck_PE_Address_Of_Intrinsic
;
1319 procedure Rcheck_PE_All_Guards_Closed
1320 (File
: System
.Address
; Line
: Integer)
1323 Raise_Program_Error_Msg
(File
, Line
, Rmsg_17
'Address);
1324 end Rcheck_PE_All_Guards_Closed
;
1326 procedure Rcheck_PE_Bad_Predicated_Generic_Type
1327 (File
: System
.Address
; Line
: Integer)
1330 Raise_Program_Error_Msg
(File
, Line
, Rmsg_18
'Address);
1331 end Rcheck_PE_Bad_Predicated_Generic_Type
;
1333 procedure Rcheck_PE_Current_Task_In_Entry_Body
1334 (File
: System
.Address
; Line
: Integer)
1337 Raise_Program_Error_Msg
(File
, Line
, Rmsg_19
'Address);
1338 end Rcheck_PE_Current_Task_In_Entry_Body
;
1340 procedure Rcheck_PE_Duplicated_Entry_Address
1341 (File
: System
.Address
; Line
: Integer)
1344 Raise_Program_Error_Msg
(File
, Line
, Rmsg_20
'Address);
1345 end Rcheck_PE_Duplicated_Entry_Address
;
1347 procedure Rcheck_PE_Explicit_Raise
1348 (File
: System
.Address
; Line
: Integer)
1351 Raise_Program_Error_Msg
(File
, Line
, Rmsg_21
'Address);
1352 end Rcheck_PE_Explicit_Raise
;
1354 procedure Rcheck_PE_Implicit_Return
1355 (File
: System
.Address
; Line
: Integer)
1358 Raise_Program_Error_Msg
(File
, Line
, Rmsg_23
'Address);
1359 end Rcheck_PE_Implicit_Return
;
1361 procedure Rcheck_PE_Misaligned_Address_Value
1362 (File
: System
.Address
; Line
: Integer)
1365 Raise_Program_Error_Msg
(File
, Line
, Rmsg_24
'Address);
1366 end Rcheck_PE_Misaligned_Address_Value
;
1368 procedure Rcheck_PE_Missing_Return
1369 (File
: System
.Address
; Line
: Integer)
1372 Raise_Program_Error_Msg
(File
, Line
, Rmsg_25
'Address);
1373 end Rcheck_PE_Missing_Return
;
1375 procedure Rcheck_PE_Overlaid_Controlled_Object
1376 (File
: System
.Address
; Line
: Integer)
1379 Raise_Program_Error_Msg
(File
, Line
, Rmsg_26
'Address);
1380 end Rcheck_PE_Overlaid_Controlled_Object
;
1382 procedure Rcheck_PE_Potentially_Blocking_Operation
1383 (File
: System
.Address
; Line
: Integer)
1386 Raise_Program_Error_Msg
(File
, Line
, Rmsg_27
'Address);
1387 end Rcheck_PE_Potentially_Blocking_Operation
;
1389 procedure Rcheck_PE_Stubbed_Subprogram_Called
1390 (File
: System
.Address
; Line
: Integer)
1393 Raise_Program_Error_Msg
(File
, Line
, Rmsg_28
'Address);
1394 end Rcheck_PE_Stubbed_Subprogram_Called
;
1396 procedure Rcheck_PE_Unchecked_Union_Restriction
1397 (File
: System
.Address
; Line
: Integer)
1400 Raise_Program_Error_Msg
(File
, Line
, Rmsg_29
'Address);
1401 end Rcheck_PE_Unchecked_Union_Restriction
;
1403 procedure Rcheck_PE_Non_Transportable_Actual
1404 (File
: System
.Address
; Line
: Integer)
1407 Raise_Program_Error_Msg
(File
, Line
, Rmsg_30
'Address);
1408 end Rcheck_PE_Non_Transportable_Actual
;
1410 procedure Rcheck_SE_Empty_Storage_Pool
1411 (File
: System
.Address
; Line
: Integer)
1414 Raise_Storage_Error_Msg
(File
, Line
, Rmsg_31
'Address);
1415 end Rcheck_SE_Empty_Storage_Pool
;
1417 procedure Rcheck_SE_Explicit_Raise
1418 (File
: System
.Address
; Line
: Integer)
1421 Raise_Storage_Error_Msg
(File
, Line
, Rmsg_32
'Address);
1422 end Rcheck_SE_Explicit_Raise
;
1424 procedure Rcheck_SE_Infinite_Recursion
1425 (File
: System
.Address
; Line
: Integer)
1428 Raise_Storage_Error_Msg
(File
, Line
, Rmsg_33
'Address);
1429 end Rcheck_SE_Infinite_Recursion
;
1431 procedure Rcheck_SE_Object_Too_Large
1432 (File
: System
.Address
; Line
: Integer)
1435 Raise_Storage_Error_Msg
(File
, Line
, Rmsg_34
'Address);
1436 end Rcheck_SE_Object_Too_Large
;
1438 procedure Rcheck_CE_Access_Check_Ext
1439 (File
: System
.Address
; Line
, Column
: Integer)
1442 Raise_Constraint_Error_Msg
(File
, Line
, Column
, Rmsg_00
'Address);
1443 end Rcheck_CE_Access_Check_Ext
;
1445 procedure Rcheck_CE_Index_Check_Ext
1446 (File
: System
.Address
; Line
, Column
, Index
, First
, Last
: Integer)
1448 Msg
: constant String :=
1449 Rmsg_05
(Rmsg_05
'First .. Rmsg_05
'Last - 1) & ASCII
.LF
&
1450 "index " & Image
(Index
) & " not in " & Image
(First
) &
1451 ".." & Image
(Last
) & ASCII
.NUL
;
1453 Raise_Constraint_Error_Msg
(File
, Line
, Column
, Msg
'Address);
1454 end Rcheck_CE_Index_Check_Ext
;
1456 procedure Rcheck_CE_Invalid_Data_Ext
1457 (File
: System
.Address
; Line
, Column
, Index
, First
, Last
: Integer)
1459 Msg
: constant String :=
1460 Rmsg_06
(Rmsg_06
'First .. Rmsg_06
'Last - 1) & ASCII
.LF
&
1461 "value " & Image
(Index
) & " not in " & Image
(First
) &
1462 ".." & Image
(Last
) & ASCII
.NUL
;
1464 Raise_Constraint_Error_Msg
(File
, Line
, Column
, Msg
'Address);
1465 end Rcheck_CE_Invalid_Data_Ext
;
1467 procedure Rcheck_CE_Range_Check_Ext
1468 (File
: System
.Address
; Line
, Column
, Index
, First
, Last
: Integer)
1470 Msg
: constant String :=
1471 Rmsg_12
(Rmsg_12
'First .. Rmsg_12
'Last - 1) & ASCII
.LF
&
1472 "value " & Image
(Index
) & " not in " & Image
(First
) &
1473 ".." & Image
(Last
) & ASCII
.NUL
;
1475 Raise_Constraint_Error_Msg
(File
, Line
, Column
, Msg
'Address);
1476 end Rcheck_CE_Range_Check_Ext
;
1478 procedure Rcheck_PE_Finalize_Raised_Exception
1479 (File
: System
.Address
; Line
: Integer)
1481 X
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
1484 -- This is "finalize/adjust raised exception". This subprogram is always
1485 -- called with abort deferred, unlike all other Rcheck_* routines, it
1486 -- needs to call Raise_Exception_No_Defer.
1488 -- This is consistent with Raise_From_Controlled_Operation
1490 Exception_Data
.Set_Exception_C_Msg
1491 (X
, Program_Error_Def
'Access, File
, Line
, 0, Rmsg_22
'Address);
1492 Complete_And_Propagate_Occurrence
(X
);
1493 end Rcheck_PE_Finalize_Raised_Exception
;
1499 procedure Reraise
is
1500 Excep
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
1501 Saved_MO
: constant System
.Address
:= Excep
.Machine_Occurrence
;
1503 if not ZCX_By_Default
then
1506 Save_Occurrence
(Excep
.all, Get_Current_Excep
.all.all);
1507 Excep
.Machine_Occurrence
:= Saved_MO
;
1508 Complete_And_Propagate_Occurrence
(Excep
);
1511 --------------------------------------
1512 -- Reraise_Library_Exception_If_Any --
1513 --------------------------------------
1515 procedure Reraise_Library_Exception_If_Any
is
1516 LE
: Exception_Occurrence
;
1518 if Library_Exception_Set
then
1519 LE
:= Library_Exception
;
1520 if LE
.Id
= Null_Id
then
1521 Raise_Exception_No_Defer
1522 (E
=> Program_Error
'Identity,
1523 Message
=> "finalize/adjust raised exception");
1525 Raise_From_Controlled_Operation
(LE
);
1528 end Reraise_Library_Exception_If_Any
;
1530 ------------------------
1531 -- Reraise_Occurrence --
1532 ------------------------
1534 procedure Reraise_Occurrence
(X
: Exception_Occurrence
) is
1540 Reraise_Occurrence_Always
(X
);
1541 end Reraise_Occurrence
;
1543 -------------------------------
1544 -- Reraise_Occurrence_Always --
1545 -------------------------------
1547 procedure Reraise_Occurrence_Always
(X
: Exception_Occurrence
) is
1549 if not ZCX_By_Default
then
1553 Reraise_Occurrence_No_Defer
(X
);
1554 end Reraise_Occurrence_Always
;
1556 ---------------------------------
1557 -- Reraise_Occurrence_No_Defer --
1558 ---------------------------------
1560 procedure Reraise_Occurrence_No_Defer
(X
: Exception_Occurrence
) is
1561 Excep
: constant EOA
:= Exception_Propagation
.Allocate_Occurrence
;
1562 Saved_MO
: constant System
.Address
:= Excep
.Machine_Occurrence
;
1564 Save_Occurrence
(Excep
.all, X
);
1565 Excep
.Machine_Occurrence
:= Saved_MO
;
1566 Complete_And_Propagate_Occurrence
(Excep
);
1567 end Reraise_Occurrence_No_Defer
;
1569 ---------------------
1570 -- Save_Occurrence --
1571 ---------------------
1573 procedure Save_Occurrence
1574 (Target
: out Exception_Occurrence
;
1575 Source
: Exception_Occurrence
)
1578 -- As the machine occurrence might be a data that must be finalized
1579 -- (outside any Ada mechanism), do not copy it
1581 Target
.Id
:= Source
.Id
;
1582 Target
.Machine_Occurrence
:= System
.Null_Address
;
1583 Target
.Msg_Length
:= Source
.Msg_Length
;
1584 Target
.Num_Tracebacks
:= Source
.Num_Tracebacks
;
1585 Target
.Pid
:= Source
.Pid
;
1587 Target
.Msg
(1 .. Target
.Msg_Length
) :=
1588 Source
.Msg
(1 .. Target
.Msg_Length
);
1590 Target
.Tracebacks
(1 .. Target
.Num_Tracebacks
) :=
1591 Source
.Tracebacks
(1 .. Target
.Num_Tracebacks
);
1592 end Save_Occurrence
;
1594 function Save_Occurrence
(Source
: Exception_Occurrence
) return EOA
is
1595 Target
: constant EOA
:= new Exception_Occurrence
;
1597 Save_Occurrence
(Target
.all, Source
);
1599 end Save_Occurrence
;
1605 function String_To_EId
(S
: String) return Exception_Id
1606 renames Stream_Attributes
.String_To_EId
;
1612 function String_To_EO
(S
: String) return Exception_Occurrence
1613 renames Stream_Attributes
.String_To_EO
;
1619 procedure To_Stderr
(C
: Character) is
1620 type int
is new Integer;
1622 procedure put_char_stderr
(C
: int
);
1623 pragma Import
(C
, put_char_stderr
, "put_char_stderr");
1626 put_char_stderr
(Character'Pos (C
));
1629 procedure To_Stderr
(S
: String) is
1631 for J
in S
'Range loop
1632 if S
(J
) /= ASCII
.CR
then
1638 -------------------------
1639 -- Transfer_Occurrence --
1640 -------------------------
1642 procedure Transfer_Occurrence
1643 (Target
: Exception_Occurrence_Access
;
1644 Source
: Exception_Occurrence
)
1647 Save_Occurrence
(Target
.all, Source
);
1648 end Transfer_Occurrence
;
1650 ------------------------
1651 -- Triggered_By_Abort --
1652 ------------------------
1654 function Triggered_By_Abort
return Boolean is
1655 Ex
: constant Exception_Occurrence_Access
:= Get_Current_Excep
.all;
1659 and then Exception_Identity
(Ex
.all) = Standard
'Abort_Signal'Identity;
1660 end Triggered_By_Abort;
1662 -------------------------
1663 -- Wide_Exception_Name --
1664 -------------------------
1666 WC_Encoding : Character;
1667 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
1668 -- Encoding method for source, as exported by binder
1670 function Wide_Exception_Name
1671 (Id : Exception_Id) return Wide_String
1673 S : constant String := Exception_Name (Id);
1674 W : Wide_String (1 .. S'Length);
1677 String_To_Wide_String
1678 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1680 end Wide_Exception_Name;
1682 function Wide_Exception_Name
1683 (X : Exception_Occurrence) return Wide_String
1685 S : constant String := Exception_Name (X);
1686 W : Wide_String (1 .. S'Length);
1689 String_To_Wide_String
1690 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1692 end Wide_Exception_Name;
1694 ----------------------------
1695 -- Wide_Wide_Exception_Name --
1696 -----------------------------
1698 function Wide_Wide_Exception_Name
1699 (Id : Exception_Id) return Wide_Wide_String
1701 S : constant String := Exception_Name (Id);
1702 W : Wide_Wide_String (1 .. S'Length);
1705 String_To_Wide_Wide_String
1706 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1708 end Wide_Wide_Exception_Name;
1710 function Wide_Wide_Exception_Name
1711 (X : Exception_Occurrence) return Wide_Wide_String
1713 S : constant String := Exception_Name (X);
1714 W : Wide_Wide_String (1 .. S'Length);
1717 String_To_Wide_Wide_String
1718 (S, W, L, Get_WC_Encoding_Method (WC_Encoding));
1720 end Wide_Wide_Exception_Name;
1722 --------------------------
1723 -- Code_Address_For_ZZZ --
1724 --------------------------
1726 -- This function gives us the end of the PC range for addresses
1727 -- within the exception unit itself. We hope that gigi/gcc keeps all the
1728 -- procedures in their original order!
1730 function Code_Address_For_ZZZ return System.Address is
1733 return Start_Of_ZZZ'Address;
1734 end Code_Address_For_ZZZ;