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