OSDN Git Service

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