]>
Commit | Line | Data |
---|---|---|
8d9254fc | 1 | /* Copyright (C) 2002-2020 Free Software Foundation, Inc. |
ee95f928 BS |
2 | Contributed by Andy Vaught and Paul Brook <paul@nowt.org> |
3 | ||
4 | This file is part of the GNU Fortran runtime library (libgfortran). | |
5 | ||
6 | Libgfortran is free software; you can redistribute it and/or modify | |
7 | it under the terms of the GNU General Public License as published by | |
8 | the Free Software Foundation; either version 3, or (at your option) | |
9 | any later version. | |
10 | ||
11 | Libgfortran is distributed in the hope that it will be useful, | |
12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | GNU General Public License for more details. | |
15 | ||
16 | Under Section 7 of GPL version 3, you are granted additional | |
17 | permissions described in the GCC Runtime Library Exception, version | |
18 | 3.1, as published by the Free Software Foundation. | |
19 | ||
20 | You should have received a copy of the GNU General Public License and | |
21 | a copy of the GCC Runtime Library Exception along with this program; | |
22 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
23 | <http://www.gnu.org/licenses/>. */ | |
24 | ||
25 | #include "libgfortran.h" | |
ee95f928 | 26 | |
41bc80c3 | 27 | #include <string.h> |
ee95f928 BS |
28 | |
29 | #ifdef HAVE_UNISTD_H | |
30 | #include <unistd.h> | |
31 | #endif | |
32 | ||
41bc80c3 TS |
33 | |
34 | #if __nvptx__ | |
35 | /* Map "exit" to "abort"; see PR85463 '[nvptx] "exit" in offloaded region | |
36 | doesn't terminate process'. */ | |
37 | # undef exit | |
38 | # define exit(status) do { (void) (status); abort (); } while (0) | |
39 | #endif | |
40 | ||
41 | ||
42 | #if __nvptx__ | |
43 | /* 'printf' is all we have. */ | |
44 | # undef estr_vprintf | |
45 | # define estr_vprintf vprintf | |
46 | #else | |
47 | # error TODO | |
48 | #endif | |
49 | ||
50 | ||
51 | /* runtime/environ.c */ | |
52 | ||
53 | options_t options; | |
54 | ||
55 | ||
56 | /* runtime/main.c */ | |
57 | ||
ee95f928 BS |
58 | /* Stupid function to be sure the constructor is always linked in, even |
59 | in the case of static linking. See PR libfortran/22298 for details. */ | |
60 | void | |
61 | stupid_function_name_for_static_linking (void) | |
62 | { | |
63 | return; | |
64 | } | |
65 | ||
ee95f928 | 66 | |
ee95f928 BS |
67 | static int argc_save; |
68 | static char **argv_save; | |
69 | ||
41bc80c3 TS |
70 | |
71 | /* Set the saved values of the command line arguments. */ | |
72 | ||
73 | void | |
74 | set_args (int argc, char **argv) | |
75 | { | |
76 | argc_save = argc; | |
77 | argv_save = argv; | |
78 | } | |
79 | iexport(set_args); | |
80 | ||
81 | ||
82 | /* Retrieve the saved values of the command line arguments. */ | |
83 | ||
84 | void | |
85 | get_args (int *argc, char ***argv) | |
86 | { | |
87 | *argc = argc_save; | |
88 | *argv = argv_save; | |
89 | } | |
90 | ||
91 | ||
92 | /* runtime/error.c */ | |
93 | ||
94 | /* Write a null-terminated C string to standard error. This function | |
95 | is async-signal-safe. */ | |
96 | ||
97 | ssize_t | |
98 | estr_write (const char *str) | |
99 | { | |
100 | return write (STDERR_FILENO, str, strlen (str)); | |
101 | } | |
102 | ||
103 | ||
104 | /* printf() like function for for printing to stderr. Uses a stack | |
105 | allocated buffer and doesn't lock stderr, so it should be safe to | |
106 | use from within a signal handler. */ | |
107 | ||
108 | int | |
109 | st_printf (const char * format, ...) | |
110 | { | |
111 | int written; | |
112 | va_list ap; | |
113 | va_start (ap, format); | |
114 | written = estr_vprintf (format, ap); | |
115 | va_end (ap); | |
116 | return written; | |
117 | } | |
118 | ||
119 | ||
120 | /* sys_abort()-- Terminate the program showing backtrace and dumping | |
121 | core. */ | |
122 | ||
123 | void | |
124 | sys_abort (void) | |
125 | { | |
126 | /* If backtracing is enabled, print backtrace and disable signal | |
127 | handler for ABRT. */ | |
128 | if (options.backtrace == 1 | |
129 | || (options.backtrace == -1 && compile_options.backtrace == 1)) | |
130 | { | |
131 | estr_write ("\nProgram aborted.\n"); | |
132 | } | |
133 | ||
134 | abort(); | |
135 | } | |
136 | ||
137 | ||
138 | /* Exit in case of error termination. If backtracing is enabled, print | |
139 | backtrace, then exit. */ | |
140 | ||
141 | void | |
142 | exit_error (int status) | |
143 | { | |
144 | if (options.backtrace == 1 | |
145 | || (options.backtrace == -1 && compile_options.backtrace == 1)) | |
146 | { | |
147 | estr_write ("\nError termination.\n"); | |
148 | } | |
149 | exit (status); | |
150 | } | |
151 | ||
152 | ||
153 | /* show_locus()-- Print a line number and filename describing where | |
154 | * something went wrong */ | |
155 | ||
156 | void | |
157 | show_locus (st_parameter_common *cmp) | |
158 | { | |
159 | char *filename; | |
160 | ||
161 | if (!options.locus || cmp == NULL || cmp->filename == NULL) | |
162 | return; | |
163 | ||
164 | if (cmp->unit > 0) | |
165 | { | |
166 | filename = /* TODO filename_from_unit (cmp->unit) */ NULL; | |
167 | ||
168 | if (filename != NULL) | |
169 | { | |
170 | st_printf ("At line %d of file %s (unit = %d, file = '%s')\n", | |
171 | (int) cmp->line, cmp->filename, (int) cmp->unit, filename); | |
172 | free (filename); | |
173 | } | |
174 | else | |
175 | { | |
176 | st_printf ("At line %d of file %s (unit = %d)\n", | |
177 | (int) cmp->line, cmp->filename, (int) cmp->unit); | |
178 | } | |
179 | return; | |
180 | } | |
181 | ||
182 | st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename); | |
183 | } | |
184 | ||
185 | ||
ee95f928 BS |
186 | /* recursion_check()-- It's possible for additional errors to occur |
187 | * during fatal error processing. We detect this condition here and | |
188 | * exit with code 4 immediately. */ | |
189 | ||
190 | #define MAGIC 0x20DE8101 | |
191 | ||
192 | static void | |
193 | recursion_check (void) | |
194 | { | |
195 | static int magic = 0; | |
196 | ||
197 | /* Don't even try to print something at this point */ | |
198 | if (magic == MAGIC) | |
199 | sys_abort (); | |
200 | ||
201 | magic = MAGIC; | |
202 | } | |
203 | ||
17abb5ac TS |
204 | |
205 | /* os_error()-- Operating system error. We get a message from the | |
206 | * operating system, show it and leave. Some operating system errors | |
207 | * are caught and processed by the library. If not, we come here. */ | |
ee95f928 BS |
208 | |
209 | void | |
210 | os_error (const char *message) | |
211 | { | |
212 | recursion_check (); | |
41bc80c3 TS |
213 | estr_write ("Operating system error: "); |
214 | estr_write (message); | |
215 | estr_write ("\n"); | |
216 | exit_error (1); | |
ee95f928 | 217 | } |
ca72b780 TS |
218 | iexport(os_error); /* TODO, DEPRECATED, ABI: Should not be exported |
219 | anymore when bumping so version. */ | |
220 | ||
221 | ||
222 | /* Improved version of os_error with a printf style format string and | |
223 | a locus. */ | |
224 | ||
225 | void | |
226 | os_error_at (const char *where, const char *message, ...) | |
227 | { | |
228 | va_list ap; | |
229 | ||
230 | recursion_check (); | |
231 | estr_write (where); | |
232 | estr_write (": "); | |
233 | va_start (ap, message); | |
234 | estr_vprintf (message, ap); | |
235 | va_end (ap); | |
236 | estr_write ("\n"); | |
237 | exit_error (1); | |
238 | } | |
239 | iexport(os_error_at); | |
ee95f928 | 240 | |
17abb5ac TS |
241 | |
242 | /* void runtime_error()-- These are errors associated with an | |
243 | * invalid fortran program. */ | |
244 | ||
ee95f928 BS |
245 | void |
246 | runtime_error (const char *message, ...) | |
247 | { | |
248 | va_list ap; | |
249 | ||
250 | recursion_check (); | |
41bc80c3 | 251 | estr_write ("Fortran runtime error: "); |
ee95f928 | 252 | va_start (ap, message); |
41bc80c3 | 253 | estr_vprintf (message, ap); |
ee95f928 | 254 | va_end (ap); |
41bc80c3 TS |
255 | estr_write ("\n"); |
256 | exit_error (2); | |
ee95f928 BS |
257 | } |
258 | iexport(runtime_error); | |
259 | ||
260 | /* void runtime_error_at()-- These are errors associated with a | |
261 | * run time error generated by the front end compiler. */ | |
262 | ||
263 | void | |
264 | runtime_error_at (const char *where, const char *message, ...) | |
265 | { | |
266 | va_list ap; | |
267 | ||
268 | recursion_check (); | |
41bc80c3 TS |
269 | estr_write (where); |
270 | estr_write ("\nFortran runtime error: "); | |
ee95f928 | 271 | va_start (ap, message); |
41bc80c3 | 272 | estr_vprintf (message, ap); |
ee95f928 | 273 | va_end (ap); |
41bc80c3 TS |
274 | estr_write ("\n"); |
275 | exit_error (2); | |
ee95f928 BS |
276 | } |
277 | iexport(runtime_error_at); | |
278 | ||
17abb5ac TS |
279 | |
280 | void | |
281 | runtime_warning_at (const char *where, const char *message, ...) | |
282 | { | |
283 | va_list ap; | |
284 | ||
41bc80c3 TS |
285 | estr_write (where); |
286 | estr_write ("\nFortran runtime warning: "); | |
17abb5ac | 287 | va_start (ap, message); |
41bc80c3 | 288 | estr_vprintf (message, ap); |
17abb5ac | 289 | va_end (ap); |
41bc80c3 | 290 | estr_write ("\n"); |
17abb5ac TS |
291 | } |
292 | iexport(runtime_warning_at); | |
293 | ||
294 | ||
295 | /* void internal_error()-- These are this-can't-happen errors | |
296 | * that indicate something deeply wrong. */ | |
297 | ||
298 | void | |
299 | internal_error (st_parameter_common *cmp, const char *message) | |
300 | { | |
301 | recursion_check (); | |
41bc80c3 TS |
302 | show_locus (cmp); |
303 | estr_write ("Internal Error: "); | |
304 | estr_write (message); | |
305 | estr_write ("\n"); | |
17abb5ac TS |
306 | |
307 | /* This function call is here to get the main.o object file included | |
308 | when linking statically. This works because error.o is supposed to | |
309 | be always linked in (and the function call is in internal_error | |
310 | because hopefully it doesn't happen too often). */ | |
311 | stupid_function_name_for_static_linking(); | |
312 | ||
41bc80c3 | 313 | exit_error (3); |
ee95f928 | 314 | } |
bb347ee2 | 315 | |
6e0d40b6 TS |
316 | |
317 | /* runtime/stop.c */ | |
318 | ||
319 | #undef report_exception | |
320 | #define report_exception() do {} while (0) | |
41bc80c3 | 321 | |
6e0d40b6 | 322 | |
bb347ee2 TK |
323 | /* A numeric STOP statement. */ |
324 | ||
325 | extern _Noreturn void stop_numeric (int, bool); | |
326 | export_proto(stop_numeric); | |
327 | ||
328 | void | |
329 | stop_numeric (int code, bool quiet) | |
330 | { | |
331 | if (!quiet) | |
6e0d40b6 TS |
332 | { |
333 | report_exception (); | |
334 | st_printf ("STOP %d\n", code); | |
335 | } | |
bb347ee2 TK |
336 | exit (code); |
337 | } | |
6e0d40b6 TS |
338 | |
339 | ||
340 | /* A character string or blank STOP statement. */ | |
341 | ||
342 | void | |
343 | stop_string (const char *string, size_t len, bool quiet) | |
344 | { | |
345 | if (!quiet) | |
346 | { | |
347 | report_exception (); | |
348 | if (string) | |
349 | { | |
350 | estr_write ("STOP "); | |
351 | (void) write (STDERR_FILENO, string, len); | |
352 | estr_write ("\n"); | |
353 | } | |
354 | } | |
355 | exit (0); | |
356 | } | |
357 | ||
358 | ||
359 | /* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates | |
360 | normal termination of execution. Execution of an ERROR STOP statement | |
361 | initiates error termination of execution." Thus, error_stop_string returns | |
362 | a nonzero exit status code. */ | |
363 | ||
364 | extern _Noreturn void error_stop_string (const char *, size_t, bool); | |
365 | export_proto(error_stop_string); | |
366 | ||
367 | void | |
368 | error_stop_string (const char *string, size_t len, bool quiet) | |
369 | { | |
370 | if (!quiet) | |
371 | { | |
372 | report_exception (); | |
373 | estr_write ("ERROR STOP "); | |
374 | (void) write (STDERR_FILENO, string, len); | |
375 | estr_write ("\n"); | |
376 | } | |
377 | exit_error (1); | |
378 | } | |
379 | ||
380 | ||
381 | /* A numeric ERROR STOP statement. */ | |
382 | ||
383 | extern _Noreturn void error_stop_numeric (int, bool); | |
384 | export_proto(error_stop_numeric); | |
385 | ||
386 | void | |
387 | error_stop_numeric (int code, bool quiet) | |
388 | { | |
389 | if (!quiet) | |
390 | { | |
391 | report_exception (); | |
392 | st_printf ("ERROR STOP %d\n", code); | |
393 | } | |
394 | exit_error (code); | |
395 | } |