File : a-except-cert.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- A D A . E X C E P T I O N S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This body is part of rts-cert, rts-ravenscar-cert and
33 -- rts-ravenscar-cert-rtp. It implements Ada 83 exception handling, plus a
34 -- subset of the operations available in Ada 95 for Exception_Occurrences
35 -- and Exception_Ids (Exception_Name, Exception_Identity ...).
36
37 with System; use System;
38 with System.Standard_Library; use System.Standard_Library;
39 with System.Soft_Links; use System.Soft_Links;
40
41 package body Ada.Exceptions is
42
43 procedure Last_Chance_Handler (Except : Exception_Occurrence);
44 pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
45 pragma No_Return (Last_Chance_Handler);
46
47 pragma Suppress (All_Checks);
48 -- We definitely do not want exceptions occurring within this unit, or
49 -- we are in big trouble. If an exceptional situation does occur, better
50 -- that it not be raised, since raising it can cause confusing chaos.
51
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
55
56 function Code_Address_For_AAA return System.Address;
57 function Code_Address_For_ZZZ return System.Address;
58 -- Return start and end of procedures in this package
59 --
60 -- These procedures are used to provide exclusion bounds in
61 -- calls to Call_Chain at exception raise points from this unit. The
62 -- purpose is to arrange for the exception tracebacks not to include
63 -- frames from routines involved in the raise process, as these are
64 -- meaningless from the user's standpoint.
65 --
66 -- For these bounds to be meaningful, we need to ensure that the object
67 -- code for the routines involved in processing a raise is located after
68 -- the object code Code_Address_For_AAA and before the object code
69 -- Code_Address_For_ZZZ. This will indeed be the case as long as the
70 -- following rules are respected:
71 --
72 -- 1) The bodies of the subprograms involved in processing a raise
73 -- are located after the body of Code_Address_For_AAA and before the
74 -- body of Code_Address_For_ZZZ.
75 --
76 -- 2) No pragma Inline applies to any of these subprograms, as this
77 -- could delay the corresponding assembly output until the end of
78 -- the unit.
79
80 procedure Call_Chain (Excep : EOA);
81 -- Generate traceback if enabled
82
83 procedure Process_Exception (E : Exception_Id);
84 -- Shared exception processing for raise / reraise
85 pragma No_Return (Process_Exception);
86
87 procedure Raise_Constraint_Error
88 (File : System.Address;
89 Line : Integer);
90 pragma No_Return (Raise_Constraint_Error);
91 pragma Export
92 (C, Raise_Constraint_Error, "__gnat_raise_constraint_error");
93 -- Raise constraint error
94
95 procedure Raise_Current_Excep (E : Exception_Id);
96 pragma No_Return (Raise_Current_Excep);
97 pragma Export (C, Raise_Current_Excep, "__gnat_raise_nodefer_with_msg");
98 -- This is a simple wrapper to Process_Exception
99 --
100 -- This external name for Raise_Current_Excep is historical, and probably
101 -- should be changed but for now we keep it, because gdb and gigi know
102 -- about it.
103
104 procedure Raise_Program_Error
105 (File : System.Address;
106 Line : Integer);
107 pragma No_Return (Raise_Program_Error);
108 pragma Export
109 (C, Raise_Program_Error, "__gnat_raise_program_error");
110 -- Raise program error
111
112 procedure Raise_Storage_Error
113 (File : System.Address;
114 Line : Integer);
115 pragma No_Return (Raise_Storage_Error);
116 pragma Export
117 (C, Raise_Storage_Error, "__gnat_raise_storage_error");
118 -- Raise storage error
119
120 -----------------------------
121 -- Run-Time Check Routines --
122 -----------------------------
123
124 -- These routines raise a specific exception with a reason message
125 -- attached. The parameters are the file name and line number in each
126 -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name.
127
128 procedure Rcheck_CE_Access_Check
129 (File : System.Address; Line : Integer);
130 procedure Rcheck_CE_Null_Access_Parameter
131 (File : System.Address; Line : Integer);
132 procedure Rcheck_CE_Discriminant_Check
133 (File : System.Address; Line : Integer);
134 procedure Rcheck_CE_Divide_By_Zero
135 (File : System.Address; Line : Integer);
136 procedure Rcheck_CE_Explicit_Raise
137 (File : System.Address; Line : Integer);
138 procedure Rcheck_CE_Index_Check
139 (File : System.Address; Line : Integer);
140 procedure Rcheck_CE_Invalid_Data
141 (File : System.Address; Line : Integer);
142 procedure Rcheck_CE_Length_Check
143 (File : System.Address; Line : Integer);
144 procedure Rcheck_CE_Null_Exception_Id
145 (File : System.Address; Line : Integer);
146 procedure Rcheck_CE_Null_Not_Allowed
147 (File : System.Address; Line : Integer);
148 procedure Rcheck_CE_Overflow_Check
149 (File : System.Address; Line : Integer);
150 procedure Rcheck_CE_Partition_Check
151 (File : System.Address; Line : Integer);
152 procedure Rcheck_CE_Range_Check
153 (File : System.Address; Line : Integer);
154 procedure Rcheck_CE_Tag_Check
155 (File : System.Address; Line : Integer);
156 procedure Rcheck_PE_Access_Before_Elaboration
157 (File : System.Address; Line : Integer);
158 procedure Rcheck_PE_Accessibility_Check
159 (File : System.Address; Line : Integer);
160 procedure Rcheck_PE_Address_Of_Intrinsic
161 (File : System.Address; Line : Integer);
162 procedure Rcheck_PE_Aliased_Parameters
163 (File : System.Address; Line : Integer);
164 procedure Rcheck_PE_All_Guards_Closed
165 (File : System.Address; Line : Integer);
166 procedure Rcheck_PE_Bad_Predicated_Generic_Type
167 (File : System.Address; Line : Integer);
168 procedure Rcheck_PE_Current_Task_In_Entry_Body
169 (File : System.Address; Line : Integer);
170 procedure Rcheck_PE_Duplicated_Entry_Address
171 (File : System.Address; Line : Integer);
172 procedure Rcheck_PE_Explicit_Raise
173 (File : System.Address; Line : Integer);
174 procedure Rcheck_PE_Finalize_Raised_Exception
175 (File : System.Address; Line : Integer);
176 procedure Rcheck_PE_Implicit_Return
177 (File : System.Address; Line : Integer);
178 procedure Rcheck_PE_Misaligned_Address_Value
179 (File : System.Address; Line : Integer);
180 procedure Rcheck_PE_Missing_Return
181 (File : System.Address; Line : Integer);
182 procedure Rcheck_PE_Non_Transportable_Actual
183 (File : System.Address; Line : Integer);
184 procedure Rcheck_PE_Overlaid_Controlled_Object
185 (File : System.Address; Line : Integer);
186 procedure Rcheck_PE_Potentially_Blocking_Operation
187 (File : System.Address; Line : Integer);
188 procedure Rcheck_PE_Stream_Operation_Not_Allowed
189 (File : System.Address; Line : Integer);
190 procedure Rcheck_PE_Stubbed_Subprogram_Called
191 (File : System.Address; Line : Integer);
192 procedure Rcheck_PE_Unchecked_Union_Restriction
193 (File : System.Address; Line : Integer);
194 procedure Rcheck_SE_Empty_Storage_Pool
195 (File : System.Address; Line : Integer);
196 procedure Rcheck_SE_Explicit_Raise
197 (File : System.Address; Line : Integer);
198 procedure Rcheck_SE_Infinite_Recursion
199 (File : System.Address; Line : Integer);
200 procedure Rcheck_SE_Object_Too_Large
201 (File : System.Address; Line : Integer);
202
203 pragma Export (C, Rcheck_CE_Access_Check,
204 "__gnat_rcheck_CE_Access_Check");
205 pragma Export (C, Rcheck_CE_Null_Access_Parameter,
206 "__gnat_rcheck_CE_Null_Access_Parameter");
207 pragma Export (C, Rcheck_CE_Discriminant_Check,
208 "__gnat_rcheck_CE_Discriminant_Check");
209 pragma Export (C, Rcheck_CE_Divide_By_Zero,
210 "__gnat_rcheck_CE_Divide_By_Zero");
211 pragma Export (C, Rcheck_CE_Explicit_Raise,
212 "__gnat_rcheck_CE_Explicit_Raise");
213 pragma Export (C, Rcheck_CE_Index_Check,
214 "__gnat_rcheck_CE_Index_Check");
215 pragma Export (C, Rcheck_CE_Invalid_Data,
216 "__gnat_rcheck_CE_Invalid_Data");
217 pragma Export (C, Rcheck_CE_Length_Check,
218 "__gnat_rcheck_CE_Length_Check");
219 pragma Export (C, Rcheck_CE_Null_Exception_Id,
220 "__gnat_rcheck_CE_Null_Exception_Id");
221 pragma Export (C, Rcheck_CE_Null_Not_Allowed,
222 "__gnat_rcheck_CE_Null_Not_Allowed");
223 pragma Export (C, Rcheck_CE_Overflow_Check,
224 "__gnat_rcheck_CE_Overflow_Check");
225 pragma Export (C, Rcheck_CE_Partition_Check,
226 "__gnat_rcheck_CE_Partition_Check");
227 pragma Export (C, Rcheck_CE_Range_Check,
228 "__gnat_rcheck_CE_Range_Check");
229 pragma Export (C, Rcheck_CE_Tag_Check,
230 "__gnat_rcheck_CE_Tag_Check");
231 pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
232 "__gnat_rcheck_PE_Access_Before_Elaboration");
233 pragma Export (C, Rcheck_PE_Accessibility_Check,
234 "__gnat_rcheck_PE_Accessibility_Check");
235 pragma Export (C, Rcheck_PE_Address_Of_Intrinsic,
236 "__gnat_rcheck_PE_Address_Of_Intrinsic");
237 pragma Export (C, Rcheck_PE_Aliased_Parameters,
238 "__gnat_rcheck_PE_Aliased_Parameters");
239 pragma Export (C, Rcheck_PE_All_Guards_Closed,
240 "__gnat_rcheck_PE_All_Guards_Closed");
241 pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type,
242 "__gnat_rcheck_PE_Bad_Predicated_Generic_Type");
243 pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body,
244 "__gnat_rcheck_PE_Current_Task_In_Entry_Body");
245 pragma Export (C, Rcheck_PE_Duplicated_Entry_Address,
246 "__gnat_rcheck_PE_Duplicated_Entry_Address");
247 pragma Export (C, Rcheck_PE_Explicit_Raise,
248 "__gnat_rcheck_PE_Explicit_Raise");
249 pragma Export (C, Rcheck_PE_Finalize_Raised_Exception,
250 "__gnat_rcheck_PE_Finalize_Raised_Exception");
251 pragma Export (C, Rcheck_PE_Implicit_Return,
252 "__gnat_rcheck_PE_Implicit_Return");
253 pragma Export (C, Rcheck_PE_Misaligned_Address_Value,
254 "__gnat_rcheck_PE_Misaligned_Address_Value");
255 pragma Export (C, Rcheck_PE_Missing_Return,
256 "__gnat_rcheck_PE_Missing_Return");
257 pragma Export (C, Rcheck_PE_Non_Transportable_Actual,
258 "__gnat_rcheck_PE_Non_Transportable_Actual");
259 pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object,
260 "__gnat_rcheck_PE_Overlaid_Controlled_Object");
261 pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation,
262 "__gnat_rcheck_PE_Potentially_Blocking_Operation");
263 pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed,
264 "__gnat_rcheck_PE_Stream_Operation_Not_Allowed");
265 pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called,
266 "__gnat_rcheck_PE_Stubbed_Subprogram_Called");
267 pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction,
268 "__gnat_rcheck_PE_Unchecked_Union_Restriction");
269 pragma Export (C, Rcheck_SE_Empty_Storage_Pool,
270 "__gnat_rcheck_SE_Empty_Storage_Pool");
271 pragma Export (C, Rcheck_SE_Explicit_Raise,
272 "__gnat_rcheck_SE_Explicit_Raise");
273 pragma Export (C, Rcheck_SE_Infinite_Recursion,
274 "__gnat_rcheck_SE_Infinite_Recursion");
275 pragma Export (C, Rcheck_SE_Object_Too_Large,
276 "__gnat_rcheck_SE_Object_Too_Large");
277
278 -- None of these procedures ever returns (they raise an exception). By
279 -- using pragma No_Return, we ensure that any junk code after the call,
280 -- such as normal return epilogue stuff, can be eliminated).
281
282 pragma No_Return (Rcheck_CE_Access_Check);
283 pragma No_Return (Rcheck_CE_Null_Access_Parameter);
284 pragma No_Return (Rcheck_CE_Discriminant_Check);
285 pragma No_Return (Rcheck_CE_Divide_By_Zero);
286 pragma No_Return (Rcheck_CE_Explicit_Raise);
287 pragma No_Return (Rcheck_CE_Index_Check);
288 pragma No_Return (Rcheck_CE_Invalid_Data);
289 pragma No_Return (Rcheck_CE_Length_Check);
290 pragma No_Return (Rcheck_CE_Null_Exception_Id);
291 pragma No_Return (Rcheck_CE_Null_Not_Allowed);
292 pragma No_Return (Rcheck_CE_Overflow_Check);
293 pragma No_Return (Rcheck_CE_Partition_Check);
294 pragma No_Return (Rcheck_CE_Range_Check);
295 pragma No_Return (Rcheck_CE_Tag_Check);
296 pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
297 pragma No_Return (Rcheck_PE_Accessibility_Check);
298 pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
299 pragma No_Return (Rcheck_PE_Aliased_Parameters);
300 pragma No_Return (Rcheck_PE_All_Guards_Closed);
301 pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type);
302 pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body);
303 pragma No_Return (Rcheck_PE_Duplicated_Entry_Address);
304 pragma No_Return (Rcheck_PE_Explicit_Raise);
305 pragma No_Return (Rcheck_PE_Implicit_Return);
306 pragma No_Return (Rcheck_PE_Misaligned_Address_Value);
307 pragma No_Return (Rcheck_PE_Missing_Return);
308 pragma No_Return (Rcheck_PE_Non_Transportable_Actual);
309 pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object);
310 pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation);
311 pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed);
312 pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called);
313 pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction);
314 pragma No_Return (Rcheck_PE_Finalize_Raised_Exception);
315 pragma No_Return (Rcheck_SE_Empty_Storage_Pool);
316 pragma No_Return (Rcheck_SE_Explicit_Raise);
317 pragma No_Return (Rcheck_SE_Infinite_Recursion);
318 pragma No_Return (Rcheck_SE_Object_Too_Large);
319
320 --------------------------
321 -- Code_Address_For_AAA --
322 --------------------------
323
324 -- This function gives us the start of the PC range for addresses within
325 -- the exception unit itself. We hope that gigi/gcc keep all the procedures
326 -- in their original order.
327
328 function Code_Address_For_AAA return System.Address is
329 begin
330 -- We are using a label instead of Code_Address_For_AAA'Address because
331 -- on some platforms the latter does not yield the address we want, but
332 -- the address of a stub or of a descriptor instead. This is the case at
333 -- least on PA-HPUX.
334
335 <<Start_Of_AAA>>
336 return Start_Of_AAA'Address;
337 end Code_Address_For_AAA;
338
339 ----------------
340 -- Call_Chain --
341 ----------------
342
343 procedure Call_Chain (Excep : EOA) is separate;
344
345 ------------------------
346 -- Exception_Identity --
347 ------------------------
348
349 function Exception_Identity
350 (X : Exception_Occurrence) return Exception_Id
351 is
352 begin
353 return X.Id;
354 end Exception_Identity;
355
356 --------------------
357 -- Exception_Name --
358 --------------------
359
360 function Exception_Name (X : Exception_Occurrence) return String is
361 begin
362 return Exception_Name (X.Id);
363 end Exception_Name;
364
365 function Exception_Name (Id : Exception_Id) return String is
366 begin
367 return To_Ptr (Id.Full_Name).all (1 .. Id.Name_Length - 1);
368 end Exception_Name;
369
370 --------------------------------------
371 -- Calls to Run-Time Check Routines --
372 --------------------------------------
373
374 procedure Rcheck_CE_Access_Check
375 (File : System.Address; Line : Integer)
376 is
377 begin
378 Raise_Constraint_Error (File, Line);
379 end Rcheck_CE_Access_Check;
380
381 procedure Rcheck_CE_Null_Access_Parameter
382 (File : System.Address; Line : Integer)
383 is
384 begin
385 Raise_Constraint_Error (File, Line);
386 end Rcheck_CE_Null_Access_Parameter;
387
388 procedure Rcheck_CE_Discriminant_Check
389 (File : System.Address; Line : Integer)
390 is
391 begin
392 Raise_Constraint_Error (File, Line);
393 end Rcheck_CE_Discriminant_Check;
394
395 procedure Rcheck_CE_Divide_By_Zero
396 (File : System.Address; Line : Integer)
397 is
398 begin
399 Raise_Constraint_Error (File, Line);
400 end Rcheck_CE_Divide_By_Zero;
401
402 procedure Rcheck_CE_Explicit_Raise
403 (File : System.Address; Line : Integer)
404 is
405 begin
406 Raise_Constraint_Error (File, Line);
407 end Rcheck_CE_Explicit_Raise;
408
409 procedure Rcheck_CE_Index_Check
410 (File : System.Address; Line : Integer)
411 is
412 begin
413 Raise_Constraint_Error (File, Line);
414 end Rcheck_CE_Index_Check;
415
416 procedure Rcheck_CE_Invalid_Data
417 (File : System.Address; Line : Integer)
418 is
419 begin
420 Raise_Constraint_Error (File, Line);
421 end Rcheck_CE_Invalid_Data;
422
423 procedure Rcheck_CE_Length_Check
424 (File : System.Address; Line : Integer)
425 is
426 begin
427 Raise_Constraint_Error (File, Line);
428 end Rcheck_CE_Length_Check;
429
430 procedure Rcheck_CE_Null_Exception_Id
431 (File : System.Address; Line : Integer)
432 is
433 begin
434 Raise_Constraint_Error (File, Line);
435 end Rcheck_CE_Null_Exception_Id;
436
437 procedure Rcheck_CE_Null_Not_Allowed
438 (File : System.Address; Line : Integer)
439 is
440 begin
441 Raise_Constraint_Error (File, Line);
442 end Rcheck_CE_Null_Not_Allowed;
443
444 procedure Rcheck_CE_Overflow_Check
445 (File : System.Address; Line : Integer)
446 is
447 begin
448 Raise_Constraint_Error (File, Line);
449 end Rcheck_CE_Overflow_Check;
450
451 procedure Rcheck_CE_Partition_Check
452 (File : System.Address; Line : Integer)
453 is
454 begin
455 Raise_Constraint_Error (File, Line);
456 end Rcheck_CE_Partition_Check;
457
458 procedure Rcheck_CE_Range_Check
459 (File : System.Address; Line : Integer)
460 is
461 begin
462 Raise_Constraint_Error (File, Line);
463 end Rcheck_CE_Range_Check;
464
465 procedure Rcheck_CE_Tag_Check
466 (File : System.Address; Line : Integer)
467 is
468 begin
469 Raise_Constraint_Error (File, Line);
470 end Rcheck_CE_Tag_Check;
471
472 procedure Rcheck_PE_Access_Before_Elaboration
473 (File : System.Address; Line : Integer)
474 is
475 begin
476 Raise_Program_Error (File, Line);
477 end Rcheck_PE_Access_Before_Elaboration;
478
479 procedure Rcheck_PE_Accessibility_Check
480 (File : System.Address; Line : Integer)
481 is
482 begin
483 Raise_Program_Error (File, Line);
484 end Rcheck_PE_Accessibility_Check;
485
486 procedure Rcheck_PE_Address_Of_Intrinsic
487 (File : System.Address; Line : Integer)
488 is
489 begin
490 Raise_Program_Error (File, Line);
491 end Rcheck_PE_Address_Of_Intrinsic;
492
493 procedure Rcheck_PE_Aliased_Parameters
494 (File : System.Address; Line : Integer)
495 is
496 begin
497 Raise_Program_Error (File, Line);
498 end Rcheck_PE_Aliased_Parameters;
499
500 procedure Rcheck_PE_All_Guards_Closed
501 (File : System.Address; Line : Integer)
502 is
503 begin
504 Raise_Program_Error (File, Line);
505 end Rcheck_PE_All_Guards_Closed;
506
507 procedure Rcheck_PE_Bad_Predicated_Generic_Type
508 (File : System.Address; Line : Integer)
509 is
510 begin
511 Raise_Program_Error (File, Line);
512 end Rcheck_PE_Bad_Predicated_Generic_Type;
513
514 procedure Rcheck_PE_Current_Task_In_Entry_Body
515 (File : System.Address; Line : Integer)
516 is
517 begin
518 Raise_Program_Error (File, Line);
519 end Rcheck_PE_Current_Task_In_Entry_Body;
520
521 procedure Rcheck_PE_Duplicated_Entry_Address
522 (File : System.Address; Line : Integer)
523 is
524 begin
525 Raise_Program_Error (File, Line);
526 end Rcheck_PE_Duplicated_Entry_Address;
527
528 procedure Rcheck_PE_Explicit_Raise
529 (File : System.Address; Line : Integer)
530 is
531 begin
532 Raise_Program_Error (File, Line);
533 end Rcheck_PE_Explicit_Raise;
534
535 procedure Rcheck_PE_Implicit_Return
536 (File : System.Address; Line : Integer)
537 is
538 begin
539 Raise_Program_Error (File, Line);
540 end Rcheck_PE_Implicit_Return;
541
542 procedure Rcheck_PE_Misaligned_Address_Value
543 (File : System.Address; Line : Integer)
544 is
545 begin
546 Raise_Program_Error (File, Line);
547 end Rcheck_PE_Misaligned_Address_Value;
548
549 procedure Rcheck_PE_Missing_Return
550 (File : System.Address; Line : Integer)
551 is
552 begin
553 Raise_Program_Error (File, Line);
554 end Rcheck_PE_Missing_Return;
555
556 procedure Rcheck_PE_Non_Transportable_Actual
557 (File : System.Address; Line : Integer)
558 is
559 begin
560 Raise_Program_Error (File, Line);
561 end Rcheck_PE_Non_Transportable_Actual;
562
563 procedure Rcheck_PE_Overlaid_Controlled_Object
564 (File : System.Address; Line : Integer)
565 is
566 begin
567 Raise_Program_Error (File, Line);
568 end Rcheck_PE_Overlaid_Controlled_Object;
569
570 procedure Rcheck_PE_Potentially_Blocking_Operation
571 (File : System.Address; Line : Integer)
572 is
573 begin
574 Raise_Program_Error (File, Line);
575 end Rcheck_PE_Potentially_Blocking_Operation;
576
577 procedure Rcheck_PE_Stream_Operation_Not_Allowed
578 (File : System.Address; Line : Integer)
579 is
580 begin
581 Raise_Program_Error (File, Line);
582 end Rcheck_PE_Stream_Operation_Not_Allowed;
583
584 procedure Rcheck_PE_Stubbed_Subprogram_Called
585 (File : System.Address; Line : Integer)
586 is
587 begin
588 Raise_Program_Error (File, Line);
589 end Rcheck_PE_Stubbed_Subprogram_Called;
590
591 procedure Rcheck_PE_Unchecked_Union_Restriction
592 (File : System.Address; Line : Integer)
593 is
594 begin
595 Raise_Program_Error (File, Line);
596 end Rcheck_PE_Unchecked_Union_Restriction;
597
598 procedure Rcheck_SE_Empty_Storage_Pool
599 (File : System.Address; Line : Integer)
600 is
601 begin
602 Raise_Storage_Error (File, Line);
603 end Rcheck_SE_Empty_Storage_Pool;
604
605 procedure Rcheck_SE_Explicit_Raise
606 (File : System.Address; Line : Integer)
607 is
608 begin
609 Raise_Storage_Error (File, Line);
610 end Rcheck_SE_Explicit_Raise;
611
612 procedure Rcheck_SE_Infinite_Recursion
613 (File : System.Address; Line : Integer)
614 is
615 begin
616 Raise_Storage_Error (File, Line);
617 end Rcheck_SE_Infinite_Recursion;
618
619 procedure Rcheck_SE_Object_Too_Large
620 (File : System.Address; Line : Integer)
621 is
622 begin
623 Raise_Storage_Error (File, Line);
624 end Rcheck_SE_Object_Too_Large;
625
626 procedure Rcheck_PE_Finalize_Raised_Exception
627 (File : System.Address; Line : Integer)
628 is
629 begin
630 Raise_Program_Error (File, Line);
631 end Rcheck_PE_Finalize_Raised_Exception;
632
633 ----------------------------
634 -- Raise_Constraint_Error --
635 ----------------------------
636
637 procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is
638 pragma Unreferenced (File, Line);
639 begin
640 Raise_Current_Excep (Constraint_Error_Def'Access);
641 end Raise_Constraint_Error;
642
643 -----------------------
644 -- Process_Exception --
645 -----------------------
646
647 procedure Process_Exception (E : Exception_Id) is
648 Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all;
649 Excep : constant EOA := Get_Current_Excep.all;
650
651 begin
652 -- Store the identifier for this exception because it may be
653 -- needed by a reraise.
654
655 Excep.Id := E;
656
657 -- Generate traceback if enabled. Call_Chain determines whether this
658 -- is a reraise, as is done for the full run-time
659
660 Call_Chain (Excep);
661
662 -- WARNING : There should be no exception handler for this body
663 -- because this would cause gigi to prepend a setup for a new
664 -- jmpbuf to the sequence of statements. We would then always get
665 -- this new buf in Jumpbuf_Ptr instead of the one for the exception
666 -- we are handling, which would completely break the whole design
667 -- of this procedure.
668
669 -- If the jump buffer pointer is non-null, transfer control using
670 -- it. Otherwise, this is an unhandled exception.
671
672 if Jumpbuf_Ptr /= Null_Address then
673 builtin_longjmp (To_Jmpbuf_Address (Jumpbuf_Ptr), 1);
674 else
675 -- Code to be executed for unhandled exceptions
676
677 Last_Chance_Handler (Excep.all);
678 end if;
679 end Process_Exception;
680
681 -------------------------
682 -- Raise_Current_Excep --
683 -------------------------
684
685 procedure Raise_Current_Excep (E : Exception_Id) is
686
687 pragma Inspection_Point (E);
688 -- This is so the debugger can reliably inspect the parameter when
689 -- inserting a breakpoint at the start of this procedure.
690
691 -- To provide support for breakpoints on unhandled exceptions, the
692 -- debugger will also need to be able to inspect the value of E from
693 -- inner frames so we need to make sure that its value is also spilled
694 -- on stack. We take the address and dereference using volatile local
695 -- objects for this purpose.
696
697 -- The pragma Warnings (Off) are needed because the compiler knows that
698 -- these locals are not referenced and that this use of pragma Volatile
699 -- is peculiar.
700
701 type EID_Access is access Exception_Id;
702
703 Access_To_E : EID_Access := E'Unrestricted_Access;
704 pragma Volatile (Access_To_E);
705 pragma Warnings (Off, Access_To_E);
706
707 Id : Exception_Id := Access_To_E.all;
708 pragma Volatile (Id);
709 pragma Warnings (Off, Id);
710
711 Excep : constant EOA := Get_Current_Excep.all;
712
713 begin
714 -- This is done in Exception_Data.Set_Exception_Msg in the full run-time
715 -- but we do not support exception messages here.
716
717 Excep.Id := E;
718 Excep.Num_Tracebacks := 0;
719
720 Process_Exception (E);
721 end Raise_Current_Excep;
722
723 ---------------------
724 -- Raise_Exception --
725 ---------------------
726
727 procedure Raise_Exception (E : Exception_Id; Message : String := "") is
728 pragma Unreferenced (Message);
729 -- This appears to be as early as we can start ignoring the "Message"
730 -- parameter, since "Raise_Exception" is externally callable.
731 begin
732 Raise_Current_Excep (E);
733 end Raise_Exception;
734
735 ----------------------------
736 -- Raise_Exception_Always --
737 ----------------------------
738
739 procedure Raise_Exception_Always
740 (E : Exception_Id;
741 Message : String := "") renames Raise_Exception;
742
743 -------------------------
744 -- Raise_Program_Error --
745 -------------------------
746
747 procedure Raise_Program_Error (File : System.Address; Line : Integer) is
748 pragma Unreferenced (File, Line);
749 begin
750 Raise_Current_Excep (Program_Error_Def'Access);
751 end Raise_Program_Error;
752
753 -------------------------
754 -- Raise_Storage_Error --
755 -------------------------
756
757 procedure Raise_Storage_Error (File : System.Address; Line : Integer) is
758 pragma Unreferenced (File, Line);
759 begin
760 Raise_Current_Excep (Storage_Error_Def'Access);
761 end Raise_Storage_Error;
762
763 ------------------------
764 -- Reraise_Occurrence --
765 ------------------------
766
767 procedure Reraise_Occurrence (X : Exception_Occurrence) is
768 begin
769 Process_Exception (X.Id);
770 end Reraise_Occurrence;
771
772 -------------------------------
773 -- Reraise_Occurrence_Always --
774 -------------------------------
775
776 procedure Reraise_Occurrence_Always (X : Exception_Occurrence)
777 renames Reraise_Occurrence;
778
779 ---------------------------------
780 -- Reraise_Occurrence_No_Defer --
781 ---------------------------------
782
783 procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence)
784 renames Reraise_Occurrence;
785
786 ---------------------
787 -- Save_Occurrence --
788 ---------------------
789
790 procedure Save_Occurrence
791 (Target : out Exception_Occurrence;
792 Source : Exception_Occurrence)
793 is
794 begin
795 Target.Id := Source.Id;
796 Target.Num_Tracebacks := Source.Num_Tracebacks;
797
798 Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
799 Source.Tracebacks (1 .. Target.Num_Tracebacks);
800 end Save_Occurrence;
801
802 --------------------------
803 -- Code_Address_For_ZZZ --
804 --------------------------
805
806 -- This function gives us the end of the PC range for addresses
807 -- within the exception unit itself. We hope that gigi/gcc keeps all the
808 -- procedures in their original order.
809
810 function Code_Address_For_ZZZ return System.Address is
811 begin
812 <<Start_Of_ZZZ>>
813 return Start_Of_ZZZ'Address;
814 end Code_Address_For_ZZZ;
815
816 end Ada.Exceptions;