OSDN Git Service

PR fortran/30723
[pf3gnuchains/gcc-fork.git] / libgfortran / runtime / error.c
1 /* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran 95 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 2, or (at your option)
9 any later version.
10
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file.  (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
18 executable.)
19
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 GNU General Public License for more details.
24
25 You should have received a copy of the GNU General Public License
26 along with libgfortran; see the file COPYING.  If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA.  */
29
30
31 #include "config.h"
32 #include <assert.h>
33 #include <stdio.h>
34 #include <stdarg.h>
35 #include <string.h>
36 #include <errno.h>
37
38 #ifdef HAVE_SIGNAL_H
39 #include <signal.h>
40 #endif
41
42 #ifdef HAVE_UNISTD_H
43 #include <unistd.h>
44 #endif
45
46 #ifdef HAVE_STDLIB_H
47 #include <stdlib.h>
48 #endif
49
50 #ifdef HAVE_SYS_TIME_H
51 #include <sys/time.h>
52 #endif
53
54 /* <sys/time.h> has to be included before <sys/resource.h> to work
55    around PR 30518; otherwise, MacOS 10.3.9 headers are just broken.  */
56 #ifdef HAVE_SYS_RESOURCE_H
57 #include <sys/resource.h>
58 #endif
59
60 #include "libgfortran.h"
61
62 #ifdef __MINGW32__
63 #define HAVE_GETPID 1
64 #include <process.h>
65 #endif
66
67
68 /* sys_exit()-- Terminate the program with an exit code.  */
69
70 void
71 sys_exit (int code)
72 {
73   /* Show error backtrace if possible.  */
74   if (code != 0 && code != 4
75       && (options.backtrace == 1
76           || (options.backtrace == -1 && compile_options.backtrace == 1)))
77     show_backtrace ();
78
79   /* Dump core if requested.  */
80   if (code != 0
81       && (options.dump_core == 1
82          || (options.dump_core == -1 && compile_options.dump_core == 1)))
83     {
84 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
85       /* Warn if a core file cannot be produced because
86          of core size limit.  */
87
88       struct rlimit core_limit;
89
90       if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
91         st_printf ("** Warning: a core dump was requested, but the core size"
92                    "limit\n**          is currently zero.\n\n");
93 #endif
94       
95       
96 #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
97       kill (getpid (), SIGQUIT);
98 #else
99       st_printf ("Core dump not possible, sorry.");
100 #endif
101     }
102
103   exit (code);
104 }
105
106
107 /* Error conditions.  The tricky part here is printing a message when
108  * it is the I/O subsystem that is severely wounded.  Our goal is to
109  * try and print something making the fewest assumptions possible,
110  * then try to clean up before actually exiting.
111  *
112  * The following exit conditions are defined:
113  * 0    Normal program exit.
114  * 1    Terminated because of operating system error.
115  * 2    Error in the runtime library
116  * 3    Internal error in runtime library
117  * 4    Error during error processing (very bad)
118  *
119  * Other error returns are reserved for the STOP statement with a numeric code.
120  */
121
122 /* gfc_itoa()-- Integer to decimal conversion. */
123
124 const char *
125 gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
126 {
127   int negative;
128   char *p;
129   GFC_UINTEGER_LARGEST t;
130
131   assert (len >= GFC_ITOA_BUF_SIZE);
132
133   if (n == 0)
134     return "0";
135
136   negative = 0;
137   t = n;
138   if (n < 0)
139     {
140       negative = 1;
141       t = -n; /*must use unsigned to protect from overflow*/
142     }
143
144   p = buffer + GFC_ITOA_BUF_SIZE - 1;
145   *p = '\0';
146
147   while (t != 0)
148     {
149       *--p = '0' + (t % 10);
150       t /= 10;
151     }
152
153   if (negative)
154     *--p = '-';
155   return p;
156 }
157
158
159 /* xtoa()-- Integer to hexadecimal conversion.  */
160
161 const char *
162 xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
163 {
164   int digit;
165   char *p;
166
167   assert (len >= GFC_XTOA_BUF_SIZE);
168
169   if (n == 0)
170     return "0";
171
172   p = buffer + GFC_XTOA_BUF_SIZE - 1;
173   *p = '\0';
174
175   while (n != 0)
176     {
177       digit = n & 0xF;
178       if (digit > 9)
179         digit += 'A' - '0' - 10;
180
181       *--p = '0' + digit;
182       n >>= 4;
183     }
184
185   return p;
186 }
187
188
189 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
190
191 void
192 st_sprintf (char *buffer, const char *format, ...)
193 {
194   va_list arg;
195   char c;
196   const char *p;
197   int count;
198   char itoa_buf[GFC_ITOA_BUF_SIZE];
199
200   va_start (arg, format);
201
202   for (;;)
203     {
204       c = *format++;
205       if (c != '%')
206         {
207           *buffer++ = c;
208           if (c == '\0')
209             break;
210           continue;
211         }
212
213       c = *format++;
214       switch (c)
215         {
216         case 'c':
217           *buffer++ = (char) va_arg (arg, int);
218           break;
219
220         case 'd':
221           p = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
222           count = strlen (p);
223
224           memcpy (buffer, p, count);
225           buffer += count;
226           break;
227
228         case 's':
229           p = va_arg (arg, char *);
230           count = strlen (p);
231
232           memcpy (buffer, p, count);
233           buffer += count;
234           break;
235
236         default:
237           *buffer++ = c;
238         }
239     }
240
241   va_end (arg);
242 }
243
244
245 /* show_locus()-- Print a line number and filename describing where
246  * something went wrong */
247
248 void
249 show_locus (st_parameter_common *cmp)
250 {
251   if (!options.locus || cmp == NULL || cmp->filename == NULL)
252     return;
253
254   st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
255 }
256
257
258 /* recursion_check()-- It's possible for additional errors to occur
259  * during fatal error processing.  We detect this condition here and
260  * exit with code 4 immediately. */
261
262 #define MAGIC 0x20DE8101
263
264 static void
265 recursion_check (void)
266 {
267   static int magic = 0;
268
269   /* Don't even try to print something at this point */
270   if (magic == MAGIC)
271     sys_exit (4);
272
273   magic = MAGIC;
274 }
275
276
277 /* os_error()-- Operating system error.  We get a message from the
278  * operating system, show it and leave.  Some operating system errors
279  * are caught and processed by the library.  If not, we come here. */
280
281 void
282 os_error (const char *message)
283 {
284   recursion_check ();
285   st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
286   sys_exit (1);
287 }
288 iexport(os_error);
289
290
291 /* void runtime_error()-- These are errors associated with an
292  * invalid fortran program. */
293
294 void
295 runtime_error (const char *message)
296 {
297   recursion_check ();
298   st_printf ("Fortran runtime error: %s\n", message);
299   sys_exit (2);
300 }
301 iexport(runtime_error);
302
303 /* void runtime_error_at()-- These are errors associated with a
304  * run time error generated by the front end compiler.  */
305
306 void
307 runtime_error_at (const char *where, const char *message)
308 {
309   recursion_check ();
310   st_printf ("%s\n", where);
311   st_printf ("Fortran runtime error: %s\n", message);
312   sys_exit (2);
313 }
314 iexport(runtime_error_at);
315
316
317 /* void internal_error()-- These are this-can't-happen errors
318  * that indicate something deeply wrong. */
319
320 void
321 internal_error (st_parameter_common *cmp, const char *message)
322 {
323   recursion_check ();
324   show_locus (cmp);
325   st_printf ("Internal Error: %s\n", message);
326
327   /* This function call is here to get the main.o object file included
328      when linking statically. This works because error.o is supposed to
329      be always linked in (and the function call is in internal_error
330      because hopefully it doesn't happen too often).  */
331   stupid_function_name_for_static_linking();
332
333   sys_exit (3);
334 }
335
336
337 /* translate_error()-- Given an integer error code, return a string
338  * describing the error. */
339
340 const char *
341 translate_error (int code)
342 {
343   const char *p;
344
345   switch (code)
346     {
347     case ERROR_EOR:
348       p = "End of record";
349       break;
350
351     case ERROR_END:
352       p = "End of file";
353       break;
354
355     case ERROR_OK:
356       p = "Successful return";
357       break;
358
359     case ERROR_OS:
360       p = "Operating system error";
361       break;
362
363     case ERROR_BAD_OPTION:
364       p = "Bad statement option";
365       break;
366
367     case ERROR_MISSING_OPTION:
368       p = "Missing statement option";
369       break;
370
371     case ERROR_OPTION_CONFLICT:
372       p = "Conflicting statement options";
373       break;
374
375     case ERROR_ALREADY_OPEN:
376       p = "File already opened in another unit";
377       break;
378
379     case ERROR_BAD_UNIT:
380       p = "Unattached unit";
381       break;
382
383     case ERROR_FORMAT:
384       p = "FORMAT error";
385       break;
386
387     case ERROR_BAD_ACTION:
388       p = "Incorrect ACTION specified";
389       break;
390
391     case ERROR_ENDFILE:
392       p = "Read past ENDFILE record";
393       break;
394
395     case ERROR_BAD_US:
396       p = "Corrupt unformatted sequential file";
397       break;
398
399     case ERROR_READ_VALUE:
400       p = "Bad value during read";
401       break;
402
403     case ERROR_READ_OVERFLOW:
404       p = "Numeric overflow on read";
405       break;
406
407     case ERROR_INTERNAL:
408       p = "Internal error in run-time library";
409       break;
410
411     case ERROR_INTERNAL_UNIT:
412       p = "Internal unit I/O error";
413       break;
414
415     case ERROR_DIRECT_EOR:
416       p = "Write exceeds length of DIRECT access record";
417       break;
418
419     case ERROR_SHORT_RECORD:
420       p = "I/O past end of record on unformatted file";
421       break;
422
423     case ERROR_CORRUPT_FILE:
424       p = "Unformatted file structure has been corrupted";
425       break;
426
427     default:
428       p = "Unknown error code";
429       break;
430     }
431
432   return p;
433 }
434
435
436 /* generate_error()-- Come here when an error happens.  This
437  * subroutine is called if it is possible to continue on after the error.
438  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
439  * ERR labels are present, we return, otherwise we terminate the program
440  * after printing a message.  The error code is always required but the
441  * message parameter can be NULL, in which case a string describing
442  * the most recent operating system error is used. */
443
444 void
445 generate_error (st_parameter_common *cmp, int family, const char *message)
446 {
447   /* Set the error status.  */
448   if ((cmp->flags & IOPARM_HAS_IOSTAT))
449     *cmp->iostat = (family == ERROR_OS) ? errno : family;
450
451   if (message == NULL)
452     message =
453       (family == ERROR_OS) ? get_oserror () : translate_error (family);
454
455   if (cmp->flags & IOPARM_HAS_IOMSG)
456     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
457
458   /* Report status back to the compiler.  */
459   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
460   switch (family)
461     {
462     case ERROR_EOR:
463       cmp->flags |= IOPARM_LIBRETURN_EOR;
464       if ((cmp->flags & IOPARM_EOR))
465         return;
466       break;
467
468     case ERROR_END:
469       cmp->flags |= IOPARM_LIBRETURN_END;
470       if ((cmp->flags & IOPARM_END))
471         return;
472       break;
473
474     default:
475       cmp->flags |= IOPARM_LIBRETURN_ERROR;
476       if ((cmp->flags & IOPARM_ERR))
477         return;
478       break;
479     }
480
481   /* Return if the user supplied an iostat variable.  */
482   if ((cmp->flags & IOPARM_HAS_IOSTAT))
483     return;
484
485   /* Terminate the program */
486
487   recursion_check ();
488   show_locus (cmp);
489   st_printf ("Fortran runtime error: %s\n", message);
490   sys_exit (2);
491 }
492 iexport(generate_error);
493
494 /* Whether, for a feature included in a given standard set (GFC_STD_*),
495    we should issue an error or a warning, or be quiet.  */
496
497 notification
498 notification_std (int std)
499 {
500   int warning;
501
502   if (!compile_options.pedantic)
503     return SILENT;
504
505   warning = compile_options.warn_std & std;
506   if ((compile_options.allow_std & std) != 0 && !warning)
507     return SILENT;
508
509   return warning ? WARNING : ERROR;
510 }
511
512
513
514 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
515    feature.  An error/warning will be issued if the currently selected
516    standard does not contain the requested bits.  */
517
518 try
519 notify_std (st_parameter_common *cmp, int std, const char * message)
520 {
521   int warning;
522
523   if (!compile_options.pedantic)
524     return SUCCESS;
525
526   warning = compile_options.warn_std & std;
527   if ((compile_options.allow_std & std) != 0 && !warning)
528     return SUCCESS;
529
530   if (!warning)
531     {
532       recursion_check ();
533       show_locus (cmp);
534       st_printf ("Fortran runtime error: %s\n", message);
535       sys_exit (2);
536     }
537   else
538     {
539       show_locus (cmp);
540       st_printf ("Fortran runtime warning: %s\n", message);
541     }
542   return FAILURE;
543 }