OSDN Git Service

PR libfortran/47972
[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 (void)
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   return
223     __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
224                            == 5,
225                            /* GNU strerror_r()  */
226                            strerror_r (errnum, buf, buflen),
227                            /* POSIX strerror_r ()  */
228                            (strerror_r (errnum, buf, buflen), buf));
229 #else
230   /* strerror () is not necessarily thread-safe, but should at least
231      be available everywhere.  */
232   return strerror (errnum);
233 #endif
234 }
235
236
237 /* show_locus()-- Print a line number and filename describing where
238  * something went wrong */
239
240 void
241 show_locus (st_parameter_common *cmp)
242 {
243   char *filename;
244
245   if (!options.locus || cmp == NULL || cmp->filename == NULL)
246     return;
247   
248   if (cmp->unit > 0)
249     {
250       filename = filename_from_unit (cmp->unit);
251
252       if (filename != NULL)
253         {
254           st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
255                    (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
256           free (filename);
257         }
258       else
259         {
260           st_printf ("At line %d of file %s (unit = %d)\n",
261                    (int) cmp->line, cmp->filename, (int) cmp->unit);
262         }
263       return;
264     }
265
266   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
267 }
268
269
270 /* recursion_check()-- It's possible for additional errors to occur
271  * during fatal error processing.  We detect this condition here and
272  * exit with code 4 immediately. */
273
274 #define MAGIC 0x20DE8101
275
276 static void
277 recursion_check (void)
278 {
279   static int magic = 0;
280
281   /* Don't even try to print something at this point */
282   if (magic == MAGIC)
283     sys_abort ();
284
285   magic = MAGIC;
286 }
287
288
289 #define STRERR_MAXSZ 256
290
291 /* os_error()-- Operating system error.  We get a message from the
292  * operating system, show it and leave.  Some operating system errors
293  * are caught and processed by the library.  If not, we come here. */
294
295 void
296 os_error (const char *message)
297 {
298   char errmsg[STRERR_MAXSZ];
299   recursion_check ();
300   estr_write ("Operating system error: ");
301   estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
302   estr_write ("\n");
303   estr_write (message);
304   estr_write ("\n");
305   exit (1);
306 }
307 iexport(os_error);
308
309
310 /* void runtime_error()-- These are errors associated with an
311  * invalid fortran program. */
312
313 void
314 runtime_error (const char *message, ...)
315 {
316   va_list ap;
317
318   recursion_check ();
319   estr_write ("Fortran runtime error: ");
320   va_start (ap, message);
321   st_vprintf (message, ap);
322   va_end (ap);
323   estr_write ("\n");
324   exit (2);
325 }
326 iexport(runtime_error);
327
328 /* void runtime_error_at()-- These are errors associated with a
329  * run time error generated by the front end compiler.  */
330
331 void
332 runtime_error_at (const char *where, const char *message, ...)
333 {
334   va_list ap;
335
336   recursion_check ();
337   estr_write (where);
338   estr_write ("\nFortran runtime error: ");
339   va_start (ap, message);
340   st_vprintf (message, ap);
341   va_end (ap);
342   estr_write ("\n");
343   exit (2);
344 }
345 iexport(runtime_error_at);
346
347
348 void
349 runtime_warning_at (const char *where, const char *message, ...)
350 {
351   va_list ap;
352
353   estr_write (where);
354   estr_write ("\nFortran runtime warning: ");
355   va_start (ap, message);
356   st_vprintf (message, ap);
357   va_end (ap);
358   estr_write ("\n");
359 }
360 iexport(runtime_warning_at);
361
362
363 /* void internal_error()-- These are this-can't-happen errors
364  * that indicate something deeply wrong. */
365
366 void
367 internal_error (st_parameter_common *cmp, const char *message)
368 {
369   recursion_check ();
370   show_locus (cmp);
371   estr_write ("Internal Error: ");
372   estr_write (message);
373   estr_write ("\n");
374
375   /* This function call is here to get the main.o object file included
376      when linking statically. This works because error.o is supposed to
377      be always linked in (and the function call is in internal_error
378      because hopefully it doesn't happen too often).  */
379   stupid_function_name_for_static_linking();
380
381   exit (3);
382 }
383
384
385 /* translate_error()-- Given an integer error code, return a string
386  * describing the error. */
387
388 const char *
389 translate_error (int code)
390 {
391   const char *p;
392
393   switch (code)
394     {
395     case LIBERROR_EOR:
396       p = "End of record";
397       break;
398
399     case LIBERROR_END:
400       p = "End of file";
401       break;
402
403     case LIBERROR_OK:
404       p = "Successful return";
405       break;
406
407     case LIBERROR_OS:
408       p = "Operating system error";
409       break;
410
411     case LIBERROR_BAD_OPTION:
412       p = "Bad statement option";
413       break;
414
415     case LIBERROR_MISSING_OPTION:
416       p = "Missing statement option";
417       break;
418
419     case LIBERROR_OPTION_CONFLICT:
420       p = "Conflicting statement options";
421       break;
422
423     case LIBERROR_ALREADY_OPEN:
424       p = "File already opened in another unit";
425       break;
426
427     case LIBERROR_BAD_UNIT:
428       p = "Unattached unit";
429       break;
430
431     case LIBERROR_FORMAT:
432       p = "FORMAT error";
433       break;
434
435     case LIBERROR_BAD_ACTION:
436       p = "Incorrect ACTION specified";
437       break;
438
439     case LIBERROR_ENDFILE:
440       p = "Read past ENDFILE record";
441       break;
442
443     case LIBERROR_BAD_US:
444       p = "Corrupt unformatted sequential file";
445       break;
446
447     case LIBERROR_READ_VALUE:
448       p = "Bad value during read";
449       break;
450
451     case LIBERROR_READ_OVERFLOW:
452       p = "Numeric overflow on read";
453       break;
454
455     case LIBERROR_INTERNAL:
456       p = "Internal error in run-time library";
457       break;
458
459     case LIBERROR_INTERNAL_UNIT:
460       p = "Internal unit I/O error";
461       break;
462
463     case LIBERROR_DIRECT_EOR:
464       p = "Write exceeds length of DIRECT access record";
465       break;
466
467     case LIBERROR_SHORT_RECORD:
468       p = "I/O past end of record on unformatted file";
469       break;
470
471     case LIBERROR_CORRUPT_FILE:
472       p = "Unformatted file structure has been corrupted";
473       break;
474
475     default:
476       p = "Unknown error code";
477       break;
478     }
479
480   return p;
481 }
482
483
484 /* generate_error()-- Come here when an error happens.  This
485  * subroutine is called if it is possible to continue on after the error.
486  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
487  * ERR labels are present, we return, otherwise we terminate the program
488  * after printing a message.  The error code is always required but the
489  * message parameter can be NULL, in which case a string describing
490  * the most recent operating system error is used. */
491
492 void
493 generate_error (st_parameter_common *cmp, int family, const char *message)
494 {
495   char errmsg[STRERR_MAXSZ];
496
497   /* If there was a previous error, don't mask it with another
498      error message, EOF or EOR condition.  */
499
500   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
501     return;
502
503   /* Set the error status.  */
504   if ((cmp->flags & IOPARM_HAS_IOSTAT))
505     *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
506
507   if (message == NULL)
508     message =
509       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
510       translate_error (family);
511
512   if (cmp->flags & IOPARM_HAS_IOMSG)
513     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
514
515   /* Report status back to the compiler.  */
516   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
517   switch (family)
518     {
519     case LIBERROR_EOR:
520       cmp->flags |= IOPARM_LIBRETURN_EOR;
521       if ((cmp->flags & IOPARM_EOR))
522         return;
523       break;
524
525     case LIBERROR_END:
526       cmp->flags |= IOPARM_LIBRETURN_END;
527       if ((cmp->flags & IOPARM_END))
528         return;
529       break;
530
531     default:
532       cmp->flags |= IOPARM_LIBRETURN_ERROR;
533       if ((cmp->flags & IOPARM_ERR))
534         return;
535       break;
536     }
537
538   /* Return if the user supplied an iostat variable.  */
539   if ((cmp->flags & IOPARM_HAS_IOSTAT))
540     return;
541
542   /* Terminate the program */
543
544   recursion_check ();
545   show_locus (cmp);
546   estr_write ("Fortran runtime error: ");
547   estr_write (message);
548   estr_write ("\n");
549   exit (2);
550 }
551 iexport(generate_error);
552
553
554 /* generate_warning()-- Similar to generate_error but just give a warning.  */
555
556 void
557 generate_warning (st_parameter_common *cmp, const char *message)
558 {
559   if (message == NULL)
560     message = " ";
561
562   show_locus (cmp);
563   estr_write ("Fortran runtime warning: ");
564   estr_write (message);
565   estr_write ("\n");
566 }
567
568
569 /* Whether, for a feature included in a given standard set (GFC_STD_*),
570    we should issue an error or a warning, or be quiet.  */
571
572 notification
573 notification_std (int std)
574 {
575   int warning;
576
577   if (!compile_options.pedantic)
578     return NOTIFICATION_SILENT;
579
580   warning = compile_options.warn_std & std;
581   if ((compile_options.allow_std & std) != 0 && !warning)
582     return NOTIFICATION_SILENT;
583
584   return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
585 }
586
587
588 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
589    feature.  An error/warning will be issued if the currently selected
590    standard does not contain the requested bits.  */
591
592 try
593 notify_std (st_parameter_common *cmp, int std, const char * message)
594 {
595   int warning;
596
597   if (!compile_options.pedantic)
598     return SUCCESS;
599
600   warning = compile_options.warn_std & std;
601   if ((compile_options.allow_std & std) != 0 && !warning)
602     return SUCCESS;
603
604   if (!warning)
605     {
606       recursion_check ();
607       show_locus (cmp);
608       estr_write ("Fortran runtime error: ");
609       estr_write (message);
610       estr_write ("\n");
611       exit (2);
612     }
613   else
614     {
615       show_locus (cmp);
616       estr_write ("Fortran runtime warning: ");
617       estr_write (message);
618       estr_write ("\n");
619     }
620   return FAILURE;
621 }