OSDN Git Service

PR 48915 Abort handling
[pf3gnuchains/gcc-fork.git] / libgfortran / runtime / error.c
1 /* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
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 modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
10 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
27 #include "libgfortran.h"
28 #include <assert.h>
29 #include <string.h>
30 #include <errno.h>
31
32 #ifdef HAVE_SIGNAL_H
33 #include <signal.h>
34 #endif
35
36 #ifdef HAVE_UNISTD_H
37 #include <unistd.h>
38 #endif
39
40 #ifdef HAVE_STDLIB_H
41 #include <stdlib.h>
42 #endif
43
44 #ifdef HAVE_SYS_TIME_H
45 #include <sys/time.h>
46 #endif
47
48 /* <sys/time.h> has to be included before <sys/resource.h> to work
49    around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
50 #ifdef HAVE_SYS_RESOURCE_H
51 #include <sys/resource.h>
52 #endif
53
54
55 #ifdef __MINGW32__
56 #define HAVE_GETPID 1
57 #include <process.h>
58 #endif
59
60
61 /* Termination of a program: F2008 2.3.5 talks about "normal
62    termination" and "error termination". Normal termination occurs as
63    a result of e.g. executing the end program statement, and executing
64    the STOP statement. It includes the effect of the C exit()
65    function. 
66
67    Error termination is initiated when the ERROR STOP statement is
68    executed, when ALLOCATE/DEALLOCATE fails without STAT= being
69    specified, when some of the co-array synchronization statements
70    fail without STAT= being specified, and some I/O errors if
71    ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
72    failure without CMDSTAT=.
73
74    2.3.5 also explains how co-images synchronize during termination.
75
76    In libgfortran we have two ways of ending a program. exit(code) is
77    a normal exit; calling exit() also causes open units to be
78    closed. No backtrace or core dump is needed here. When something
79    goes wrong, we have sys_abort() which tries to print the backtrace
80    if -fbacktrace is enabled, and then dumps core; whether a core file
81    is generated is system dependent. When aborting, we don't flush and
82    close open units, as program memory might be corrupted and we'd
83    rather risk losing dirty data in the buffers rather than corrupting
84    files on disk.
85
86 */
87
88 /* Error conditions.  The tricky part here is printing a message when
89  * it is the I/O subsystem that is severely wounded.  Our goal is to
90  * try and print something making the fewest assumptions possible,
91  * then try to clean up before actually exiting.
92  *
93  * The following exit conditions are defined:
94  * 0    Normal program exit.
95  * 1    Terminated because of operating system error.
96  * 2    Error in the runtime library
97  * 3    Internal error in runtime library
98  *
99  * Other error returns are reserved for the STOP statement with a numeric code.
100  */
101
102
103 /* Write a null-terminated C string to standard error. This function
104    is async-signal-safe.  */
105
106 ssize_t
107 estr_write (const char *str)
108 {
109   return write (STDERR_FILENO, str, strlen (str));
110 }
111
112
113 /* st_vprintf()-- vsnprintf-like function for error output.  We use a
114    stack allocated buffer for formatting; since this function might be
115    called from within a signal handler, printing directly to stderr
116    with vfprintf is not safe since the stderr locking might lead to a
117    deadlock.  */
118
119 #define ST_VPRINTF_SIZE 512
120
121 int
122 st_vprintf (const char *format, va_list ap)
123 {
124   int written;
125   char buffer[ST_VPRINTF_SIZE];
126
127 #ifdef HAVE_VSNPRINTF
128   written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
129 #else
130   written = vsprintf(buffer, format, ap);
131
132   if (written >= ST_VPRINTF_SIZE - 1)
133     {
134       /* The error message was longer than our buffer.  Ouch.  Because
135          we may have messed up things badly, report the error and
136          quit.  */
137 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
138       write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
139       write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
140       sys_abort ();
141 #undef ERROR_MESSAGE
142
143     }
144 #endif
145
146   written = write (STDERR_FILENO, buffer, written);
147   return written;
148 }
149
150
151 int
152 st_printf (const char * format, ...)
153 {
154   int written;
155   va_list ap;
156   va_start (ap, format);
157   written = st_vprintf (format, ap);
158   va_end (ap);
159   return written;
160 }
161
162
163 /* sys_abort()-- Terminate the program showing backtrace and dumping
164    core.  */
165
166 void
167 sys_abort ()
168 {
169   /* If backtracing is enabled, print backtrace and disable signal
170      handler for ABRT.  */
171   if (options.backtrace == 1
172       || (options.backtrace == -1 && compile_options.backtrace == 1))
173     {
174       show_backtrace ();
175 #if defined(HAVE_SIGNAL) && defined(SIGABRT)
176       signal (SIGABRT, SIG_DFL);
177 #endif
178     }
179
180   abort();
181 }
182
183
184 /* gfc_xtoa()-- Integer to hexadecimal conversion.  */
185
186 const char *
187 gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
188 {
189   int digit;
190   char *p;
191
192   assert (len >= GFC_XTOA_BUF_SIZE);
193
194   if (n == 0)
195     return "0";
196
197   p = buffer + GFC_XTOA_BUF_SIZE - 1;
198   *p = '\0';
199
200   while (n != 0)
201     {
202       digit = n & 0xF;
203       if (digit > 9)
204         digit += 'A' - '0' - 10;
205
206       *--p = '0' + digit;
207       n >>= 4;
208     }
209
210   return p;
211 }
212
213
214 /* Hopefully thread-safe wrapper for a strerror_r() style function.  */
215
216 char *
217 gf_strerror (int errnum, 
218              char * buf __attribute__((unused)), 
219              size_t buflen __attribute__((unused)))
220 {
221 #ifdef HAVE_STRERROR_R
222   /* TODO: How to prevent the compiler warning due to strerror_r of
223      the untaken branch having the wrong return type?  */
224   if (__builtin_classify_type (strerror_r (0, buf, 0)) == 5)
225     {
226       /* GNU strerror_r()  */
227       return strerror_r (errnum, buf, buflen);
228     }
229   else
230     {
231       /* POSIX strerror_r ()  */
232       strerror_r (errnum, buf, buflen);
233       return buf;
234     }
235 #else
236   /* strerror () is not necessarily thread-safe, but should at least
237      be available everywhere.  */
238   return strerror (errnum);
239 #endif
240 }
241
242
243 /* show_locus()-- Print a line number and filename describing where
244  * something went wrong */
245
246 void
247 show_locus (st_parameter_common *cmp)
248 {
249   char *filename;
250
251   if (!options.locus || cmp == NULL || cmp->filename == NULL)
252     return;
253   
254   if (cmp->unit > 0)
255     {
256       filename = filename_from_unit (cmp->unit);
257
258       if (filename != NULL)
259         {
260           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
261                    (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
262           free (filename);
263         }
264       else
265         {
266           st_printf ("At line %d of file %s (unit = %d)\n",
267                    (int) cmp->line, cmp->filename, (int) cmp->unit);
268         }
269       return;
270     }
271
272   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
273 }
274
275
276 /* recursion_check()-- It's possible for additional errors to occur
277  * during fatal error processing.  We detect this condition here and
278  * exit with code 4 immediately. */
279
280 #define MAGIC 0x20DE8101
281
282 static void
283 recursion_check (void)
284 {
285   static int magic = 0;
286
287   /* Don't even try to print something at this point */
288   if (magic == MAGIC)
289     sys_abort ();
290
291   magic = MAGIC;
292 }
293
294
295 #define STRERR_MAXSZ 256
296
297 /* os_error()-- Operating system error.  We get a message from the
298  * operating system, show it and leave.  Some operating system errors
299  * are caught and processed by the library.  If not, we come here. */
300
301 void
302 os_error (const char *message)
303 {
304   char errmsg[STRERR_MAXSZ];
305   recursion_check ();
306   estr_write ("Operating system error: ");
307   estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
308   estr_write ("\n");
309   estr_write (message);
310   estr_write ("\n");
311   exit (1);
312 }
313 iexport(os_error);
314
315
316 /* void runtime_error()-- These are errors associated with an
317  * invalid fortran program. */
318
319 void
320 runtime_error (const char *message, ...)
321 {
322   va_list ap;
323
324   recursion_check ();
325   estr_write ("Fortran runtime error: ");
326   va_start (ap, message);
327   st_vprintf (message, ap);
328   va_end (ap);
329   estr_write ("\n");
330   exit (2);
331 }
332 iexport(runtime_error);
333
334 /* void runtime_error_at()-- These are errors associated with a
335  * run time error generated by the front end compiler.  */
336
337 void
338 runtime_error_at (const char *where, const char *message, ...)
339 {
340   va_list ap;
341
342   recursion_check ();
343   estr_write (where);
344   estr_write ("\nFortran runtime error: ");
345   va_start (ap, message);
346   st_vprintf (message, ap);
347   va_end (ap);
348   estr_write ("\n");
349   exit (2);
350 }
351 iexport(runtime_error_at);
352
353
354 void
355 runtime_warning_at (const char *where, const char *message, ...)
356 {
357   va_list ap;
358
359   estr_write (where);
360   estr_write ("\nFortran runtime warning: ");
361   va_start (ap, message);
362   st_vprintf (message, ap);
363   va_end (ap);
364   estr_write ("\n");
365 }
366 iexport(runtime_warning_at);
367
368
369 /* void internal_error()-- These are this-can't-happen errors
370  * that indicate something deeply wrong. */
371
372 void
373 internal_error (st_parameter_common *cmp, const char *message)
374 {
375   recursion_check ();
376   show_locus (cmp);
377   estr_write ("Internal Error: ");
378   estr_write (message);
379   estr_write ("\n");
380
381   /* This function call is here to get the main.o object file included
382      when linking statically. This works because error.o is supposed to
383      be always linked in (and the function call is in internal_error
384      because hopefully it doesn't happen too often).  */
385   stupid_function_name_for_static_linking();
386
387   exit (3);
388 }
389
390
391 /* translate_error()-- Given an integer error code, return a string
392  * describing the error. */
393
394 const char *
395 translate_error (int code)
396 {
397   const char *p;
398
399   switch (code)
400     {
401     case LIBERROR_EOR:
402       p = "End of record";
403       break;
404
405     case LIBERROR_END:
406       p = "End of file";
407       break;
408
409     case LIBERROR_OK:
410       p = "Successful return";
411       break;
412
413     case LIBERROR_OS:
414       p = "Operating system error";
415       break;
416
417     case LIBERROR_BAD_OPTION:
418       p = "Bad statement option";
419       break;
420
421     case LIBERROR_MISSING_OPTION:
422       p = "Missing statement option";
423       break;
424
425     case LIBERROR_OPTION_CONFLICT:
426       p = "Conflicting statement options";
427       break;
428
429     case LIBERROR_ALREADY_OPEN:
430       p = "File already opened in another unit";
431       break;
432
433     case LIBERROR_BAD_UNIT:
434       p = "Unattached unit";
435       break;
436
437     case LIBERROR_FORMAT:
438       p = "FORMAT error";
439       break;
440
441     case LIBERROR_BAD_ACTION:
442       p = "Incorrect ACTION specified";
443       break;
444
445     case LIBERROR_ENDFILE:
446       p = "Read past ENDFILE record";
447       break;
448
449     case LIBERROR_BAD_US:
450       p = "Corrupt unformatted sequential file";
451       break;
452
453     case LIBERROR_READ_VALUE:
454       p = "Bad value during read";
455       break;
456
457     case LIBERROR_READ_OVERFLOW:
458       p = "Numeric overflow on read";
459       break;
460
461     case LIBERROR_INTERNAL:
462       p = "Internal error in run-time library";
463       break;
464
465     case LIBERROR_INTERNAL_UNIT:
466       p = "Internal unit I/O error";
467       break;
468
469     case LIBERROR_DIRECT_EOR:
470       p = "Write exceeds length of DIRECT access record";
471       break;
472
473     case LIBERROR_SHORT_RECORD:
474       p = "I/O past end of record on unformatted file";
475       break;
476
477     case LIBERROR_CORRUPT_FILE:
478       p = "Unformatted file structure has been corrupted";
479       break;
480
481     default:
482       p = "Unknown error code";
483       break;
484     }
485
486   return p;
487 }
488
489
490 /* generate_error()-- Come here when an error happens.  This
491  * subroutine is called if it is possible to continue on after the error.
492  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
493  * ERR labels are present, we return, otherwise we terminate the program
494  * after printing a message.  The error code is always required but the
495  * message parameter can be NULL, in which case a string describing
496  * the most recent operating system error is used. */
497
498 void
499 generate_error (st_parameter_common *cmp, int family, const char *message)
500 {
501   char errmsg[STRERR_MAXSZ];
502
503   /* If there was a previous error, don't mask it with another
504      error message, EOF or EOR condition.  */
505
506   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
507     return;
508
509   /* Set the error status.  */
510   if ((cmp->flags & IOPARM_HAS_IOSTAT))
511     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
512
513   if (message == NULL)
514     message =
515       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
516       translate_error (family);
517
518   if (cmp->flags & IOPARM_HAS_IOMSG)
519     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
520
521   /* Report status back to the compiler.  */
522   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
523   switch (family)
524     {
525     case LIBERROR_EOR:
526       cmp->flags |= IOPARM_LIBRETURN_EOR;
527       if ((cmp->flags & IOPARM_EOR))
528         return;
529       break;
530
531     case LIBERROR_END:
532       cmp->flags |= IOPARM_LIBRETURN_END;
533       if ((cmp->flags & IOPARM_END))
534         return;
535       break;
536
537     default:
538       cmp->flags |= IOPARM_LIBRETURN_ERROR;
539       if ((cmp->flags & IOPARM_ERR))
540         return;
541       break;
542     }
543
544   /* Return if the user supplied an iostat variable.  */
545   if ((cmp->flags & IOPARM_HAS_IOSTAT))
546     return;
547
548   /* Terminate the program */
549
550   recursion_check ();
551   show_locus (cmp);
552   estr_write ("Fortran runtime error: ");
553   estr_write (message);
554   estr_write ("\n");
555   exit (2);
556 }
557 iexport(generate_error);
558
559
560 /* generate_warning()-- Similar to generate_error but just give a warning.  */
561
562 void
563 generate_warning (st_parameter_common *cmp, const char *message)
564 {
565   if (message == NULL)
566     message = " ";
567
568   show_locus (cmp);
569   estr_write ("Fortran runtime warning: ");
570   estr_write (message);
571   estr_write ("\n");
572 }
573
574
575 /* Whether, for a feature included in a given standard set (GFC_STD_*),
576    we should issue an error or a warning, or be quiet.  */
577
578 notification
579 notification_std (int std)
580 {
581   int warning;
582
583   if (!compile_options.pedantic)
584     return NOTIFICATION_SILENT;
585
586   warning = compile_options.warn_std & std;
587   if ((compile_options.allow_std & std) != 0 && !warning)
588     return NOTIFICATION_SILENT;
589
590   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
591 }
592
593
594 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
595    feature.  An error/warning will be issued if the currently selected
596    standard does not contain the requested bits.  */
597
598 try
599 notify_std (st_parameter_common *cmp, int std, const char * message)
600 {
601   int warning;
602
603   if (!compile_options.pedantic)
604     return SUCCESS;
605
606   warning = compile_options.warn_std & std;
607   if ((compile_options.allow_std & std) != 0 && !warning)
608     return SUCCESS;
609
610   if (!warning)
611     {
612       recursion_check ();
613       show_locus (cmp);
614       estr_write ("Fortran runtime error: ");
615       estr_write (message);
616       estr_write ("\n");
617       exit (2);
618     }
619   else
620     {
621       show_locus (cmp);
622       estr_write ("Fortran runtime warning: ");
623       estr_write (message);
624       estr_write ("\n");
625     }
626   return FAILURE;
627 }