libgfortran/runtime/minimal.c

   1 /* Copyright (C) 2002-2018 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 #include <string.h>
  27
  28
  29 #ifdef HAVE_UNISTD_H
  30 #include <unistd.h>
  31 #endif
  32
  33 /* Stupid function to be sure the constructor is always linked in, even
  34    in the case of static linking.  See PR libfortran/22298 for details.  */
  35 void
  36 stupid_function_name_for_static_linking (void)
  37 {
  38   return;
  39 }
  40
  41 options_t options;
  42
  43 static int argc_save;
  44 static char **argv_save;
  45
  46 /* recursion_check()-- It's possible for additional errors to occur
  47  * during fatal error processing.  We detect this condition here and
  48  * exit with code 4 immediately. */
  49
  50 #define MAGIC 0x20DE8101
  51
  52 static void
  53 recursion_check (void)
  54 {
  55   static int magic = 0;
  56
  57   /* Don't even try to print something at this point */
  58   if (magic == MAGIC)
  59     sys_abort ();
  60
  61   magic = MAGIC;
  62 }
  63
  64
  65 /* os_error()-- Operating system error.  We get a message from the
  66  * operating system, show it and leave.  Some operating system errors
  67  * are caught and processed by the library.  If not, we come here. */
  68
  69 void
  70 os_error (const char *message)
  71 {
  72   recursion_check ();
  73   printf ("Operating system error: ");
  74   printf ("%s\n", message);
  75   exit (1);
  76 }
  77 iexport(os_error);
  78
  79
  80 /* void runtime_error()-- These are errors associated with an
  81  * invalid fortran program. */
  82
  83 void
  84 runtime_error (const char *message, ...)
  85 {
  86   va_list ap;
  87
  88   recursion_check ();
  89   printf ("Fortran runtime error: ");
  90   va_start (ap, message);
  91   vprintf (message, ap);
  92   va_end (ap);
  93   printf ("\n");
  94   exit (2);
  95 }
  96 iexport(runtime_error);
  97
  98 /* void runtime_error_at()-- These are errors associated with a
  99  * run time error generated by the front end compiler.  */
 100
 101 void
 102 runtime_error_at (const char *where, const char *message, ...)
 103 {
 104   va_list ap;
 105
 106   recursion_check ();
 107   printf ("%s", where);
 108   printf ("\nFortran runtime error: ");
 109   va_start (ap, message);
 110   vprintf (message, ap);
 111   va_end (ap);
 112   printf ("\n");
 113   exit (2);
 114 }
 115 iexport(runtime_error_at);
 116
 117
 118 void
 119 runtime_warning_at (const char *where, const char *message, ...)
 120 {
 121   va_list ap;
 122
 123   printf ("%s", where);
 124   printf ("\nFortran runtime warning: ");
 125   va_start (ap, message);
 126   vprintf (message, ap);
 127   va_end (ap);
 128   printf ("\n");
 129 }
 130 iexport(runtime_warning_at);
 131
 132
 133 /* void internal_error()-- These are this-can't-happen errors
 134  * that indicate something deeply wrong. */
 135
 136 void
 137 internal_error (st_parameter_common *cmp, const char *message)
 138 {
 139   recursion_check ();
 140   printf ("Internal Error: ");
 141   printf ("%s", message);
 142   printf ("\n");
 143
 144   /* This function call is here to get the main.o object file included
 145      when linking statically. This works because error.o is supposed to
 146      be always linked in (and the function call is in internal_error
 147      because hopefully it doesn't happen too often).  */
 148   stupid_function_name_for_static_linking();
 149
 150   exit (3);
 151 }
 152
 153
 154 /* Set the saved values of the command line arguments.  */
 155
 156 void
 157 set_args (int argc, char **argv)
 158 {
 159   argc_save = argc;
 160   argv_save = argv;
 161 }
 162 iexport(set_args);
 163
 164
 165 /* Retrieve the saved values of the command line arguments.  */
 166
 167 void
 168 get_args (int *argc, char ***argv)
 169 {
 170   *argc = argc_save;
 171   *argv = argv_save;
 172 }
 173
 174 /* sys_abort()-- Terminate the program showing backtrace and dumping
 175    core.  */
 176
 177 void
 178 sys_abort (void)
 179 {
 180   /* If backtracing is enabled, print backtrace and disable signal
 181      handler for ABRT.  */
 182   if (options.backtrace == 1
 183       || (options.backtrace == -1 && compile_options.backtrace == 1))
 184     {
 185       printf ("\nProgram aborted.\n");
 186     }
 187
 188   abort();
 189 }
 190
 191
 192 /* runtime/stop.c */
 193
 194 #undef report_exception
 195 #define report_exception() do {} while (0)
 196 #undef st_printf
 197 #define st_printf printf
 198 #undef estr_write
 199 #define estr_write(X) write(STDERR_FILENO, (X), strlen (X))
 200 #if __nvptx__
 201 /* Map "exit" to "abort"; see PR85463 '[nvptx] "exit" in offloaded region
 202    doesn't terminate process'.  */
 203 #undef exit
 204 #define exit(...) do { abort (); } while (0)
 205 #endif
 206 #undef exit_error
 207 #define exit_error(...) do { abort (); } while (0)
 208
 209 /* A numeric STOP statement.  */
 210
 211 extern _Noreturn void stop_numeric (int, bool);
 212 export_proto(stop_numeric);
 213
 214 void
 215 stop_numeric (int code, bool quiet)
 216 {
 217   if (!quiet)
 218     {
 219       report_exception ();
 220       st_printf ("STOP %d\n", code);
 221     }
 222   exit (code);
 223 }
 224
 225
 226 /* A character string or blank STOP statement.  */
 227
 228 void
 229 stop_string (const char *string, size_t len, bool quiet)
 230 {
 231   if (!quiet)
 232     {
 233       report_exception ();
 234       if (string)
 235         {
 236           estr_write ("STOP ");
 237           (void) write (STDERR_FILENO, string, len);
 238           estr_write ("\n");
 239         }
 240     }
 241   exit (0);
 242 }
 243
 244
 245 /* Per Fortran 2008, section 8.4:  "Execution of a STOP statement initiates
 246    normal termination of execution. Execution of an ERROR STOP statement
 247    initiates error termination of execution."  Thus, error_stop_string returns
 248    a nonzero exit status code.  */
 249
 250 extern _Noreturn void error_stop_string (const char *, size_t, bool);
 251 export_proto(error_stop_string);
 252
 253 void
 254 error_stop_string (const char *string, size_t len, bool quiet)
 255 {
 256   if (!quiet)
 257     {
 258       report_exception ();
 259       estr_write ("ERROR STOP ");
 260       (void) write (STDERR_FILENO, string, len);
 261       estr_write ("\n");
 262     }
 263   exit_error (1);
 264 }
 265
 266
 267 /* A numeric ERROR STOP statement.  */
 268
 269 extern _Noreturn void error_stop_numeric (int, bool);
 270 export_proto(error_stop_numeric);
 271
 272 void
 273 error_stop_numeric (int code, bool quiet)
 274 {
 275   if (!quiet)
 276     {
 277       report_exception ();
 278       st_printf ("ERROR STOP %d\n", code);
 279     }
 280   exit_error (code);
 281 }