1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
2 Contributed by Andy Vaught and Paul Brook <paul@nowt.org>
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 3, or (at your option)
9 any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23 <http://www.gnu.org/licenses/>. */
24
25 #include "libgfortran.h"
26 #include <string.h>
27
28
29 #ifdef HAVE_UNISTD_H
30 #include <unistd.h>
31 #endif
32
33 /* Stupid function to be sure the constructor is always linked in, even
34 in the case of static linking. See PR libfortran/22298 for details. */
35 void
stupid_function_name_for_static_linking(void)36 stupid_function_name_for_static_linking (void)
37 {
38 return;
39 }
40
41 options_t options;
42
43 static int argc_save;
44 static char **argv_save;
45
46 /* recursion_check()-- It's possible for additional errors to occur
47 * during fatal error processing. We detect this condition here and
48 * exit with code 4 immediately. */
49
50 #define MAGIC 0x20DE8101
51
52 static void
recursion_check(void)53 recursion_check (void)
54 {
55 static int magic = 0;
56
57 /* Don't even try to print something at this point */
58 if (magic == MAGIC)
59 sys_abort ();
60
61 magic = MAGIC;
62 }
63
64
65 /* os_error()-- Operating system error. We get a message from the
66 * operating system, show it and leave. Some operating system errors
67 * are caught and processed by the library. If not, we come here. */
68
69 void
os_error(const char * message)70 os_error (const char *message)
71 {
72 recursion_check ();
73 printf ("Operating system error: ");
74 printf ("%s\n", message);
75 exit (1);
76 }
77 iexport(os_error);
78
79
80 /* void runtime_error()-- These are errors associated with an
81 * invalid fortran program. */
82
83 void
runtime_error(const char * message,...)84 runtime_error (const char *message, ...)
85 {
86 va_list ap;
87
88 recursion_check ();
89 printf ("Fortran runtime error: ");
90 va_start (ap, message);
91 vprintf (message, ap);
92 va_end (ap);
93 printf ("\n");
94 exit (2);
95 }
96 iexport(runtime_error);
97
98 /* void runtime_error_at()-- These are errors associated with a
99 * run time error generated by the front end compiler. */
100
101 void
runtime_error_at(const char * where,const char * message,...)102 runtime_error_at (const char *where, const char *message, ...)
103 {
104 va_list ap;
105
106 recursion_check ();
107 printf ("%s", where);
108 printf ("\nFortran runtime error: ");
109 va_start (ap, message);
110 vprintf (message, ap);
111 va_end (ap);
112 printf ("\n");
113 exit (2);
114 }
115 iexport(runtime_error_at);
116
117
118 void
runtime_warning_at(const char * where,const char * message,...)119 runtime_warning_at (const char *where, const char *message, ...)
120 {
121 va_list ap;
122
123 printf ("%s", where);
124 printf ("\nFortran runtime warning: ");
125 va_start (ap, message);
126 vprintf (message, ap);
127 va_end (ap);
128 printf ("\n");
129 }
130 iexport(runtime_warning_at);
131
132
133 /* void internal_error()-- These are this-can't-happen errors
134 * that indicate something deeply wrong. */
135
136 void
internal_error(st_parameter_common * cmp,const char * message)137 internal_error (st_parameter_common *cmp, const char *message)
138 {
139 recursion_check ();
140 printf ("Internal Error: ");
141 printf ("%s", message);
142 printf ("\n");
143
144 /* This function call is here to get the main.o object file included
145 when linking statically. This works because error.o is supposed to
146 be always linked in (and the function call is in internal_error
147 because hopefully it doesn't happen too often). */
148 stupid_function_name_for_static_linking();
149
150 exit (3);
151 }
152
153
154 /* Set the saved values of the command line arguments. */
155
156 void
set_args(int argc,char ** argv)157 set_args (int argc, char **argv)
158 {
159 argc_save = argc;
160 argv_save = argv;
161 }
162 iexport(set_args);
163
164
165 /* Retrieve the saved values of the command line arguments. */
166
167 void
get_args(int * argc,char *** argv)168 get_args (int *argc, char ***argv)
169 {
170 *argc = argc_save;
171 *argv = argv_save;
172 }
173
174 /* sys_abort()-- Terminate the program showing backtrace and dumping
175 core. */
176
177 void
sys_abort(void)178 sys_abort (void)
179 {
180 /* If backtracing is enabled, print backtrace and disable signal
181 handler for ABRT. */
182 if (options.backtrace == 1
183 || (options.backtrace == -1 && compile_options.backtrace == 1))
184 {
185 printf ("\nProgram aborted.\n");
186 }
187
188 abort();
189 }
190
191
192 /* runtime/stop.c */
193
194 #undef report_exception
195 #define report_exception() do {} while (0)
196 #undef st_printf
197 #define st_printf printf
198 #undef estr_write
199 #define estr_write printf
200 /* Map "exit" to "abort"; see PR85463 '[nvptx] "exit" in offloaded region
201 doesn't terminate process'. */
202 #undef exit
203 #define exit(...) do { abort (); } while (0)
204 #undef exit_error
205 #define exit_error(...) do { abort (); } while (0)
206
207 /* A numeric STOP statement. */
208
209 extern _Noreturn void stop_numeric (int, bool);
210 export_proto(stop_numeric);
211
212 void
stop_numeric(int code,bool quiet)213 stop_numeric (int code, bool quiet)
214 {
215 if (!quiet)
216 {
217 report_exception ();
218 st_printf ("STOP %d\n", code);
219 }
220 exit (code);
221 }
222
223
224 /* A character string or blank STOP statement. */
225
226 void
stop_string(const char * string,size_t len,bool quiet)227 stop_string (const char *string, size_t len, bool quiet)
228 {
229 if (!quiet)
230 {
231 report_exception ();
232 if (string)
233 {
234 estr_write ("STOP ");
235 (void) write (STDERR_FILENO, string, len);
236 estr_write ("\n");
237 }
238 }
239 exit (0);
240 }
241
242
243 /* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates
244 normal termination of execution. Execution of an ERROR STOP statement
245 initiates error termination of execution." Thus, error_stop_string returns
246 a nonzero exit status code. */
247
248 extern _Noreturn void error_stop_string (const char *, size_t, bool);
249 export_proto(error_stop_string);
250
251 void
error_stop_string(const char * string,size_t len,bool quiet)252 error_stop_string (const char *string, size_t len, bool quiet)
253 {
254 if (!quiet)
255 {
256 report_exception ();
257 estr_write ("ERROR STOP ");
258 (void) write (STDERR_FILENO, string, len);
259 estr_write ("\n");
260 }
261 exit_error (1);
262 }
263
264
265 /* A numeric ERROR STOP statement. */
266
267 extern _Noreturn void error_stop_numeric (int, bool);
268 export_proto(error_stop_numeric);
269
270 void
error_stop_numeric(int code,bool quiet)271 error_stop_numeric (int code, bool quiet)
272 {
273 if (!quiet)
274 {
275 report_exception ();
276 st_printf ("ERROR STOP %d\n", code);
277 }
278 exit_error (code);
279 }
280