1 /* Implementation of the STOP statement.
2    Copyright (C) 2002-2022 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
report_exception(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
stop_numeric(int code,bool quiet)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
stop_string(const char * string,size_t len,bool quiet)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
error_stop_string(const char * string,size_t len,bool quiet)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
error_stop_numeric(int code,bool quiet)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