1 /* Implementation of the STOP statement. 2 Copyright (C) 2002-2020 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 } 196