1*0bfacb9bSmrg /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2760c2415Smrg Contributed by Andy Vaught and Paul Brook <paul@nowt.org>
3760c2415Smrg
4760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
5760c2415Smrg
6760c2415Smrg Libgfortran is free software; you can redistribute it and/or modify
7760c2415Smrg it under the terms of the GNU General Public License as published by
8760c2415Smrg the Free Software Foundation; either version 3, or (at your option)
9760c2415Smrg any later version.
10760c2415Smrg
11760c2415Smrg Libgfortran is distributed in the hope that it will be useful,
12760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
13760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14760c2415Smrg GNU General Public License for more details.
15760c2415Smrg
16760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
17760c2415Smrg permissions described in the GCC Runtime Library Exception, version
18760c2415Smrg 3.1, as published by the Free Software Foundation.
19760c2415Smrg
20760c2415Smrg You should have received a copy of the GNU General Public License and
21760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
22760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23760c2415Smrg <http://www.gnu.org/licenses/>. */
24760c2415Smrg
25760c2415Smrg #include "libgfortran.h"
26760c2415Smrg
27*0bfacb9bSmrg #include <string.h>
28760c2415Smrg
29760c2415Smrg #ifdef HAVE_UNISTD_H
30760c2415Smrg #include <unistd.h>
31760c2415Smrg #endif
32760c2415Smrg
33*0bfacb9bSmrg
34*0bfacb9bSmrg #if __nvptx__
35*0bfacb9bSmrg /* Map "exit" to "abort"; see PR85463 '[nvptx] "exit" in offloaded region
36*0bfacb9bSmrg doesn't terminate process'. */
37*0bfacb9bSmrg # undef exit
38*0bfacb9bSmrg # define exit(status) do { (void) (status); abort (); } while (0)
39*0bfacb9bSmrg #endif
40*0bfacb9bSmrg
41*0bfacb9bSmrg
42*0bfacb9bSmrg #if __nvptx__
43*0bfacb9bSmrg /* 'printf' is all we have. */
44*0bfacb9bSmrg # undef estr_vprintf
45*0bfacb9bSmrg # define estr_vprintf vprintf
46*0bfacb9bSmrg #else
47*0bfacb9bSmrg # error TODO
48*0bfacb9bSmrg #endif
49*0bfacb9bSmrg
50*0bfacb9bSmrg
51*0bfacb9bSmrg /* runtime/environ.c */
52*0bfacb9bSmrg
53*0bfacb9bSmrg options_t options;
54*0bfacb9bSmrg
55*0bfacb9bSmrg
56*0bfacb9bSmrg /* runtime/main.c */
57*0bfacb9bSmrg
58760c2415Smrg /* Stupid function to be sure the constructor is always linked in, even
59760c2415Smrg in the case of static linking. See PR libfortran/22298 for details. */
60760c2415Smrg void
stupid_function_name_for_static_linking(void)61760c2415Smrg stupid_function_name_for_static_linking (void)
62760c2415Smrg {
63760c2415Smrg return;
64760c2415Smrg }
65760c2415Smrg
66760c2415Smrg
67760c2415Smrg static int argc_save;
68760c2415Smrg static char **argv_save;
69760c2415Smrg
70*0bfacb9bSmrg
71*0bfacb9bSmrg /* Set the saved values of the command line arguments. */
72*0bfacb9bSmrg
73*0bfacb9bSmrg void
set_args(int argc,char ** argv)74*0bfacb9bSmrg set_args (int argc, char **argv)
75*0bfacb9bSmrg {
76*0bfacb9bSmrg argc_save = argc;
77*0bfacb9bSmrg argv_save = argv;
78*0bfacb9bSmrg }
79*0bfacb9bSmrg iexport(set_args);
80*0bfacb9bSmrg
81*0bfacb9bSmrg
82*0bfacb9bSmrg /* Retrieve the saved values of the command line arguments. */
83*0bfacb9bSmrg
84*0bfacb9bSmrg void
get_args(int * argc,char *** argv)85*0bfacb9bSmrg get_args (int *argc, char ***argv)
86*0bfacb9bSmrg {
87*0bfacb9bSmrg *argc = argc_save;
88*0bfacb9bSmrg *argv = argv_save;
89*0bfacb9bSmrg }
90*0bfacb9bSmrg
91*0bfacb9bSmrg
92*0bfacb9bSmrg /* runtime/error.c */
93*0bfacb9bSmrg
94*0bfacb9bSmrg /* Write a null-terminated C string to standard error. This function
95*0bfacb9bSmrg is async-signal-safe. */
96*0bfacb9bSmrg
97*0bfacb9bSmrg ssize_t
estr_write(const char * str)98*0bfacb9bSmrg estr_write (const char *str)
99*0bfacb9bSmrg {
100*0bfacb9bSmrg return write (STDERR_FILENO, str, strlen (str));
101*0bfacb9bSmrg }
102*0bfacb9bSmrg
103*0bfacb9bSmrg
104*0bfacb9bSmrg /* printf() like function for for printing to stderr. Uses a stack
105*0bfacb9bSmrg allocated buffer and doesn't lock stderr, so it should be safe to
106*0bfacb9bSmrg use from within a signal handler. */
107*0bfacb9bSmrg
108*0bfacb9bSmrg int
st_printf(const char * format,...)109*0bfacb9bSmrg st_printf (const char * format, ...)
110*0bfacb9bSmrg {
111*0bfacb9bSmrg int written;
112*0bfacb9bSmrg va_list ap;
113*0bfacb9bSmrg va_start (ap, format);
114*0bfacb9bSmrg written = estr_vprintf (format, ap);
115*0bfacb9bSmrg va_end (ap);
116*0bfacb9bSmrg return written;
117*0bfacb9bSmrg }
118*0bfacb9bSmrg
119*0bfacb9bSmrg
120*0bfacb9bSmrg /* sys_abort()-- Terminate the program showing backtrace and dumping
121*0bfacb9bSmrg core. */
122*0bfacb9bSmrg
123*0bfacb9bSmrg void
sys_abort(void)124*0bfacb9bSmrg sys_abort (void)
125*0bfacb9bSmrg {
126*0bfacb9bSmrg /* If backtracing is enabled, print backtrace and disable signal
127*0bfacb9bSmrg handler for ABRT. */
128*0bfacb9bSmrg if (options.backtrace == 1
129*0bfacb9bSmrg || (options.backtrace == -1 && compile_options.backtrace == 1))
130*0bfacb9bSmrg {
131*0bfacb9bSmrg estr_write ("\nProgram aborted.\n");
132*0bfacb9bSmrg }
133*0bfacb9bSmrg
134*0bfacb9bSmrg abort();
135*0bfacb9bSmrg }
136*0bfacb9bSmrg
137*0bfacb9bSmrg
138*0bfacb9bSmrg /* Exit in case of error termination. If backtracing is enabled, print
139*0bfacb9bSmrg backtrace, then exit. */
140*0bfacb9bSmrg
141*0bfacb9bSmrg void
exit_error(int status)142*0bfacb9bSmrg exit_error (int status)
143*0bfacb9bSmrg {
144*0bfacb9bSmrg if (options.backtrace == 1
145*0bfacb9bSmrg || (options.backtrace == -1 && compile_options.backtrace == 1))
146*0bfacb9bSmrg {
147*0bfacb9bSmrg estr_write ("\nError termination.\n");
148*0bfacb9bSmrg }
149*0bfacb9bSmrg exit (status);
150*0bfacb9bSmrg }
151*0bfacb9bSmrg
152*0bfacb9bSmrg
153*0bfacb9bSmrg /* show_locus()-- Print a line number and filename describing where
154*0bfacb9bSmrg * something went wrong */
155*0bfacb9bSmrg
156*0bfacb9bSmrg void
show_locus(st_parameter_common * cmp)157*0bfacb9bSmrg show_locus (st_parameter_common *cmp)
158*0bfacb9bSmrg {
159*0bfacb9bSmrg char *filename;
160*0bfacb9bSmrg
161*0bfacb9bSmrg if (!options.locus || cmp == NULL || cmp->filename == NULL)
162*0bfacb9bSmrg return;
163*0bfacb9bSmrg
164*0bfacb9bSmrg if (cmp->unit > 0)
165*0bfacb9bSmrg {
166*0bfacb9bSmrg filename = /* TODO filename_from_unit (cmp->unit) */ NULL;
167*0bfacb9bSmrg
168*0bfacb9bSmrg if (filename != NULL)
169*0bfacb9bSmrg {
170*0bfacb9bSmrg st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
171*0bfacb9bSmrg (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
172*0bfacb9bSmrg free (filename);
173*0bfacb9bSmrg }
174*0bfacb9bSmrg else
175*0bfacb9bSmrg {
176*0bfacb9bSmrg st_printf ("At line %d of file %s (unit = %d)\n",
177*0bfacb9bSmrg (int) cmp->line, cmp->filename, (int) cmp->unit);
178*0bfacb9bSmrg }
179*0bfacb9bSmrg return;
180*0bfacb9bSmrg }
181*0bfacb9bSmrg
182*0bfacb9bSmrg st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
183*0bfacb9bSmrg }
184*0bfacb9bSmrg
185*0bfacb9bSmrg
186760c2415Smrg /* recursion_check()-- It's possible for additional errors to occur
187760c2415Smrg * during fatal error processing. We detect this condition here and
188760c2415Smrg * exit with code 4 immediately. */
189760c2415Smrg
190760c2415Smrg #define MAGIC 0x20DE8101
191760c2415Smrg
192760c2415Smrg static void
recursion_check(void)193760c2415Smrg recursion_check (void)
194760c2415Smrg {
195760c2415Smrg static int magic = 0;
196760c2415Smrg
197760c2415Smrg /* Don't even try to print something at this point */
198760c2415Smrg if (magic == MAGIC)
199760c2415Smrg sys_abort ();
200760c2415Smrg
201760c2415Smrg magic = MAGIC;
202760c2415Smrg }
203760c2415Smrg
204760c2415Smrg
205760c2415Smrg /* os_error()-- Operating system error. We get a message from the
206760c2415Smrg * operating system, show it and leave. Some operating system errors
207760c2415Smrg * are caught and processed by the library. If not, we come here. */
208760c2415Smrg
209760c2415Smrg void
os_error(const char * message)210760c2415Smrg os_error (const char *message)
211760c2415Smrg {
212760c2415Smrg recursion_check ();
213*0bfacb9bSmrg estr_write ("Operating system error: ");
214*0bfacb9bSmrg estr_write (message);
215*0bfacb9bSmrg estr_write ("\n");
216*0bfacb9bSmrg exit_error (1);
217760c2415Smrg }
218*0bfacb9bSmrg iexport(os_error); /* TODO, DEPRECATED, ABI: Should not be exported
219*0bfacb9bSmrg anymore when bumping so version. */
220*0bfacb9bSmrg
221*0bfacb9bSmrg
222*0bfacb9bSmrg /* Improved version of os_error with a printf style format string and
223*0bfacb9bSmrg a locus. */
224*0bfacb9bSmrg
225*0bfacb9bSmrg void
os_error_at(const char * where,const char * message,...)226*0bfacb9bSmrg os_error_at (const char *where, const char *message, ...)
227*0bfacb9bSmrg {
228*0bfacb9bSmrg va_list ap;
229*0bfacb9bSmrg
230*0bfacb9bSmrg recursion_check ();
231*0bfacb9bSmrg estr_write (where);
232*0bfacb9bSmrg estr_write (": ");
233*0bfacb9bSmrg va_start (ap, message);
234*0bfacb9bSmrg estr_vprintf (message, ap);
235*0bfacb9bSmrg va_end (ap);
236*0bfacb9bSmrg estr_write ("\n");
237*0bfacb9bSmrg exit_error (1);
238*0bfacb9bSmrg }
239*0bfacb9bSmrg iexport(os_error_at);
240760c2415Smrg
241760c2415Smrg
242760c2415Smrg /* void runtime_error()-- These are errors associated with an
243760c2415Smrg * invalid fortran program. */
244760c2415Smrg
245760c2415Smrg void
runtime_error(const char * message,...)246760c2415Smrg runtime_error (const char *message, ...)
247760c2415Smrg {
248760c2415Smrg va_list ap;
249760c2415Smrg
250760c2415Smrg recursion_check ();
251*0bfacb9bSmrg estr_write ("Fortran runtime error: ");
252760c2415Smrg va_start (ap, message);
253*0bfacb9bSmrg estr_vprintf (message, ap);
254760c2415Smrg va_end (ap);
255*0bfacb9bSmrg estr_write ("\n");
256*0bfacb9bSmrg exit_error (2);
257760c2415Smrg }
258760c2415Smrg iexport(runtime_error);
259760c2415Smrg
260760c2415Smrg /* void runtime_error_at()-- These are errors associated with a
261760c2415Smrg * run time error generated by the front end compiler. */
262760c2415Smrg
263760c2415Smrg void
runtime_error_at(const char * where,const char * message,...)264760c2415Smrg runtime_error_at (const char *where, const char *message, ...)
265760c2415Smrg {
266760c2415Smrg va_list ap;
267760c2415Smrg
268760c2415Smrg recursion_check ();
269*0bfacb9bSmrg estr_write (where);
270*0bfacb9bSmrg estr_write ("\nFortran runtime error: ");
271760c2415Smrg va_start (ap, message);
272*0bfacb9bSmrg estr_vprintf (message, ap);
273760c2415Smrg va_end (ap);
274*0bfacb9bSmrg estr_write ("\n");
275*0bfacb9bSmrg exit_error (2);
276760c2415Smrg }
277760c2415Smrg iexport(runtime_error_at);
278760c2415Smrg
279760c2415Smrg
280760c2415Smrg void
runtime_warning_at(const char * where,const char * message,...)281760c2415Smrg runtime_warning_at (const char *where, const char *message, ...)
282760c2415Smrg {
283760c2415Smrg va_list ap;
284760c2415Smrg
285*0bfacb9bSmrg estr_write (where);
286*0bfacb9bSmrg estr_write ("\nFortran runtime warning: ");
287760c2415Smrg va_start (ap, message);
288*0bfacb9bSmrg estr_vprintf (message, ap);
289760c2415Smrg va_end (ap);
290*0bfacb9bSmrg estr_write ("\n");
291760c2415Smrg }
292760c2415Smrg iexport(runtime_warning_at);
293760c2415Smrg
294760c2415Smrg
295760c2415Smrg /* void internal_error()-- These are this-can't-happen errors
296760c2415Smrg * that indicate something deeply wrong. */
297760c2415Smrg
298760c2415Smrg void
internal_error(st_parameter_common * cmp,const char * message)299760c2415Smrg internal_error (st_parameter_common *cmp, const char *message)
300760c2415Smrg {
301760c2415Smrg recursion_check ();
302*0bfacb9bSmrg show_locus (cmp);
303*0bfacb9bSmrg estr_write ("Internal Error: ");
304*0bfacb9bSmrg estr_write (message);
305*0bfacb9bSmrg estr_write ("\n");
306760c2415Smrg
307760c2415Smrg /* This function call is here to get the main.o object file included
308760c2415Smrg when linking statically. This works because error.o is supposed to
309760c2415Smrg be always linked in (and the function call is in internal_error
310760c2415Smrg because hopefully it doesn't happen too often). */
311760c2415Smrg stupid_function_name_for_static_linking();
312760c2415Smrg
313*0bfacb9bSmrg exit_error (3);
314760c2415Smrg }
315760c2415Smrg
316760c2415Smrg
317760c2415Smrg /* runtime/stop.c */
318760c2415Smrg
319760c2415Smrg #undef report_exception
320760c2415Smrg #define report_exception() do {} while (0)
321*0bfacb9bSmrg
322760c2415Smrg
323760c2415Smrg /* A numeric STOP statement. */
324760c2415Smrg
325760c2415Smrg extern _Noreturn void stop_numeric (int, bool);
326760c2415Smrg export_proto(stop_numeric);
327760c2415Smrg
328760c2415Smrg void
stop_numeric(int code,bool quiet)329760c2415Smrg stop_numeric (int code, bool quiet)
330760c2415Smrg {
331760c2415Smrg if (!quiet)
332760c2415Smrg {
333760c2415Smrg report_exception ();
334760c2415Smrg st_printf ("STOP %d\n", code);
335760c2415Smrg }
336760c2415Smrg exit (code);
337760c2415Smrg }
338760c2415Smrg
339760c2415Smrg
340760c2415Smrg /* A character string or blank STOP statement. */
341760c2415Smrg
342760c2415Smrg void
stop_string(const char * string,size_t len,bool quiet)343760c2415Smrg stop_string (const char *string, size_t len, bool quiet)
344760c2415Smrg {
345760c2415Smrg if (!quiet)
346760c2415Smrg {
347760c2415Smrg report_exception ();
348760c2415Smrg if (string)
349760c2415Smrg {
350760c2415Smrg estr_write ("STOP ");
351760c2415Smrg (void) write (STDERR_FILENO, string, len);
352760c2415Smrg estr_write ("\n");
353760c2415Smrg }
354760c2415Smrg }
355760c2415Smrg exit (0);
356760c2415Smrg }
357760c2415Smrg
358760c2415Smrg
359760c2415Smrg /* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates
360760c2415Smrg normal termination of execution. Execution of an ERROR STOP statement
361760c2415Smrg initiates error termination of execution." Thus, error_stop_string returns
362760c2415Smrg a nonzero exit status code. */
363760c2415Smrg
364760c2415Smrg extern _Noreturn void error_stop_string (const char *, size_t, bool);
365760c2415Smrg export_proto(error_stop_string);
366760c2415Smrg
367760c2415Smrg void
error_stop_string(const char * string,size_t len,bool quiet)368760c2415Smrg error_stop_string (const char *string, size_t len, bool quiet)
369760c2415Smrg {
370760c2415Smrg if (!quiet)
371760c2415Smrg {
372760c2415Smrg report_exception ();
373760c2415Smrg estr_write ("ERROR STOP ");
374760c2415Smrg (void) write (STDERR_FILENO, string, len);
375760c2415Smrg estr_write ("\n");
376760c2415Smrg }
377760c2415Smrg exit_error (1);
378760c2415Smrg }
379760c2415Smrg
380760c2415Smrg
381760c2415Smrg /* A numeric ERROR STOP statement. */
382760c2415Smrg
383760c2415Smrg extern _Noreturn void error_stop_numeric (int, bool);
384760c2415Smrg export_proto(error_stop_numeric);
385760c2415Smrg
386760c2415Smrg void
error_stop_numeric(int code,bool quiet)387760c2415Smrg error_stop_numeric (int code, bool quiet)
388760c2415Smrg {
389760c2415Smrg if (!quiet)
390760c2415Smrg {
391760c2415Smrg report_exception ();
392760c2415Smrg st_printf ("ERROR STOP %d\n", code);
393760c2415Smrg }
394760c2415Smrg exit_error (code);
395760c2415Smrg }
396