1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2 Contributed by Andy Vaught and Paul Brook <paul@nowt.org>
4 This file is part of the GNU Fortran runtime library (libgfortran).
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)
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.
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.
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/>. */
25 #include "libgfortran.h"
35 /* Map "exit" to "abort"; see PR85463 '[nvptx] "exit" in offloaded region
36 doesn't terminate process'. */
38 # define exit(status) do { (void) (status); abort (); } while (0)
43 /* 'printf' is all we have. */
45 # define estr_vprintf vprintf
51 /* runtime/environ.c */
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. */
61 stupid_function_name_for_static_linking (void)
68 static char **argv_save
;
71 /* Set the saved values of the command line arguments. */
74 set_args (int argc
, char **argv
)
82 /* Retrieve the saved values of the command line arguments. */
85 get_args (int *argc
, char ***argv
)
94 /* Write a null-terminated C string to standard error. This function
95 is async-signal-safe. */
98 estr_write (const char *str
)
100 return write (STDERR_FILENO
, str
, strlen (str
));
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. */
109 st_printf (const char * format
, ...)
113 va_start (ap
, format
);
114 written
= estr_vprintf (format
, ap
);
120 /* sys_abort()-- Terminate the program showing backtrace and dumping
126 /* If backtracing is enabled, print backtrace and disable signal
128 if (options
.backtrace
== 1
129 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
131 estr_write ("\nProgram aborted.\n");
138 /* Exit in case of error termination. If backtracing is enabled, print
139 backtrace, then exit. */
142 exit_error (int status
)
144 if (options
.backtrace
== 1
145 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1))
147 estr_write ("\nError termination.\n");
153 /* show_locus()-- Print a line number and filename describing where
154 * something went wrong */
157 show_locus (st_parameter_common
*cmp
)
161 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
166 filename
= /* TODO filename_from_unit (cmp->unit) */ NULL
;
168 if (filename
!= NULL
)
170 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
171 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
, filename
);
176 st_printf ("At line %d of file %s (unit = %d)\n",
177 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
);
182 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
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. */
190 #define MAGIC 0x20DE8101
193 recursion_check (void)
195 static int magic
= 0;
197 /* Don't even try to print something at this point */
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. */
210 os_error (const char *message
)
213 estr_write ("Operating system error: ");
214 estr_write (message
);
218 iexport(os_error
); /* TODO, DEPRECATED, ABI: Should not be exported
219 anymore when bumping so version. */
222 /* Improved version of os_error with a printf style format string and
226 os_error_at (const char *where
, const char *message
, ...)
233 va_start (ap
, message
);
234 estr_vprintf (message
, ap
);
239 iexport(os_error_at
);
242 /* void runtime_error()-- These are errors associated with an
243 * invalid fortran program. */
246 runtime_error (const char *message
, ...)
251 estr_write ("Fortran runtime error: ");
252 va_start (ap
, message
);
253 estr_vprintf (message
, ap
);
258 iexport(runtime_error
);
260 /* void runtime_error_at()-- These are errors associated with a
261 * run time error generated by the front end compiler. */
264 runtime_error_at (const char *where
, const char *message
, ...)
270 estr_write ("\nFortran runtime error: ");
271 va_start (ap
, message
);
272 estr_vprintf (message
, ap
);
277 iexport(runtime_error_at
);
281 runtime_warning_at (const char *where
, const char *message
, ...)
286 estr_write ("\nFortran runtime warning: ");
287 va_start (ap
, message
);
288 estr_vprintf (message
, ap
);
292 iexport(runtime_warning_at
);
295 /* void internal_error()-- These are this-can't-happen errors
296 * that indicate something deeply wrong. */
299 internal_error (st_parameter_common
*cmp
, const char *message
)
303 estr_write ("Internal Error: ");
304 estr_write (message
);
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();
319 #undef report_exception
320 #define report_exception() do {} while (0)
323 /* A numeric STOP statement. */
325 extern _Noreturn
void stop_numeric (int, bool);
326 export_proto(stop_numeric
);
329 stop_numeric (int code
, bool quiet
)
334 st_printf ("STOP %d\n", code
);
340 /* A character string or blank STOP statement. */
343 stop_string (const char *string
, size_t len
, bool quiet
)
350 estr_write ("STOP ");
351 (void) write (STDERR_FILENO
, string
, len
);
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. */
364 extern _Noreturn
void error_stop_string (const char *, size_t, bool);
365 export_proto(error_stop_string
);
368 error_stop_string (const char *string
, size_t len
, bool quiet
)
373 estr_write ("ERROR STOP ");
374 (void) write (STDERR_FILENO
, string
, len
);
381 /* A numeric ERROR STOP statement. */
383 extern _Noreturn
void error_stop_numeric (int, bool);
384 export_proto(error_stop_numeric
);
387 error_stop_numeric (int code
, bool quiet
)
392 st_printf ("ERROR STOP %d\n", code
);