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 printf
 200 /* Map "exit" to "abort"; see PR85463 '[nvptx] "exit" in offloaded region
 201    doesn't terminate process'.  */
 202 #undef exit
 203 #define exit(...) do { abort (); } while (0)
 204 #undef exit_error
 205 #define exit_error(...) do { abort (); } while (0)
 206
 207 /* A numeric STOP statement.  */
 208
 209 extern _Noreturn void stop_numeric (int, bool);
 210 export_proto(stop_numeric);
 211
 212 void
 213 stop_numeric (int code, bool quiet)
 214 {
 215   if (!quiet)
 216     {
 217       report_exception ();
 218       st_printf ("STOP %d\n", code);
 219     }
 220   exit (code);
 221 }
 222
 223
 224 /* A character string or blank STOP statement.  */
 225
 226 void
 227 stop_string (const char *string, size_t len, bool quiet)
 228 {
 229   if (!quiet)
 230     {
 231       report_exception ();
 232       if (string)
 233         {
 234           estr_write ("STOP ");
 235           (void) write (STDERR_FILENO, string, len);
 236           estr_write ("\n");
 237         }
 238     }
 239   exit (0);
 240 }
 241
 242
 243 /* Per Fortran 2008, section 8.4:  "Execution of a STOP statement initiates
 244    normal termination of execution. Execution of an ERROR STOP statement
 245    initiates error termination of execution."  Thus, error_stop_string returns
 246    a nonzero exit status code.  */
 247
 248 extern _Noreturn void error_stop_string (const char *, size_t, bool);
 249 export_proto(error_stop_string);
 250
 251 void
 252 error_stop_string (const char *string, size_t len, bool quiet)
 253 {
 254   if (!quiet)
 255     {
 256       report_exception ();
 257       estr_write ("ERROR STOP ");
 258       (void) write (STDERR_FILENO, string, len);
 259       estr_write ("\n");
 260     }
 261   exit_error (1);
 262 }
 263
 264
 265 /* A numeric ERROR STOP statement.  */
 266
 267 extern _Noreturn void error_stop_numeric (int, bool);
 268 export_proto(error_stop_numeric);
 269
 270 void
 271 error_stop_numeric (int code, bool quiet)
 272 {
 273   if (!quiet)
 274     {
 275       report_exception ();
 276       st_printf ("ERROR STOP %d\n", code);
 277     }
 278   exit_error (code);
 279 }