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 }