1*0bfacb9bSmrg /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2760c2415Smrg Contributed by Andy Vaught
3760c2415Smrg
4760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
5760c2415Smrg
6760c2415Smrg Libgfortran is free software; you can redistribute it and/or modify
7760c2415Smrg it under the terms of the GNU General Public License as published by
8760c2415Smrg the Free Software Foundation; either version 3, or (at your option)
9760c2415Smrg any later version.
10760c2415Smrg
11760c2415Smrg Libgfortran is distributed in the hope that it will be useful,
12760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
13760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14760c2415Smrg GNU General Public License for more details.
15760c2415Smrg
16760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
17760c2415Smrg permissions described in the GCC Runtime Library Exception, version
18760c2415Smrg 3.1, as published by the Free Software Foundation.
19760c2415Smrg
20760c2415Smrg You should have received a copy of the GNU General Public License and
21760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
22760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23760c2415Smrg <http://www.gnu.org/licenses/>. */
24760c2415Smrg
25760c2415Smrg
26760c2415Smrg #include "libgfortran.h"
27760c2415Smrg #include "io.h"
28760c2415Smrg #include "async.h"
29760c2415Smrg
30760c2415Smrg #include <assert.h>
31760c2415Smrg #include <string.h>
32760c2415Smrg #include <errno.h>
33760c2415Smrg #include <signal.h>
34760c2415Smrg
35760c2415Smrg #ifdef HAVE_UNISTD_H
36760c2415Smrg #include <unistd.h>
37760c2415Smrg #endif
38760c2415Smrg
39760c2415Smrg #ifdef HAVE_SYS_TIME_H
40760c2415Smrg #include <sys/time.h>
41760c2415Smrg #endif
42760c2415Smrg
43760c2415Smrg /* <sys/time.h> has to be included before <sys/resource.h> to work
44760c2415Smrg around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
45760c2415Smrg #ifdef HAVE_SYS_RESOURCE_H
46760c2415Smrg #include <sys/resource.h>
47760c2415Smrg #endif
48760c2415Smrg
49760c2415Smrg
50760c2415Smrg #include <locale.h>
51760c2415Smrg
52760c2415Smrg #ifdef HAVE_XLOCALE_H
53760c2415Smrg #include <xlocale.h>
54760c2415Smrg #endif
55760c2415Smrg
56760c2415Smrg
57760c2415Smrg #ifdef __MINGW32__
58760c2415Smrg #define HAVE_GETPID 1
59760c2415Smrg #include <process.h>
60760c2415Smrg #endif
61760c2415Smrg
62760c2415Smrg
63760c2415Smrg /* Termination of a program: F2008 2.3.5 talks about "normal
64760c2415Smrg termination" and "error termination". Normal termination occurs as
65760c2415Smrg a result of e.g. executing the end program statement, and executing
66760c2415Smrg the STOP statement. It includes the effect of the C exit()
67760c2415Smrg function.
68760c2415Smrg
69760c2415Smrg Error termination is initiated when the ERROR STOP statement is
70760c2415Smrg executed, when ALLOCATE/DEALLOCATE fails without STAT= being
71760c2415Smrg specified, when some of the co-array synchronization statements
72760c2415Smrg fail without STAT= being specified, and some I/O errors if
73760c2415Smrg ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
74760c2415Smrg failure without CMDSTAT=.
75760c2415Smrg
76760c2415Smrg 2.3.5 also explains how co-images synchronize during termination.
77760c2415Smrg
78760c2415Smrg In libgfortran we have three ways of ending a program. exit(code)
79760c2415Smrg is a normal exit; calling exit() also causes open units to be
80760c2415Smrg closed. No backtrace or core dump is needed here. For error
81760c2415Smrg termination, we have exit_error(status), which prints a backtrace
82760c2415Smrg if backtracing is enabled, then exits. Finally, when something
83760c2415Smrg goes terribly wrong, we have sys_abort() which tries to print the
84760c2415Smrg backtrace if -fbacktrace is enabled, and then dumps core; whether a
85760c2415Smrg core file is generated is system dependent. When aborting, we don't
86760c2415Smrg flush and close open units, as program memory might be corrupted
87760c2415Smrg and we'd rather risk losing dirty data in the buffers rather than
88760c2415Smrg corrupting files on disk.
89760c2415Smrg
90760c2415Smrg */
91760c2415Smrg
92760c2415Smrg /* Error conditions. The tricky part here is printing a message when
93760c2415Smrg * it is the I/O subsystem that is severely wounded. Our goal is to
94760c2415Smrg * try and print something making the fewest assumptions possible,
95760c2415Smrg * then try to clean up before actually exiting.
96760c2415Smrg *
97760c2415Smrg * The following exit conditions are defined:
98760c2415Smrg * 0 Normal program exit.
99760c2415Smrg * 1 Terminated because of operating system error.
100760c2415Smrg * 2 Error in the runtime library
101760c2415Smrg * 3 Internal error in runtime library
102760c2415Smrg *
103760c2415Smrg * Other error returns are reserved for the STOP statement with a numeric code.
104760c2415Smrg */
105760c2415Smrg
106760c2415Smrg
107760c2415Smrg /* Write a null-terminated C string to standard error. This function
108760c2415Smrg is async-signal-safe. */
109760c2415Smrg
110760c2415Smrg ssize_t
estr_write(const char * str)111760c2415Smrg estr_write (const char *str)
112760c2415Smrg {
113760c2415Smrg return write (STDERR_FILENO, str, strlen (str));
114760c2415Smrg }
115760c2415Smrg
116760c2415Smrg
117760c2415Smrg /* Write a vector of strings to standard error. This function is
118760c2415Smrg async-signal-safe. */
119760c2415Smrg
120760c2415Smrg ssize_t
estr_writev(const struct iovec * iov,int iovcnt)121760c2415Smrg estr_writev (const struct iovec *iov, int iovcnt)
122760c2415Smrg {
123760c2415Smrg #ifdef HAVE_WRITEV
124760c2415Smrg return writev (STDERR_FILENO, iov, iovcnt);
125760c2415Smrg #else
126760c2415Smrg ssize_t w = 0;
127760c2415Smrg for (int i = 0; i < iovcnt; i++)
128760c2415Smrg {
129760c2415Smrg ssize_t r = write (STDERR_FILENO, iov[i].iov_base, iov[i].iov_len);
130760c2415Smrg if (r == -1)
131760c2415Smrg return r;
132760c2415Smrg w += r;
133760c2415Smrg }
134760c2415Smrg return w;
135760c2415Smrg #endif
136760c2415Smrg }
137760c2415Smrg
138760c2415Smrg
139760c2415Smrg #ifndef HAVE_VSNPRINTF
140760c2415Smrg static int
gf_vsnprintf(char * str,size_t size,const char * format,va_list ap)141760c2415Smrg gf_vsnprintf (char *str, size_t size, const char *format, va_list ap)
142760c2415Smrg {
143760c2415Smrg int written;
144760c2415Smrg
145760c2415Smrg written = vsprintf(buffer, format, ap);
146760c2415Smrg
147760c2415Smrg if (written >= size - 1)
148760c2415Smrg {
149760c2415Smrg /* The error message was longer than our buffer. Ouch. Because
150760c2415Smrg we may have messed up things badly, report the error and
151760c2415Smrg quit. */
152760c2415Smrg #define ERROR_MESSAGE "Internal error: buffer overrun in gf_vsnprintf()\n"
153760c2415Smrg write (STDERR_FILENO, buffer, size - 1);
154760c2415Smrg write (STDERR_FILENO, ERROR_MESSAGE, strlen (ERROR_MESSAGE));
155760c2415Smrg sys_abort ();
156760c2415Smrg #undef ERROR_MESSAGE
157760c2415Smrg
158760c2415Smrg }
159760c2415Smrg return written;
160760c2415Smrg }
161760c2415Smrg
162760c2415Smrg #define vsnprintf gf_vsnprintf
163760c2415Smrg #endif
164760c2415Smrg
165760c2415Smrg
166760c2415Smrg /* printf() like function for for printing to stderr. Uses a stack
167760c2415Smrg allocated buffer and doesn't lock stderr, so it should be safe to
168760c2415Smrg use from within a signal handler. */
169760c2415Smrg
170760c2415Smrg #define ST_ERRBUF_SIZE 512
171760c2415Smrg
172760c2415Smrg int
st_printf(const char * format,...)173760c2415Smrg st_printf (const char * format, ...)
174760c2415Smrg {
175760c2415Smrg char buffer[ST_ERRBUF_SIZE];
176760c2415Smrg int written;
177760c2415Smrg va_list ap;
178760c2415Smrg va_start (ap, format);
179760c2415Smrg written = vsnprintf (buffer, ST_ERRBUF_SIZE, format, ap);
180760c2415Smrg va_end (ap);
181760c2415Smrg written = write (STDERR_FILENO, buffer, written);
182760c2415Smrg return written;
183760c2415Smrg }
184760c2415Smrg
185760c2415Smrg
186760c2415Smrg /* sys_abort()-- Terminate the program showing backtrace and dumping
187760c2415Smrg core. */
188760c2415Smrg
189760c2415Smrg void
sys_abort(void)190760c2415Smrg sys_abort (void)
191760c2415Smrg {
192760c2415Smrg /* If backtracing is enabled, print backtrace and disable signal
193760c2415Smrg handler for ABRT. */
194760c2415Smrg if (options.backtrace == 1
195760c2415Smrg || (options.backtrace == -1 && compile_options.backtrace == 1))
196760c2415Smrg {
197760c2415Smrg estr_write ("\nProgram aborted. Backtrace:\n");
198760c2415Smrg show_backtrace (false);
199760c2415Smrg signal (SIGABRT, SIG_DFL);
200760c2415Smrg }
201760c2415Smrg
202760c2415Smrg abort();
203760c2415Smrg }
204760c2415Smrg
205760c2415Smrg
206760c2415Smrg /* Exit in case of error termination. If backtracing is enabled, print
207760c2415Smrg backtrace, then exit. */
208760c2415Smrg
209760c2415Smrg void
exit_error(int status)210760c2415Smrg exit_error (int status)
211760c2415Smrg {
212760c2415Smrg if (options.backtrace == 1
213760c2415Smrg || (options.backtrace == -1 && compile_options.backtrace == 1))
214760c2415Smrg {
215760c2415Smrg estr_write ("\nError termination. Backtrace:\n");
216760c2415Smrg show_backtrace (false);
217760c2415Smrg }
218760c2415Smrg exit (status);
219760c2415Smrg }
220760c2415Smrg
221760c2415Smrg
222760c2415Smrg
223760c2415Smrg /* gfc_xtoa()-- Integer to hexadecimal conversion. */
224760c2415Smrg
225760c2415Smrg const char *
gfc_xtoa(GFC_UINTEGER_LARGEST n,char * buffer,size_t len)226760c2415Smrg gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
227760c2415Smrg {
228760c2415Smrg int digit;
229760c2415Smrg char *p;
230760c2415Smrg
231760c2415Smrg assert (len >= GFC_XTOA_BUF_SIZE);
232760c2415Smrg
233760c2415Smrg if (n == 0)
234760c2415Smrg return "0";
235760c2415Smrg
236760c2415Smrg p = buffer + GFC_XTOA_BUF_SIZE - 1;
237760c2415Smrg *p = '\0';
238760c2415Smrg
239760c2415Smrg while (n != 0)
240760c2415Smrg {
241760c2415Smrg digit = n & 0xF;
242760c2415Smrg if (digit > 9)
243760c2415Smrg digit += 'A' - '0' - 10;
244760c2415Smrg
245760c2415Smrg *--p = '0' + digit;
246760c2415Smrg n >>= 4;
247760c2415Smrg }
248760c2415Smrg
249760c2415Smrg return p;
250760c2415Smrg }
251760c2415Smrg
252760c2415Smrg
253760c2415Smrg /* Hopefully thread-safe wrapper for a strerror() style function. */
254760c2415Smrg
255760c2415Smrg char *
gf_strerror(int errnum,char * buf,size_t buflen)256760c2415Smrg gf_strerror (int errnum,
257760c2415Smrg char * buf __attribute__((unused)),
258760c2415Smrg size_t buflen __attribute__((unused)))
259760c2415Smrg {
260760c2415Smrg #ifdef HAVE_STRERROR_L
261760c2415Smrg locale_t myloc = newlocale (LC_CTYPE_MASK | LC_MESSAGES_MASK, "",
262760c2415Smrg (locale_t) 0);
263760c2415Smrg char *p;
264760c2415Smrg if (myloc)
265760c2415Smrg {
266760c2415Smrg p = strerror_l (errnum, myloc);
267760c2415Smrg freelocale (myloc);
268760c2415Smrg }
269760c2415Smrg else
270760c2415Smrg /* newlocale might fail e.g. due to running out of memory, fall
271760c2415Smrg back to the simpler strerror. */
272760c2415Smrg p = strerror (errnum);
273760c2415Smrg return p;
274760c2415Smrg #elif defined(HAVE_STRERROR_R)
275760c2415Smrg #ifdef HAVE_USELOCALE
276760c2415Smrg /* Some targets (Darwin at least) have the POSIX 2008 extended
277760c2415Smrg locale functions, but not strerror_l. So reset the per-thread
278760c2415Smrg locale here. */
279760c2415Smrg uselocale (LC_GLOBAL_LOCALE);
280760c2415Smrg #endif
281760c2415Smrg /* POSIX returns an "int", GNU a "char*". */
282760c2415Smrg return
283760c2415Smrg __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
284760c2415Smrg == 5,
285760c2415Smrg /* GNU strerror_r() */
286760c2415Smrg strerror_r (errnum, buf, buflen),
287760c2415Smrg /* POSIX strerror_r () */
288760c2415Smrg (strerror_r (errnum, buf, buflen), buf));
289760c2415Smrg #elif defined(HAVE_STRERROR_R_2ARGS)
290760c2415Smrg strerror_r (errnum, buf);
291760c2415Smrg return buf;
292760c2415Smrg #else
293760c2415Smrg /* strerror () is not necessarily thread-safe, but should at least
294760c2415Smrg be available everywhere. */
295760c2415Smrg return strerror (errnum);
296760c2415Smrg #endif
297760c2415Smrg }
298760c2415Smrg
299760c2415Smrg
300760c2415Smrg /* show_locus()-- Print a line number and filename describing where
301760c2415Smrg * something went wrong */
302760c2415Smrg
303760c2415Smrg void
show_locus(st_parameter_common * cmp)304760c2415Smrg show_locus (st_parameter_common *cmp)
305760c2415Smrg {
306760c2415Smrg char *filename;
307760c2415Smrg
308760c2415Smrg if (!options.locus || cmp == NULL || cmp->filename == NULL)
309760c2415Smrg return;
310760c2415Smrg
311760c2415Smrg if (cmp->unit > 0)
312760c2415Smrg {
313760c2415Smrg filename = filename_from_unit (cmp->unit);
314760c2415Smrg
315760c2415Smrg if (filename != NULL)
316760c2415Smrg {
317760c2415Smrg st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
318760c2415Smrg (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
319760c2415Smrg free (filename);
320760c2415Smrg }
321760c2415Smrg else
322760c2415Smrg {
323760c2415Smrg st_printf ("At line %d of file %s (unit = %d)\n",
324760c2415Smrg (int) cmp->line, cmp->filename, (int) cmp->unit);
325760c2415Smrg }
326760c2415Smrg return;
327760c2415Smrg }
328760c2415Smrg
329760c2415Smrg st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
330760c2415Smrg }
331760c2415Smrg
332760c2415Smrg
333760c2415Smrg /* recursion_check()-- It's possible for additional errors to occur
334760c2415Smrg * during fatal error processing. We detect this condition here and
335760c2415Smrg * abort immediately. */
336760c2415Smrg
337760c2415Smrg static __gthread_key_t recursion_key;
338760c2415Smrg
339760c2415Smrg static void
recursion_check(void)340760c2415Smrg recursion_check (void)
341760c2415Smrg {
342760c2415Smrg if (__gthread_active_p ())
343760c2415Smrg {
344760c2415Smrg bool* p = __gthread_getspecific (recursion_key);
345760c2415Smrg if (!p)
346760c2415Smrg {
347760c2415Smrg p = xcalloc (1, sizeof (bool));
348760c2415Smrg __gthread_setspecific (recursion_key, p);
349760c2415Smrg }
350760c2415Smrg if (*p)
351760c2415Smrg sys_abort ();
352760c2415Smrg *p = true;
353760c2415Smrg }
354760c2415Smrg else
355760c2415Smrg {
356760c2415Smrg static bool recur;
357760c2415Smrg if (recur)
358760c2415Smrg sys_abort ();
359760c2415Smrg recur = true;
360760c2415Smrg }
361760c2415Smrg }
362760c2415Smrg
363760c2415Smrg #ifdef __GTHREADS
364760c2415Smrg static void __attribute__((constructor))
constructor_recursion_check(void)365760c2415Smrg constructor_recursion_check (void)
366760c2415Smrg {
367760c2415Smrg if (__gthread_active_p ())
368760c2415Smrg __gthread_key_create (&recursion_key, &free);
369760c2415Smrg }
370760c2415Smrg
371760c2415Smrg static void __attribute__((destructor))
destructor_recursion_check(void)372760c2415Smrg destructor_recursion_check (void)
373760c2415Smrg {
374760c2415Smrg if (__gthread_active_p ())
375760c2415Smrg __gthread_key_delete (recursion_key);
376760c2415Smrg }
377760c2415Smrg #endif
378760c2415Smrg
379760c2415Smrg
380760c2415Smrg
381760c2415Smrg #define STRERR_MAXSZ 256
382760c2415Smrg
383760c2415Smrg /* os_error()-- Operating system error. We get a message from the
384760c2415Smrg * operating system, show it and leave. Some operating system errors
385760c2415Smrg * are caught and processed by the library. If not, we come here. */
386760c2415Smrg
387760c2415Smrg void
os_error(const char * message)388760c2415Smrg os_error (const char *message)
389760c2415Smrg {
390760c2415Smrg char errmsg[STRERR_MAXSZ];
391760c2415Smrg struct iovec iov[5];
392760c2415Smrg recursion_check ();
393760c2415Smrg iov[0].iov_base = (char*) "Operating system error: ";
394760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
395760c2415Smrg iov[1].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ);
396760c2415Smrg iov[1].iov_len = strlen (iov[1].iov_base);
397760c2415Smrg iov[2].iov_base = (char*) "\n";
398760c2415Smrg iov[2].iov_len = 1;
399760c2415Smrg iov[3].iov_base = (char*) message;
400760c2415Smrg iov[3].iov_len = strlen (message);
401760c2415Smrg iov[4].iov_base = (char*) "\n";
402760c2415Smrg iov[4].iov_len = 1;
403760c2415Smrg estr_writev (iov, 5);
404760c2415Smrg exit_error (1);
405760c2415Smrg }
406*0bfacb9bSmrg iexport(os_error); /* TODO, DEPRECATED, ABI: Should not be exported
407*0bfacb9bSmrg anymore when bumping so version. */
408*0bfacb9bSmrg
409*0bfacb9bSmrg
410*0bfacb9bSmrg /* Improved version of os_error with a printf style format string and
411*0bfacb9bSmrg a locus. */
412*0bfacb9bSmrg
413*0bfacb9bSmrg void
os_error_at(const char * where,const char * message,...)414*0bfacb9bSmrg os_error_at (const char *where, const char *message, ...)
415*0bfacb9bSmrg {
416*0bfacb9bSmrg char errmsg[STRERR_MAXSZ];
417*0bfacb9bSmrg char buffer[STRERR_MAXSZ];
418*0bfacb9bSmrg struct iovec iov[6];
419*0bfacb9bSmrg va_list ap;
420*0bfacb9bSmrg recursion_check ();
421*0bfacb9bSmrg int written;
422*0bfacb9bSmrg
423*0bfacb9bSmrg iov[0].iov_base = (char*) where;
424*0bfacb9bSmrg iov[0].iov_len = strlen (where);
425*0bfacb9bSmrg
426*0bfacb9bSmrg iov[1].iov_base = (char*) ": ";
427*0bfacb9bSmrg iov[1].iov_len = strlen (iov[1].iov_base);
428*0bfacb9bSmrg
429*0bfacb9bSmrg va_start (ap, message);
430*0bfacb9bSmrg written = vsnprintf (buffer, STRERR_MAXSZ, message, ap);
431*0bfacb9bSmrg va_end (ap);
432*0bfacb9bSmrg iov[2].iov_base = buffer;
433*0bfacb9bSmrg if (written >= 0)
434*0bfacb9bSmrg iov[2].iov_len = written;
435*0bfacb9bSmrg else
436*0bfacb9bSmrg iov[2].iov_len = 0;
437*0bfacb9bSmrg
438*0bfacb9bSmrg iov[3].iov_base = (char*) ": ";
439*0bfacb9bSmrg iov[3].iov_len = strlen (iov[3].iov_base);
440*0bfacb9bSmrg
441*0bfacb9bSmrg iov[4].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ);
442*0bfacb9bSmrg iov[4].iov_len = strlen (iov[4].iov_base);
443*0bfacb9bSmrg
444*0bfacb9bSmrg iov[5].iov_base = (char*) "\n";
445*0bfacb9bSmrg iov[5].iov_len = 1;
446*0bfacb9bSmrg
447*0bfacb9bSmrg estr_writev (iov, 6);
448*0bfacb9bSmrg exit_error (1);
449*0bfacb9bSmrg }
450*0bfacb9bSmrg iexport(os_error_at);
451760c2415Smrg
452760c2415Smrg
453760c2415Smrg /* void runtime_error()-- These are errors associated with an
454760c2415Smrg * invalid fortran program. */
455760c2415Smrg
456760c2415Smrg void
runtime_error(const char * message,...)457760c2415Smrg runtime_error (const char *message, ...)
458760c2415Smrg {
459760c2415Smrg char buffer[ST_ERRBUF_SIZE];
460760c2415Smrg struct iovec iov[3];
461760c2415Smrg va_list ap;
462760c2415Smrg int written;
463760c2415Smrg
464760c2415Smrg recursion_check ();
465760c2415Smrg iov[0].iov_base = (char*) "Fortran runtime error: ";
466760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
467760c2415Smrg va_start (ap, message);
468760c2415Smrg written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
469760c2415Smrg va_end (ap);
470760c2415Smrg if (written >= 0)
471760c2415Smrg {
472760c2415Smrg iov[1].iov_base = buffer;
473760c2415Smrg iov[1].iov_len = written;
474760c2415Smrg iov[2].iov_base = (char*) "\n";
475760c2415Smrg iov[2].iov_len = 1;
476760c2415Smrg estr_writev (iov, 3);
477760c2415Smrg }
478760c2415Smrg exit_error (2);
479760c2415Smrg }
480760c2415Smrg iexport(runtime_error);
481760c2415Smrg
482760c2415Smrg /* void runtime_error_at()-- These are errors associated with a
483760c2415Smrg * run time error generated by the front end compiler. */
484760c2415Smrg
485760c2415Smrg void
runtime_error_at(const char * where,const char * message,...)486760c2415Smrg runtime_error_at (const char *where, const char *message, ...)
487760c2415Smrg {
488760c2415Smrg char buffer[ST_ERRBUF_SIZE];
489760c2415Smrg va_list ap;
490760c2415Smrg struct iovec iov[4];
491760c2415Smrg int written;
492760c2415Smrg
493760c2415Smrg recursion_check ();
494760c2415Smrg iov[0].iov_base = (char*) where;
495760c2415Smrg iov[0].iov_len = strlen (where);
496760c2415Smrg iov[1].iov_base = (char*) "\nFortran runtime error: ";
497760c2415Smrg iov[1].iov_len = strlen (iov[1].iov_base);
498760c2415Smrg va_start (ap, message);
499760c2415Smrg written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
500760c2415Smrg va_end (ap);
501760c2415Smrg if (written >= 0)
502760c2415Smrg {
503760c2415Smrg iov[2].iov_base = buffer;
504760c2415Smrg iov[2].iov_len = written;
505760c2415Smrg iov[3].iov_base = (char*) "\n";
506760c2415Smrg iov[3].iov_len = 1;
507760c2415Smrg estr_writev (iov, 4);
508760c2415Smrg }
509760c2415Smrg exit_error (2);
510760c2415Smrg }
511760c2415Smrg iexport(runtime_error_at);
512760c2415Smrg
513760c2415Smrg
514760c2415Smrg void
runtime_warning_at(const char * where,const char * message,...)515760c2415Smrg runtime_warning_at (const char *where, const char *message, ...)
516760c2415Smrg {
517760c2415Smrg char buffer[ST_ERRBUF_SIZE];
518760c2415Smrg va_list ap;
519760c2415Smrg struct iovec iov[4];
520760c2415Smrg int written;
521760c2415Smrg
522760c2415Smrg iov[0].iov_base = (char*) where;
523760c2415Smrg iov[0].iov_len = strlen (where);
524760c2415Smrg iov[1].iov_base = (char*) "\nFortran runtime warning: ";
525760c2415Smrg iov[1].iov_len = strlen (iov[1].iov_base);
526760c2415Smrg va_start (ap, message);
527760c2415Smrg written = vsnprintf (buffer, ST_ERRBUF_SIZE, message, ap);
528760c2415Smrg va_end (ap);
529760c2415Smrg if (written >= 0)
530760c2415Smrg {
531760c2415Smrg iov[2].iov_base = buffer;
532760c2415Smrg iov[2].iov_len = written;
533760c2415Smrg iov[3].iov_base = (char*) "\n";
534760c2415Smrg iov[3].iov_len = 1;
535760c2415Smrg estr_writev (iov, 4);
536760c2415Smrg }
537760c2415Smrg }
538760c2415Smrg iexport(runtime_warning_at);
539760c2415Smrg
540760c2415Smrg
541760c2415Smrg /* void internal_error()-- These are this-can't-happen errors
542760c2415Smrg * that indicate something deeply wrong. */
543760c2415Smrg
544760c2415Smrg void
internal_error(st_parameter_common * cmp,const char * message)545760c2415Smrg internal_error (st_parameter_common *cmp, const char *message)
546760c2415Smrg {
547760c2415Smrg struct iovec iov[3];
548760c2415Smrg
549760c2415Smrg recursion_check ();
550760c2415Smrg show_locus (cmp);
551760c2415Smrg iov[0].iov_base = (char*) "Internal Error: ";
552760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
553760c2415Smrg iov[1].iov_base = (char*) message;
554760c2415Smrg iov[1].iov_len = strlen (message);
555760c2415Smrg iov[2].iov_base = (char*) "\n";
556760c2415Smrg iov[2].iov_len = 1;
557760c2415Smrg estr_writev (iov, 3);
558760c2415Smrg
559760c2415Smrg /* This function call is here to get the main.o object file included
560760c2415Smrg when linking statically. This works because error.o is supposed to
561760c2415Smrg be always linked in (and the function call is in internal_error
562760c2415Smrg because hopefully it doesn't happen too often). */
563760c2415Smrg stupid_function_name_for_static_linking();
564760c2415Smrg
565760c2415Smrg exit_error (3);
566760c2415Smrg }
567760c2415Smrg
568760c2415Smrg
569760c2415Smrg /* translate_error()-- Given an integer error code, return a string
570760c2415Smrg * describing the error. */
571760c2415Smrg
572760c2415Smrg const char *
translate_error(int code)573760c2415Smrg translate_error (int code)
574760c2415Smrg {
575760c2415Smrg const char *p;
576760c2415Smrg
577760c2415Smrg switch (code)
578760c2415Smrg {
579760c2415Smrg case LIBERROR_EOR:
580760c2415Smrg p = "End of record";
581760c2415Smrg break;
582760c2415Smrg
583760c2415Smrg case LIBERROR_END:
584760c2415Smrg p = "End of file";
585760c2415Smrg break;
586760c2415Smrg
587760c2415Smrg case LIBERROR_OK:
588760c2415Smrg p = "Successful return";
589760c2415Smrg break;
590760c2415Smrg
591760c2415Smrg case LIBERROR_OS:
592760c2415Smrg p = "Operating system error";
593760c2415Smrg break;
594760c2415Smrg
595760c2415Smrg case LIBERROR_BAD_OPTION:
596760c2415Smrg p = "Bad statement option";
597760c2415Smrg break;
598760c2415Smrg
599760c2415Smrg case LIBERROR_MISSING_OPTION:
600760c2415Smrg p = "Missing statement option";
601760c2415Smrg break;
602760c2415Smrg
603760c2415Smrg case LIBERROR_OPTION_CONFLICT:
604760c2415Smrg p = "Conflicting statement options";
605760c2415Smrg break;
606760c2415Smrg
607760c2415Smrg case LIBERROR_ALREADY_OPEN:
608760c2415Smrg p = "File already opened in another unit";
609760c2415Smrg break;
610760c2415Smrg
611760c2415Smrg case LIBERROR_BAD_UNIT:
612760c2415Smrg p = "Unattached unit";
613760c2415Smrg break;
614760c2415Smrg
615760c2415Smrg case LIBERROR_FORMAT:
616760c2415Smrg p = "FORMAT error";
617760c2415Smrg break;
618760c2415Smrg
619760c2415Smrg case LIBERROR_BAD_ACTION:
620760c2415Smrg p = "Incorrect ACTION specified";
621760c2415Smrg break;
622760c2415Smrg
623760c2415Smrg case LIBERROR_ENDFILE:
624760c2415Smrg p = "Read past ENDFILE record";
625760c2415Smrg break;
626760c2415Smrg
627760c2415Smrg case LIBERROR_BAD_US:
628760c2415Smrg p = "Corrupt unformatted sequential file";
629760c2415Smrg break;
630760c2415Smrg
631760c2415Smrg case LIBERROR_READ_VALUE:
632760c2415Smrg p = "Bad value during read";
633760c2415Smrg break;
634760c2415Smrg
635760c2415Smrg case LIBERROR_READ_OVERFLOW:
636760c2415Smrg p = "Numeric overflow on read";
637760c2415Smrg break;
638760c2415Smrg
639760c2415Smrg case LIBERROR_INTERNAL:
640760c2415Smrg p = "Internal error in run-time library";
641760c2415Smrg break;
642760c2415Smrg
643760c2415Smrg case LIBERROR_INTERNAL_UNIT:
644760c2415Smrg p = "Internal unit I/O error";
645760c2415Smrg break;
646760c2415Smrg
647760c2415Smrg case LIBERROR_DIRECT_EOR:
648760c2415Smrg p = "Write exceeds length of DIRECT access record";
649760c2415Smrg break;
650760c2415Smrg
651760c2415Smrg case LIBERROR_SHORT_RECORD:
652760c2415Smrg p = "I/O past end of record on unformatted file";
653760c2415Smrg break;
654760c2415Smrg
655760c2415Smrg case LIBERROR_CORRUPT_FILE:
656760c2415Smrg p = "Unformatted file structure has been corrupted";
657760c2415Smrg break;
658760c2415Smrg
659760c2415Smrg case LIBERROR_INQUIRE_INTERNAL_UNIT:
660760c2415Smrg p = "Inquire statement identifies an internal file";
661760c2415Smrg break;
662760c2415Smrg
663*0bfacb9bSmrg case LIBERROR_BAD_WAIT_ID:
664*0bfacb9bSmrg p = "Bad ID in WAIT statement";
665*0bfacb9bSmrg break;
666*0bfacb9bSmrg
667760c2415Smrg default:
668760c2415Smrg p = "Unknown error code";
669760c2415Smrg break;
670760c2415Smrg }
671760c2415Smrg
672760c2415Smrg return p;
673760c2415Smrg }
674760c2415Smrg
675760c2415Smrg
676760c2415Smrg /* Worker function for generate_error and generate_error_async. Return true
677760c2415Smrg if a straight return is to be done, zero if the program should abort. */
678760c2415Smrg
679760c2415Smrg bool
generate_error_common(st_parameter_common * cmp,int family,const char * message)680760c2415Smrg generate_error_common (st_parameter_common *cmp, int family, const char *message)
681760c2415Smrg {
682760c2415Smrg char errmsg[STRERR_MAXSZ];
683760c2415Smrg
684760c2415Smrg #if ASYNC_IO
685760c2415Smrg gfc_unit *u;
686760c2415Smrg
687760c2415Smrg NOTE ("Entering generate_error_common");
688760c2415Smrg
689760c2415Smrg u = thread_unit;
690760c2415Smrg if (u && u->au)
691760c2415Smrg {
692760c2415Smrg if (u->au->error.has_error)
693760c2415Smrg return true;
694760c2415Smrg
695760c2415Smrg if (__gthread_equal (u->au->thread, __gthread_self ()))
696760c2415Smrg {
697760c2415Smrg u->au->error.has_error = 1;
698760c2415Smrg u->au->error.cmp = cmp;
699760c2415Smrg u->au->error.family = family;
700760c2415Smrg u->au->error.message = message;
701760c2415Smrg return true;
702760c2415Smrg }
703760c2415Smrg }
704760c2415Smrg #endif
705760c2415Smrg
706760c2415Smrg /* If there was a previous error, don't mask it with another
707760c2415Smrg error message, EOF or EOR condition. */
708760c2415Smrg
709760c2415Smrg if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
710760c2415Smrg return true;
711760c2415Smrg
712760c2415Smrg /* Set the error status. */
713760c2415Smrg if ((cmp->flags & IOPARM_HAS_IOSTAT))
714760c2415Smrg *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
715760c2415Smrg
716760c2415Smrg if (message == NULL)
717760c2415Smrg message =
718760c2415Smrg (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
719760c2415Smrg translate_error (family);
720760c2415Smrg
721760c2415Smrg if (cmp->flags & IOPARM_HAS_IOMSG)
722760c2415Smrg cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
723760c2415Smrg
724760c2415Smrg /* Report status back to the compiler. */
725760c2415Smrg cmp->flags &= ~IOPARM_LIBRETURN_MASK;
726760c2415Smrg switch (family)
727760c2415Smrg {
728760c2415Smrg case LIBERROR_EOR:
729760c2415Smrg cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR");
730760c2415Smrg if ((cmp->flags & IOPARM_EOR))
731760c2415Smrg return true;
732760c2415Smrg break;
733760c2415Smrg
734760c2415Smrg case LIBERROR_END:
735760c2415Smrg cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
736760c2415Smrg if ((cmp->flags & IOPARM_END))
737760c2415Smrg return true;
738760c2415Smrg break;
739760c2415Smrg
740760c2415Smrg default:
741760c2415Smrg cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
742760c2415Smrg if ((cmp->flags & IOPARM_ERR))
743760c2415Smrg return true;
744760c2415Smrg break;
745760c2415Smrg }
746760c2415Smrg
747760c2415Smrg /* Return if the user supplied an iostat variable. */
748760c2415Smrg if ((cmp->flags & IOPARM_HAS_IOSTAT))
749760c2415Smrg return true;
750760c2415Smrg
751760c2415Smrg /* Return code, caller is responsible for terminating
752760c2415Smrg the program if necessary. */
753760c2415Smrg
754760c2415Smrg recursion_check ();
755760c2415Smrg show_locus (cmp);
756760c2415Smrg struct iovec iov[3];
757760c2415Smrg iov[0].iov_base = (char*) "Fortran runtime error: ";
758760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
759760c2415Smrg iov[1].iov_base = (char*) message;
760760c2415Smrg iov[1].iov_len = strlen (message);
761760c2415Smrg iov[2].iov_base = (char*) "\n";
762760c2415Smrg iov[2].iov_len = 1;
763760c2415Smrg estr_writev (iov, 3);
764760c2415Smrg return false;
765760c2415Smrg }
766760c2415Smrg
767760c2415Smrg /* generate_error()-- Come here when an error happens. This
768760c2415Smrg * subroutine is called if it is possible to continue on after the error.
769760c2415Smrg * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
770760c2415Smrg * ERR labels are present, we return, otherwise we terminate the program
771760c2415Smrg * after printing a message. The error code is always required but the
772760c2415Smrg * message parameter can be NULL, in which case a string describing
773760c2415Smrg * the most recent operating system error is used.
774760c2415Smrg * If the error is for an asynchronous unit and if the program is currently
775760c2415Smrg * executing the asynchronous thread, just mark the error and return. */
776760c2415Smrg
777760c2415Smrg void
generate_error(st_parameter_common * cmp,int family,const char * message)778760c2415Smrg generate_error (st_parameter_common *cmp, int family, const char *message)
779760c2415Smrg {
780760c2415Smrg if (generate_error_common (cmp, family, message))
781760c2415Smrg return;
782760c2415Smrg
783760c2415Smrg exit_error(2);
784760c2415Smrg }
785760c2415Smrg iexport(generate_error);
786760c2415Smrg
787760c2415Smrg
788760c2415Smrg /* generate_warning()-- Similar to generate_error but just give a warning. */
789760c2415Smrg
790760c2415Smrg void
generate_warning(st_parameter_common * cmp,const char * message)791760c2415Smrg generate_warning (st_parameter_common *cmp, const char *message)
792760c2415Smrg {
793760c2415Smrg if (message == NULL)
794760c2415Smrg message = " ";
795760c2415Smrg
796760c2415Smrg show_locus (cmp);
797760c2415Smrg struct iovec iov[3];
798760c2415Smrg iov[0].iov_base = (char*) "Fortran runtime warning: ";
799760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
800760c2415Smrg iov[1].iov_base = (char*) message;
801760c2415Smrg iov[1].iov_len = strlen (message);
802760c2415Smrg iov[2].iov_base = (char*) "\n";
803760c2415Smrg iov[2].iov_len = 1;
804760c2415Smrg estr_writev (iov, 3);
805760c2415Smrg }
806760c2415Smrg
807760c2415Smrg
808760c2415Smrg /* Whether, for a feature included in a given standard set (GFC_STD_*),
809760c2415Smrg we should issue an error or a warning, or be quiet. */
810760c2415Smrg
811760c2415Smrg notification
notification_std(int std)812760c2415Smrg notification_std (int std)
813760c2415Smrg {
814760c2415Smrg int warning;
815760c2415Smrg
816760c2415Smrg if (!compile_options.pedantic)
817760c2415Smrg return NOTIFICATION_SILENT;
818760c2415Smrg
819760c2415Smrg warning = compile_options.warn_std & std;
820760c2415Smrg if ((compile_options.allow_std & std) != 0 && !warning)
821760c2415Smrg return NOTIFICATION_SILENT;
822760c2415Smrg
823760c2415Smrg return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
824760c2415Smrg }
825760c2415Smrg
826760c2415Smrg
827760c2415Smrg /* Possibly issue a warning/error about use of a nonstandard (or deleted)
828760c2415Smrg feature. An error/warning will be issued if the currently selected
829760c2415Smrg standard does not contain the requested bits. */
830760c2415Smrg
831760c2415Smrg bool
notify_std(st_parameter_common * cmp,int std,const char * message)832760c2415Smrg notify_std (st_parameter_common *cmp, int std, const char * message)
833760c2415Smrg {
834760c2415Smrg int warning;
835760c2415Smrg struct iovec iov[3];
836760c2415Smrg
837760c2415Smrg if (!compile_options.pedantic)
838760c2415Smrg return true;
839760c2415Smrg
840760c2415Smrg warning = compile_options.warn_std & std;
841760c2415Smrg if ((compile_options.allow_std & std) != 0 && !warning)
842760c2415Smrg return true;
843760c2415Smrg
844760c2415Smrg if (!warning)
845760c2415Smrg {
846760c2415Smrg recursion_check ();
847760c2415Smrg show_locus (cmp);
848760c2415Smrg iov[0].iov_base = (char*) "Fortran runtime error: ";
849760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
850760c2415Smrg iov[1].iov_base = (char*) message;
851760c2415Smrg iov[1].iov_len = strlen (message);
852760c2415Smrg iov[2].iov_base = (char*) "\n";
853760c2415Smrg iov[2].iov_len = 1;
854760c2415Smrg estr_writev (iov, 3);
855760c2415Smrg exit_error (2);
856760c2415Smrg }
857760c2415Smrg else
858760c2415Smrg {
859760c2415Smrg show_locus (cmp);
860760c2415Smrg iov[0].iov_base = (char*) "Fortran runtime warning: ";
861760c2415Smrg iov[0].iov_len = strlen (iov[0].iov_base);
862760c2415Smrg iov[1].iov_base = (char*) message;
863760c2415Smrg iov[1].iov_len = strlen (message);
864760c2415Smrg iov[2].iov_base = (char*) "\n";
865760c2415Smrg iov[2].iov_len = 1;
866760c2415Smrg estr_writev (iov, 3);
867760c2415Smrg }
868760c2415Smrg return false;
869760c2415Smrg }
870