]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/runtime/error.c
1 /* Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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)
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
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.
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. */
39 #include "libgfortran.h"
41 #include "../io/unix.h"
43 /* Error conditions. The tricky part here is printing a message when
44 * it is the I/O subsystem that is severely wounded. Our goal is to
45 * try and print something making the fewest assumptions possible,
46 * then try to clean up before actually exiting.
48 * The following exit conditions are defined:
49 * 0 Normal program exit.
50 * 1 Terminated because of operating system error.
51 * 2 Error in the runtime library
52 * 3 Internal error in runtime library
53 * 4 Error during error processing (very bad)
55 * Other error returns are reserved for the STOP statement with a numeric code.
58 /* gfc_itoa()-- Integer to decimal conversion. */
61 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
65 GFC_UINTEGER_LARGEST t
;
67 assert (len
>= GFC_ITOA_BUF_SIZE
);
77 t
= -n
; /*must use unsigned to protect from overflow*/
80 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
85 *--p
= '0' + (t
% 10);
95 /* xtoa()-- Integer to hexadecimal conversion. */
98 xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
103 assert (len
>= GFC_XTOA_BUF_SIZE
);
108 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
115 digit
+= 'A' - '0' - 10;
125 /* st_printf()-- simple printf() function for streams that handles the
126 * formats %d, %s and %c. This function handles printing of error
127 * messages that originate within the library itself, not from a user
131 st_printf (const char *format
, ...)
138 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
139 unix_stream err_stream
;
142 s
= init_error_stream (&err_stream
);
143 va_start (arg
, format
);
149 while (format
[count
] != '%' && format
[count
] != '\0')
154 p
= salloc_w (s
, &count
);
155 memmove (p
, format
, count
);
161 if (*format
++ == '\0')
169 p
= salloc_w (s
, &count
);
170 *p
= (char) va_arg (arg
, int);
176 q
= gfc_itoa (va_arg (arg
, int), itoa_buf
, sizeof (itoa_buf
));
179 p
= salloc_w (s
, &count
);
180 memmove (p
, q
, count
);
185 q
= xtoa (va_arg (arg
, unsigned), itoa_buf
, sizeof (itoa_buf
));
188 p
= salloc_w (s
, &count
);
189 memmove (p
, q
, count
);
194 q
= va_arg (arg
, char *);
197 p
= salloc_w (s
, &count
);
198 memmove (p
, q
, count
);
207 p
= salloc_w (s
, &count
);
223 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
226 st_sprintf (char *buffer
, const char *format
, ...)
232 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
234 va_start (arg
, format
);
251 *buffer
++ = (char) va_arg (arg
, int);
255 p
= gfc_itoa (va_arg (arg
, int), itoa_buf
, sizeof (itoa_buf
));
258 memcpy (buffer
, p
, count
);
263 p
= va_arg (arg
, char *);
266 memcpy (buffer
, p
, count
);
279 /* show_locus()-- Print a line number and filename describing where
280 * something went wrong */
283 show_locus (st_parameter_common
*cmp
)
285 if (!options
.locus
|| cmp
== NULL
|| cmp
->filename
== NULL
)
288 st_printf ("At line %d of file %s\n", (int) cmp
->line
, cmp
->filename
);
292 /* recursion_check()-- It's possible for additional errors to occur
293 * during fatal error processing. We detect this condition here and
294 * exit with code 4 immediately. */
296 #define MAGIC 0x20DE8101
299 recursion_check (void)
301 static int magic
= 0;
303 /* Don't even try to print something at this point */
311 /* os_error()-- Operating system error. We get a message from the
312 * operating system, show it and leave. Some operating system errors
313 * are caught and processed by the library. If not, we come here. */
316 os_error (const char *message
)
319 st_printf ("Operating system error: %s\n%s\n", get_oserror (), message
);
324 /* void runtime_error()-- These are errors associated with an
325 * invalid fortran program. */
328 runtime_error (const char *message
)
331 st_printf ("Fortran runtime error: %s\n", message
);
334 iexport(runtime_error
);
337 /* void internal_error()-- These are this-can't-happen errors
338 * that indicate something deeply wrong. */
341 internal_error (st_parameter_common
*cmp
, const char *message
)
345 st_printf ("Internal Error: %s\n", message
);
347 /* This function call is here to get the main.o object file included
348 when linking statically. This works because error.o is supposed to
349 be always linked in (and the function call is in internal_error
350 because hopefully it doesn't happen too often). */
351 stupid_function_name_for_static_linking();
357 /* translate_error()-- Given an integer error code, return a string
358 * describing the error. */
361 translate_error (int code
)
376 p
= "Successful return";
380 p
= "Operating system error";
383 case ERROR_BAD_OPTION
:
384 p
= "Bad statement option";
387 case ERROR_MISSING_OPTION
:
388 p
= "Missing statement option";
391 case ERROR_OPTION_CONFLICT
:
392 p
= "Conflicting statement options";
395 case ERROR_ALREADY_OPEN
:
396 p
= "File already opened in another unit";
400 p
= "Unattached unit";
407 case ERROR_BAD_ACTION
:
408 p
= "Incorrect ACTION specified";
412 p
= "Read past ENDFILE record";
416 p
= "Corrupt unformatted sequential file";
419 case ERROR_READ_VALUE
:
420 p
= "Bad value during read";
423 case ERROR_READ_OVERFLOW
:
424 p
= "Numeric overflow on read";
428 p
= "Internal error in run-time library";
431 case ERROR_INTERNAL_UNIT
:
432 p
= "Internal unit I/O error";
435 case ERROR_DIRECT_EOR
:
436 p
= "Write exceeds length of DIRECT access record";
439 case ERROR_SHORT_RECORD
:
440 p
= "Short record on unformatted read";
444 p
= "Unknown error code";
452 /* generate_error()-- Come here when an error happens. This
453 * subroutine is called if it is possible to continue on after the error.
454 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
455 * ERR labels are present, we return, otherwise we terminate the program
456 * after printing a message. The error code is always required but the
457 * message parameter can be NULL, in which case a string describing
458 * the most recent operating system error is used. */
461 generate_error (st_parameter_common
*cmp
, int family
, const char *message
)
463 /* Set the error status. */
464 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
465 *cmp
->iostat
= (family
== ERROR_OS
) ? errno
: family
;
469 (family
== ERROR_OS
) ? get_oserror () : translate_error (family
);
471 if (cmp
->flags
& IOPARM_HAS_IOMSG
)
472 cf_strcpy (cmp
->iomsg
, cmp
->iomsg_len
, message
);
474 /* Report status back to the compiler. */
475 cmp
->flags
&= ~IOPARM_LIBRETURN_MASK
;
479 cmp
->flags
|= IOPARM_LIBRETURN_EOR
;
480 if ((cmp
->flags
& IOPARM_EOR
))
485 cmp
->flags
|= IOPARM_LIBRETURN_END
;
486 if ((cmp
->flags
& IOPARM_END
))
491 cmp
->flags
|= IOPARM_LIBRETURN_ERROR
;
492 if ((cmp
->flags
& IOPARM_ERR
))
497 /* Return if the user supplied an iostat variable. */
498 if ((cmp
->flags
& IOPARM_HAS_IOSTAT
))
501 /* Terminate the program */
505 st_printf ("Fortran runtime error: %s\n", message
);
510 /* Whether, for a feature included in a given standard set (GFC_STD_*),
511 we should issue an error or a warning, or be quiet. */
514 notification_std (int std
)
518 if (!compile_options
.pedantic
)
521 warning
= compile_options
.warn_std
& std
;
522 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
525 return warning
? WARNING
: ERROR
;
530 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
531 feature. An error/warning will be issued if the currently selected
532 standard does not contain the requested bits. */
535 notify_std (st_parameter_common
*cmp
, int std
, const char * message
)
539 if (!compile_options
.pedantic
)
542 warning
= compile_options
.warn_std
& std
;
543 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
550 st_printf ("Fortran runtime error: %s\n", message
);
556 st_printf ("Fortran runtime warning: %s\n", message
);