1 /* Copyright (C) 2002-2023 Free Software Foundation, Inc.
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"
26
27 #include <string.h>
28
29 #ifdef HAVE_UNISTD_H
30 #include <unistd.h>
31 #endif
32
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
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
66
67 static int argc_save;
68 static char **argv_save;
69
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
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
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. */
208
209 void
210 os_error (const char *message)
211 {
212 recursion_check ();
213 estr_write ("Operating system error: ");
214 estr_write (message);
215 estr_write ("\n");
216 exit_error (1);
217 }
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);
240
241
242 /* void runtime_error()-- These are errors associated with an
243 * invalid fortran program. */
244
245 void
246 runtime_error (const char *message, ...)
247 {
248 va_list ap;
249
250 recursion_check ();
251 estr_write ("Fortran runtime error: ");
252 va_start (ap, message);
253 estr_vprintf (message, ap);
254 va_end (ap);
255 estr_write ("\n");
256 exit_error (2);
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 ();
269 estr_write (where);
270 estr_write ("\nFortran runtime error: ");
271 va_start (ap, message);
272 estr_vprintf (message, ap);
273 va_end (ap);
274 estr_write ("\n");
275 exit_error (2);
276 }
277 iexport(runtime_error_at);
278
279
280 void
281 runtime_warning_at (const char *where, const char *message, ...)
282 {
283 va_list ap;
284
285 estr_write (where);
286 estr_write ("\nFortran runtime warning: ");
287 va_start (ap, message);
288 estr_vprintf (message, ap);
289 va_end (ap);
290 estr_write ("\n");
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 ();
302 show_locus (cmp);
303 estr_write ("Internal Error: ");
304 estr_write (message);
305 estr_write ("\n");
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
313 exit_error (3);
314 }
315
316
317 /* runtime/stop.c */
318
319 #undef report_exception
320 #define report_exception() do {} while (0)
321
322
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)
332 {
333 report_exception ();
334 st_printf ("STOP %d\n", code);
335 }
336 exit (code);
337 }
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 }