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 /* A numeric STOP statement.  */
 192
 193 extern _Noreturn void stop_numeric (int, bool);
 194 export_proto(stop_numeric);
 195
 196 void
 197 stop_numeric (int code, bool quiet)
 198 {
 199   if (!quiet)
 200     printf ("STOP %d\n", code);
 201
 202   exit (code);
 203 }