Mercurial > hg > CbC > CbC_gcc

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2003-2017, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- Default version for most targets
33
34 pragma Compiler_Unit_Warning;
35
36 with System.Standard_Library; use System.Standard_Library;
37 with System.Soft_Links;
38
39 procedure Ada.Exceptions.Last_Chance_Handler
40 (Except : Exception_Occurrence)
41 is
42 procedure Unhandled_Terminate;
43 pragma No_Return (Unhandled_Terminate);
44 pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
45 -- Perform system dependent shutdown code
46
47 function Exception_Message_Length
48 (X : Exception_Occurrence) return Natural;
49 pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len");
50
51 procedure Append_Info_Exception_Message
52 (X : Exception_Occurrence;
53 Info : in out String;
54 Ptr : in out Natural);
55 pragma Import
56 (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg");
57
58 procedure Append_Info_Untailored_Exception_Information
59 (X : Exception_Occurrence;
60 Info : in out String;
61 Ptr : in out Natural);
62 pragma Import
63 (Ada, Append_Info_Untailored_Exception_Information,
64 "__gnat_append_info_u_e_info");
65
66 procedure To_Stderr (S : String);
67 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
68 -- Little routine to output string to stderr
69
70 Ptr : Natural := 0;
71 Nobuf : String (1 .. 0);
72
73 Nline : constant String := String'(1 => ASCII.LF);
74 -- Convenient shortcut
75
76 begin
77 -- Do not execute any task termination code when shutting down the system.
78 -- The Adafinal procedure would execute the task termination routine for
79 -- normal termination, but we have already executed the task termination
80 -- procedure because of an unhandled exception.
81
82 System.Soft_Links.Task_Termination_Handler :=
83 System.Soft_Links.Task_Termination_NT'Access;
84
85 -- We shutdown the runtime now. The rest of the procedure needs to be
86 -- careful not to use anything that would require runtime support. In
87 -- particular, functions returning strings are banned since the sec stack
88 -- is no longer functional. This is particularly important to note for the
89 -- Exception_Information output. We used to allow the tailored version to
90 -- show up here, which turned out to be a bad idea as it might involve a
91 -- traceback decorator the length of which we don't control. Potentially
92 -- heavy primary/secondary stack use or dynamic allocations right before
93 -- this point are not welcome, moving the output before the finalization
94 -- raises order of outputs concerns, and decorators are intended to only
95 -- be used with exception traces, which should have been issued already.
96
97 System.Standard_Library.Adafinal;
98
99 -- Print a message only when exception traces are not active
100
101 if Exception_Trace /= RM_Convention then
102 null;
103
104 -- Check for special case of raising _ABORT_SIGNAL, which is not
105 -- really an exception at all. We recognize this by the fact that
106 -- it is the only exception whose name starts with underscore.
107
108 elsif To_Ptr (Except.Id.Full_Name) (1) = '_' then
109 To_Stderr (Nline);
110 To_Stderr ("Execution terminated by abort of environment task");
111 To_Stderr (Nline);
112
113 -- If no tracebacks, we print the unhandled exception in the old style
114 -- (i.e. the style used before ZCX was implemented). We do this to
115 -- retain compatibility.
116
117 elsif Except.Num_Tracebacks = 0 then
118 To_Stderr (Nline);
119 To_Stderr ("raised ");
120 To_Stderr
121 (To_Ptr (Except.Id.Full_Name) (1 .. Except.Id.Name_Length - 1));
122
123 if Exception_Message_Length (Except) /= 0 then
124 To_Stderr (" : ");
125 Append_Info_Exception_Message (Except, Nobuf, Ptr);
126 end if;
127
128 To_Stderr (Nline);
129
130 -- Traceback exists
131
132 else
133 To_Stderr (Nline);
134 To_Stderr ("Execution terminated by unhandled exception");
135 To_Stderr (Nline);
136
137 Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr);
138 end if;
139
140 Unhandled_Terminate;
141 end Ada.Exceptions.Last_Chance_Handler;