libgfortran/runtime/minimal.c

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