OSDN Git Service

2bcc293091a5b2ddb7838674c0cfe1c186645ccc
[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
289
290 /* void runtime_error()-- These are errors associated with an
291  * invalid fortran program. */
292
293 void
294 runtime_error (const char *message)
295 {
296   recursion_check ();
297   st_printf ("Fortran runtime error: %s\n", message);
298   sys_exit (2);
299 }
300 iexport(runtime_error);
301
302 /* void runtime_error_at()-- These are errors associated with a
303  * run time error generated by the front end compiler.  */
304
305 void
306 runtime_error_at (const char *where, const char *message)
307 {
308   recursion_check ();
309   st_printf ("%s\n", where);
310   st_printf ("Fortran runtime error: %s\n", message);
311   sys_exit (2);
312 }
313 iexport(runtime_error_at);
314
315
316 /* void internal_error()-- These are this-can't-happen errors
317  * that indicate something deeply wrong. */
318
319 void
320 internal_error (st_parameter_common *cmp, const char *message)
321 {
322   recursion_check ();
323   show_locus (cmp);
324   st_printf ("Internal Error: %s\n", message);
325
326   /* This function call is here to get the main.o object file included
327      when linking statically. This works because error.o is supposed to
328      be always linked in (and the function call is in internal_error
329      because hopefully it doesn't happen too often).  */
330   stupid_function_name_for_static_linking();
331
332   sys_exit (3);
333 }
334
335
336 /* translate_error()-- Given an integer error code, return a string
337  * describing the error. */
338
339 const char *
340 translate_error (int code)
341 {
342   const char *p;
343
344   switch (code)
345     {
346     case ERROR_EOR:
347       p = "End of record";
348       break;
349
350     case ERROR_END:
351       p = "End of file";
352       break;
353
354     case ERROR_OK:
355       p = "Successful return";
356       break;
357
358     case ERROR_OS:
359       p = "Operating system error";
360       break;
361
362     case ERROR_BAD_OPTION:
363       p = "Bad statement option";
364       break;
365
366     case ERROR_MISSING_OPTION:
367       p = "Missing statement option";
368       break;
369
370     case ERROR_OPTION_CONFLICT:
371       p = "Conflicting statement options";
372       break;
373
374     case ERROR_ALREADY_OPEN:
375       p = "File already opened in another unit";
376       break;
377
378     case ERROR_BAD_UNIT:
379       p = "Unattached unit";
380       break;
381
382     case ERROR_FORMAT:
383       p = "FORMAT error";
384       break;
385
386     case ERROR_BAD_ACTION:
387       p = "Incorrect ACTION specified";
388       break;
389
390     case ERROR_ENDFILE:
391       p = "Read past ENDFILE record";
392       break;
393
394     case ERROR_BAD_US:
395       p = "Corrupt unformatted sequential file";
396       break;
397
398     case ERROR_READ_VALUE:
399       p = "Bad value during read";
400       break;
401
402     case ERROR_READ_OVERFLOW:
403       p = "Numeric overflow on read";
404       break;
405
406     case ERROR_INTERNAL:
407       p = "Internal error in run-time library";
408       break;
409
410     case ERROR_INTERNAL_UNIT:
411       p = "Internal unit I/O error";
412       break;
413
414     case ERROR_DIRECT_EOR:
415       p = "Write exceeds length of DIRECT access record";
416       break;
417
418     case ERROR_SHORT_RECORD:
419       p = "I/O past end of record on unformatted file";
420       break;
421
422     case ERROR_CORRUPT_FILE:
423       p = "Unformatted file structure has been corrupted";
424       break;
425
426     default:
427       p = "Unknown error code";
428       break;
429     }
430
431   return p;
432 }
433
434
435 /* generate_error()-- Come here when an error happens.  This
436  * subroutine is called if it is possible to continue on after the error.
437  * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
438  * ERR labels are present, we return, otherwise we terminate the program
439  * after printing a message.  The error code is always required but the
440  * message parameter can be NULL, in which case a string describing
441  * the most recent operating system error is used. */
442
443 void
444 generate_error (st_parameter_common *cmp, int family, const char *message)
445 {
446   /* Set the error status.  */
447   if ((cmp->flags & IOPARM_HAS_IOSTAT))
448     *cmp->iostat = (family == ERROR_OS) ? errno : family;
449
450   if (message == NULL)
451     message =
452       (family == ERROR_OS) ? get_oserror () : translate_error (family);
453
454   if (cmp->flags & IOPARM_HAS_IOMSG)
455     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
456
457   /* Report status back to the compiler.  */
458   cmp->flags &= ~IOPARM_LIBRETURN_MASK;
459   switch (family)
460     {
461     case ERROR_EOR:
462       cmp->flags |= IOPARM_LIBRETURN_EOR;
463       if ((cmp->flags & IOPARM_EOR))
464         return;
465       break;
466
467     case ERROR_END:
468       cmp->flags |= IOPARM_LIBRETURN_END;
469       if ((cmp->flags & IOPARM_END))
470         return;
471       break;
472
473     default:
474       cmp->flags |= IOPARM_LIBRETURN_ERROR;
475       if ((cmp->flags & IOPARM_ERR))
476         return;
477       break;
478     }
479
480   /* Return if the user supplied an iostat variable.  */
481   if ((cmp->flags & IOPARM_HAS_IOSTAT))
482     return;
483
484   /* Terminate the program */
485
486   recursion_check ();
487   show_locus (cmp);
488   st_printf ("Fortran runtime error: %s\n", message);
489   sys_exit (2);
490 }
491 iexport(generate_error);
492
493 /* Whether, for a feature included in a given standard set (GFC_STD_*),
494    we should issue an error or a warning, or be quiet.  */
495
496 notification
497 notification_std (int std)
498 {
499   int warning;
500
501   if (!compile_options.pedantic)
502     return SILENT;
503
504   warning = compile_options.warn_std & std;
505   if ((compile_options.allow_std & std) != 0 && !warning)
506     return SILENT;
507
508   return warning ? WARNING : ERROR;
509 }
510
511
512
513 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
514    feature.  An error/warning will be issued if the currently selected
515    standard does not contain the requested bits.  */
516
517 try
518 notify_std (st_parameter_common *cmp, int std, const char * message)
519 {
520   int warning;
521
522   if (!compile_options.pedantic)
523     return SUCCESS;
524
525   warning = compile_options.warn_std & std;
526   if ((compile_options.allow_std & std) != 0 && !warning)
527     return SUCCESS;
528
529   if (!warning)
530     {
531       recursion_check ();
532       show_locus (cmp);
533       st_printf ("Fortran runtime error: %s\n", message);
534       sys_exit (2);
535     }
536   else
537     {
538       show_locus (cmp);
539       st_printf ("Fortran runtime warning: %s\n", message);
540     }
541   return FAILURE;
542 }