libgfortran/runtime/stop.c

   1 /* Implementation of the STOP statement.
   2    Copyright (C) 2002-2023 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU General Public
   9 License as published by the Free Software Foundation; either
  10 version 3 of the License, or (at your option) any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27
  28 #ifdef HAVE_UNISTD_H
  29 #include <unistd.h>
  30 #endif
  31
  32 #include <string.h>
  33
  34 /* Fortran 2008 demands: If any exception (14) is signaling on that image, the
  35    processor shall issue a warning indicating which exceptions are signaling;
  36    this warning shall be on the unit identified by the named constant
  37    ERROR_UNIT (13.8.2.8).  In line with other compilers, we do not report
  38    inexact - and we optionally ignore underflow, cf. thread starting at
  39    http://mailman.j3-fortran.org/pipermail/j3/2013-June/006452.html.  */
  40
  41 static void
  42 report_exception (void)
  43 {
  44   struct iovec iov[8];
  45   int set_excepts, iovcnt = 1;
  46
  47   if (!compile_options.fpe_summary)
  48     return;
  49
  50   set_excepts = get_fpu_except_flags ();
  51   if ((set_excepts & compile_options.fpe_summary) == 0)
  52     return;
  53
  54   iov[0].iov_base = (char*) "Note: The following floating-point exceptions are signalling:";
  55   iov[0].iov_len = strlen (iov[0].iov_base);
  56
  57   if ((compile_options.fpe_summary & GFC_FPE_INVALID)
  58       && (set_excepts & GFC_FPE_INVALID))
  59     {
  60       iov[iovcnt].iov_base = (char*) " IEEE_INVALID_FLAG";
  61       iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
  62       iovcnt++;
  63     }
  64
  65   if ((compile_options.fpe_summary & GFC_FPE_ZERO)
  66       && (set_excepts & GFC_FPE_ZERO))
  67     {
  68       iov[iovcnt].iov_base = (char*) " IEEE_DIVIDE_BY_ZERO";
  69       iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
  70       iovcnt++;
  71     }
  72
  73   if ((compile_options.fpe_summary & GFC_FPE_OVERFLOW)
  74       && (set_excepts & GFC_FPE_OVERFLOW))
  75     {
  76       iov[iovcnt].iov_base = (char*) " IEEE_OVERFLOW_FLAG";
  77       iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
  78       iovcnt++;
  79     }
  80
  81   if ((compile_options.fpe_summary & GFC_FPE_UNDERFLOW)
  82       && (set_excepts & GFC_FPE_UNDERFLOW))
  83     {
  84       iov[iovcnt].iov_base = (char*) " IEEE_UNDERFLOW_FLAG";
  85       iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
  86       iovcnt++;
  87     }
  88
  89   if ((compile_options.fpe_summary & GFC_FPE_DENORMAL)
  90       && (set_excepts & GFC_FPE_DENORMAL))
  91     {
  92       iov[iovcnt].iov_base = (char*) " IEEE_DENORMAL";
  93       iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
  94       iovcnt++;
  95     }
  96
  97   if ((compile_options.fpe_summary & GFC_FPE_INEXACT)
  98       && (set_excepts & GFC_FPE_INEXACT))
  99     {
 100       iov[iovcnt].iov_base = (char*) " IEEE_INEXACT_FLAG";
 101       iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
 102       iovcnt++;
 103     }
 104
 105   iov[iovcnt].iov_base = (char*) "\n";
 106   iov[iovcnt].iov_len = 1;
 107   iovcnt++;
 108
 109   estr_writev (iov, iovcnt);
 110 }
 111
 112
 113 /* A numeric STOP statement.  */
 114
 115 extern _Noreturn void stop_numeric (int, bool);
 116 export_proto(stop_numeric);
 117
 118 void
 119 stop_numeric (int code, bool quiet)
 120 {
 121   if (!quiet)
 122     {
 123       report_exception ();
 124       st_printf ("STOP %d\n", code);
 125     }
 126   exit (code);
 127 }
 128
 129
 130 /* A character string or blank STOP statement.  */
 131
 132 void
 133 stop_string (const char *string, size_t len, bool quiet)
 134 {
 135   if (!quiet)
 136     {
 137       report_exception ();
 138       if (string)
 139         {
 140           struct iovec iov[3];
 141           iov[0].iov_base = (char*) "STOP ";
 142           iov[0].iov_len = strlen (iov[0].iov_base);
 143           iov[1].iov_base = (char*) string;
 144           iov[1].iov_len = len;
 145           iov[2].iov_base = (char*) "\n";
 146           iov[2].iov_len = 1;
 147           estr_writev (iov, 3);
 148         }
 149     }
 150   exit (0);
 151 }
 152
 153
 154 /* Per Fortran 2008, section 8.4:  "Execution of a STOP statement initiates
 155    normal termination of execution. Execution of an ERROR STOP statement
 156    initiates error termination of execution."  Thus, error_stop_string returns
 157    a nonzero exit status code.  */
 158
 159 extern _Noreturn void error_stop_string (const char *, size_t, bool);
 160 export_proto(error_stop_string);
 161
 162 void
 163 error_stop_string (const char *string, size_t len, bool quiet)
 164 {
 165   if (!quiet)
 166     {
 167       struct iovec iov[3];
 168       report_exception ();
 169       iov[0].iov_base = (char*) "ERROR STOP ";
 170       iov[0].iov_len = strlen (iov[0].iov_base);
 171       iov[1].iov_base = (char*) string;
 172       iov[1].iov_len = len;
 173       iov[2].iov_base = (char*) "\n";
 174       iov[2].iov_len = 1;
 175       estr_writev (iov, 3);
 176     }
 177   exit_error (1);
 178 }
 179
 180
 181 /* A numeric ERROR STOP statement.  */
 182
 183 extern _Noreturn void error_stop_numeric (int, bool);
 184 export_proto(error_stop_numeric);
 185
 186 void
 187 error_stop_numeric (int code, bool quiet)
 188 {
 189   if (!quiet)
 190     {
 191       report_exception ();
 192       st_printf ("ERROR STOP %d\n", code);
 193     }
 194   exit_error (code);
 195 }