|
111
|
1 /* Implementation of the STOP statement.
|
|
145
|
2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
|
|
111
|
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
|
|
131
|
32 #include <string.h>
|
|
111
|
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 {
|
|
131
|
44 struct iovec iov[8];
|
|
|
45 int set_excepts, iovcnt = 1;
|
|
111
|
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
|
|
131
|
54 iov[0].iov_base = (char*) "Note: The following floating-point exceptions are signalling:";
|
|
|
55 iov[0].iov_len = strlen (iov[0].iov_base);
|
|
111
|
56
|
|
|
57 if ((compile_options.fpe_summary & GFC_FPE_INVALID)
|
|
|
58 && (set_excepts & GFC_FPE_INVALID))
|
|
131
|
59 {
|
|
|
60 iov[iovcnt].iov_base = (char*) " IEEE_INVALID_FLAG";
|
|
|
61 iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
|
|
|
62 iovcnt++;
|
|
|
63 }
|
|
111
|
64
|
|
|
65 if ((compile_options.fpe_summary & GFC_FPE_ZERO)
|
|
|
66 && (set_excepts & GFC_FPE_ZERO))
|
|
131
|
67 {
|
|
|
68 iov[iovcnt].iov_base = (char*) " IEEE_DIVIDE_BY_ZERO";
|
|
|
69 iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
|
|
|
70 iovcnt++;
|
|
|
71 }
|
|
111
|
72
|
|
|
73 if ((compile_options.fpe_summary & GFC_FPE_OVERFLOW)
|
|
|
74 && (set_excepts & GFC_FPE_OVERFLOW))
|
|
131
|
75 {
|
|
|
76 iov[iovcnt].iov_base = (char*) " IEEE_OVERFLOW_FLAG";
|
|
|
77 iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
|
|
|
78 iovcnt++;
|
|
|
79 }
|
|
111
|
80
|
|
|
81 if ((compile_options.fpe_summary & GFC_FPE_UNDERFLOW)
|
|
|
82 && (set_excepts & GFC_FPE_UNDERFLOW))
|
|
131
|
83 {
|
|
|
84 iov[iovcnt].iov_base = (char*) " IEEE_UNDERFLOW_FLAG";
|
|
|
85 iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
|
|
|
86 iovcnt++;
|
|
|
87 }
|
|
111
|
88
|
|
|
89 if ((compile_options.fpe_summary & GFC_FPE_DENORMAL)
|
|
|
90 && (set_excepts & GFC_FPE_DENORMAL))
|
|
131
|
91 {
|
|
|
92 iov[iovcnt].iov_base = (char*) " IEEE_DENORMAL";
|
|
|
93 iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
|
|
|
94 iovcnt++;
|
|
|
95 }
|
|
111
|
96
|
|
|
97 if ((compile_options.fpe_summary & GFC_FPE_INEXACT)
|
|
|
98 && (set_excepts & GFC_FPE_INEXACT))
|
|
131
|
99 {
|
|
|
100 iov[iovcnt].iov_base = (char*) " IEEE_INEXACT_FLAG";
|
|
|
101 iov[iovcnt].iov_len = strlen (iov[iovcnt].iov_base);
|
|
|
102 iovcnt++;
|
|
|
103 }
|
|
111
|
104
|
|
131
|
105 iov[iovcnt].iov_base = (char*) "\n";
|
|
|
106 iov[iovcnt].iov_len = 1;
|
|
|
107 iovcnt++;
|
|
|
108
|
|
|
109 estr_writev (iov, iovcnt);
|
|
111
|
110 }
|
|
|
111
|
|
|
112
|
|
|
113 /* A numeric STOP statement. */
|
|
|
114
|
|
131
|
115 extern _Noreturn void stop_numeric (int, bool);
|
|
111
|
116 export_proto(stop_numeric);
|
|
|
117
|
|
|
118 void
|
|
131
|
119 stop_numeric (int code, bool quiet)
|
|
111
|
120 {
|
|
131
|
121 if (!quiet)
|
|
|
122 {
|
|
|
123 report_exception ();
|
|
|
124 st_printf ("STOP %d\n", code);
|
|
|
125 }
|
|
111
|
126 exit (code);
|
|
|
127 }
|
|
|
128
|
|
|
129
|
|
|
130 /* A character string or blank STOP statement. */
|
|
|
131
|
|
|
132 void
|
|
131
|
133 stop_string (const char *string, size_t len, bool quiet)
|
|
111
|
134 {
|
|
131
|
135 if (!quiet)
|
|
111
|
136 {
|
|
131
|
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 }
|
|
111
|
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
|
|
131
|
159 extern _Noreturn void error_stop_string (const char *, size_t, bool);
|
|
111
|
160 export_proto(error_stop_string);
|
|
|
161
|
|
|
162 void
|
|
131
|
163 error_stop_string (const char *string, size_t len, bool quiet)
|
|
111
|
164 {
|
|
131
|
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 }
|
|
111
|
177 exit_error (1);
|
|
|
178 }
|
|
|
179
|
|
|
180
|
|
|
181 /* A numeric ERROR STOP statement. */
|
|
|
182
|
|
131
|
183 extern _Noreturn void error_stop_numeric (int, bool);
|
|
111
|
184 export_proto(error_stop_numeric);
|
|
|
185
|
|
|
186 void
|
|
131
|
187 error_stop_numeric (int code, bool quiet)
|
|
111
|
188 {
|
|
131
|
189 if (!quiet)
|
|
|
190 {
|
|
|
191 report_exception ();
|
|
|
192 st_printf ("ERROR STOP %d\n", code);
|
|
|
193 }
|
|
111
|
194 exit_error (code);
|
|
|
195 }
|
