]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/runtime/error.c
1 /* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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)
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.
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.
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/>. */
27 #include "libgfortran.h"
44 #ifdef HAVE_SYS_TIME_H
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>
61 /* sys_exit()-- Terminate the program with an exit code. */
66 /* Show error backtrace if possible. */
67 if (code
!= 0 && code
!= 4
68 && (options
.backtrace
== 1
69 || (options
.backtrace
== -1 && compile_options
.backtrace
== 1)))
72 /* Dump core if requested. */
74 && (options
.dump_core
== 1
75 || (options
.dump_core
== -1 && compile_options
.dump_core
== 1)))
77 #if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
78 /* Warn if a core file cannot be produced because
79 of core size limit. */
81 struct rlimit core_limit
;
83 if (getrlimit (RLIMIT_CORE
, &core_limit
) == 0 && core_limit
.rlim_cur
== 0)
84 st_printf ("** Warning: a core dump was requested, but the core size"
85 "limit\n** is currently zero.\n\n");
89 #if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
90 kill (getpid (), SIGQUIT
);
92 st_printf ("Core dump not possible, sorry.");
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.
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)
112 * Other error returns are reserved for the STOP statement with a numeric code.
115 /* gfc_xtoa()-- Integer to hexadecimal conversion. */
118 gfc_xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
123 assert (len
>= GFC_XTOA_BUF_SIZE
);
128 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
135 digit
+= 'A' - '0' - 10;
144 /* show_locus()-- Print a line number and filename describing where
145 * something went wrong */
148 show_locus (st_parameter_common
*cmp
)
150 static char *filename
;
152 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
157 filename
= filename_from_unit (cmp
->unit
);
158 if (filename
!= NULL
)
160 st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
161 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
, filename
);
166 st_printf ("At line %d of file %s (unit = %d)\n",
167 (int) cmp
->line
, cmp
->filename
, (int) cmp
->unit
);
172 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
176 /* recursion_check()-- It's possible for additional errors to occur
177 * during fatal error processing. We detect this condition here and
178 * exit with code 4 immediately. */
180 #define MAGIC 0x20DE8101
183 recursion_check (void)
185 static int magic
= 0;
187 /* Don't even try to print something at this point */
195 /* os_error()-- Operating system error. We get a message from the
196 * operating system, show it and leave. Some operating system errors
197 * are caught and processed by the library. If not, we come here. */
200 os_error (const char *message
)
203 st_printf ("Operating system error: %s\n%s\n", get_oserror (), message
);
209 /* void runtime_error()-- These are errors associated with an
210 * invalid fortran program. */
213 runtime_error (const char *message
, ...)
218 st_printf ("Fortran runtime error: ");
219 va_start (ap
, message
);
220 st_vprintf (message
, ap
);
225 iexport(runtime_error
);
227 /* void runtime_error_at()-- These are errors associated with a
228 * run time error generated by the front end compiler. */
231 runtime_error_at (const char *where
, const char *message
, ...)
236 st_printf ("%s\n", where
);
237 st_printf ("Fortran runtime error: ");
238 va_start (ap
, message
);
239 st_vprintf (message
, ap
);
244 iexport(runtime_error_at
);
248 runtime_warning_at (const char *where
, const char *message
, ...)
252 st_printf ("%s\n", where
);
253 st_printf ("Fortran runtime warning: ");
254 va_start (ap
, message
);
255 st_vprintf (message
, ap
);
259 iexport(runtime_warning_at
);
262 /* void internal_error()-- These are this-can't-happen errors
263 * that indicate something deeply wrong. */
266 internal_error (st_parameter_common
*cmp
, const char *message
)
270 st_printf ("Internal Error: %s\n", message
);
272 /* This function call is here to get the main.o object file included
273 when linking statically. This works because error.o is supposed to
274 be always linked in (and the function call is in internal_error
275 because hopefully it doesn't happen too often). */
276 stupid_function_name_for_static_linking();
282 /* translate_error()-- Given an integer error code, return a string
283 * describing the error. */
286 translate_error (int code
)
301 p
= "Successful return";
305 p
= "Operating system error";
308 case LIBERROR_BAD_OPTION
:
309 p
= "Bad statement option";
312 case LIBERROR_MISSING_OPTION
:
313 p
= "Missing statement option";
316 case LIBERROR_OPTION_CONFLICT
:
317 p
= "Conflicting statement options";
320 case LIBERROR_ALREADY_OPEN
:
321 p
= "File already opened in another unit";
324 case LIBERROR_BAD_UNIT
:
325 p
= "Unattached unit";
328 case LIBERROR_FORMAT
:
332 case LIBERROR_BAD_ACTION
:
333 p
= "Incorrect ACTION specified";
336 case LIBERROR_ENDFILE
:
337 p
= "Read past ENDFILE record";
340 case LIBERROR_BAD_US
:
341 p
= "Corrupt unformatted sequential file";
344 case LIBERROR_READ_VALUE
:
345 p
= "Bad value during read";
348 case LIBERROR_READ_OVERFLOW
:
349 p
= "Numeric overflow on read";
352 case LIBERROR_INTERNAL
:
353 p
= "Internal error in run-time library";
356 case LIBERROR_INTERNAL_UNIT
:
357 p
= "Internal unit I/O error";
360 case LIBERROR_DIRECT_EOR
:
361 p
= "Write exceeds length of DIRECT access record";
364 case LIBERROR_SHORT_RECORD
:
365 p
= "I/O past end of record on unformatted file";
368 case LIBERROR_CORRUPT_FILE
:
369 p
= "Unformatted file structure has been corrupted";
373 p
= "Unknown error code";
381 /* generate_error()-- Come here when an error happens. This
382 * subroutine is called if it is possible to continue on after the error.
383 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
384 * ERR labels are present, we return, otherwise we terminate the program
385 * after printing a message. The error code is always required but the
386 * message parameter can be NULL, in which case a string describing
387 * the most recent operating system error is used. */
390 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
393 /* If there was a previous error, don't mask it with another
394 error message, EOF or EOR condition. */
396 if ((cmp
->flags
& IOPARM_LIBRETURN_MASK
) == IOPARM_LIBRETURN_ERROR
)
399 /* Set the error status. */
400 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
401 *cmp
->iostat
= (family
== LIBERROR_OS
) ? errno
: family
;
405 (family
== LIBERROR_OS
) ? get_oserror () : translate_error (family
);
407 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
408 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
410 /* Report status back to the compiler. */
411 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
415 cmp
->flags
|= IOPARM_LIBRETURN_EOR
;
416 if ((cmp
->flags
& IOPARM_EOR
))
421 cmp
->flags
|= IOPARM_LIBRETURN_END
;
422 if ((cmp
->flags
& IOPARM_END
))
427 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
;
428 if ((cmp
->flags
& IOPARM_ERR
))
433 /* Return if the user supplied an iostat variable. */
434 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
437 /* Terminate the program */
441 st_printf ("Fortran runtime error: %s\n", message
);
444 iexport(generate_error
);
446 /* Whether, for a feature included in a given standard set (GFC_STD_*),
447 we should issue an error or a warning, or be quiet. */
450 notification_std (int std
)
454 if (!compile_options
.pedantic
)
455 return NOTIFICATION_SILENT
;
457 warning
= compile_options
.warn_std
& std
;
458 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
459 return NOTIFICATION_SILENT
;
461 return warning
? NOTIFICATION_WARNING
: NOTIFICATION_ERROR
;
466 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
467 feature. An error/warning will be issued if the currently selected
468 standard does not contain the requested bits. */
471 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
475 if (!compile_options
.pedantic
)
478 warning
= compile_options
.warn_std
& std
;
479 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
486 st_printf ("Fortran runtime error: %s\n", message
);
492 st_printf ("Fortran runtime warning: %s\n", message
);