1 /* Copyright (C) 2002-2020 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 } 396