]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/runtime/error.c
1 /* Copyright (C) 2002, 2003, 2005 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. */
38 #include "libgfortran.h"
41 /* Error conditions. The tricky part here is printing a message when
42 * it is the I/O subsystem that is severely wounded. Our goal is to
43 * try and print something making the fewest assumptions possible,
44 * then try to clean up before actually exiting.
46 * The following exit conditions are defined:
47 * 0 Normal program exit.
48 * 1 Terminated because of operating system error.
49 * 2 Error in the runtime library
50 * 3 Internal error in runtime library
51 * 4 Error during error processing (very bad)
53 * Other error returns are reserved for the STOP statement with a numeric code.
56 /* locus variables. These are optionally set by a caller before a
57 * library subroutine is called. They are always cleared on exit so
58 * that files that report loci and those that do not can be linked
59 * together without reporting an erroneous position. */
62 iexport_data(filename
);
67 /* gfc_itoa()-- Integer to decimal conversion. */
70 gfc_itoa (GFC_INTEGER_LARGEST n
, char *buffer
, size_t len
)
74 GFC_UINTEGER_LARGEST t
;
76 assert (len
>= GFC_ITOA_BUF_SIZE
);
86 t
= -n
; /*must use unsigned to protect from overflow*/
89 p
= buffer
+ GFC_ITOA_BUF_SIZE
- 1;
94 *--p
= '0' + (t
% 10);
104 /* xtoa()-- Integer to hexadecimal conversion. */
107 xtoa (GFC_UINTEGER_LARGEST n
, char *buffer
, size_t len
)
112 assert (len
>= GFC_XTOA_BUF_SIZE
);
117 p
= buffer
+ GFC_XTOA_BUF_SIZE
- 1;
124 digit
+= 'A' - '0' - 10;
134 /* st_printf()-- simple printf() function for streams that handles the
135 * formats %d, %s and %c. This function handles printing of error
136 * messages that originate within the library itself, not from a user
140 st_printf (const char *format
, ...)
147 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
150 s
= init_error_stream ();
151 va_start (arg
, format
);
157 while (format
[count
] != '%' && format
[count
] != '\0')
162 p
= salloc_w (s
, &count
);
163 memmove (p
, format
, count
);
169 if (*format
++ == '\0')
177 p
= salloc_w (s
, &count
);
178 *p
= (char) va_arg (arg
, int);
184 q
= gfc_itoa (va_arg (arg
, int), itoa_buf
, sizeof (itoa_buf
));
187 p
= salloc_w (s
, &count
);
188 memmove (p
, q
, count
);
193 q
= xtoa (va_arg (arg
, unsigned), itoa_buf
, sizeof (itoa_buf
));
196 p
= salloc_w (s
, &count
);
197 memmove (p
, q
, count
);
202 q
= va_arg (arg
, char *);
205 p
= salloc_w (s
, &count
);
206 memmove (p
, q
, count
);
215 p
= salloc_w (s
, &count
);
231 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
234 st_sprintf (char *buffer
, const char *format
, ...)
240 char itoa_buf
[GFC_ITOA_BUF_SIZE
];
242 va_start (arg
, format
);
259 *buffer
++ = (char) va_arg (arg
, int);
263 p
= gfc_itoa (va_arg (arg
, int), itoa_buf
, sizeof (itoa_buf
));
266 memcpy (buffer
, p
, count
);
271 p
= va_arg (arg
, char *);
274 memcpy (buffer
, p
, count
);
287 /* show_locus()-- Print a line number and filename describing where
288 * something went wrong */
293 if (!options
.locus
|| filename
== NULL
)
296 st_printf ("At line %d of file %s\n", line
, filename
);
300 /* recursion_check()-- It's possible for additional errors to occur
301 * during fatal error processing. We detect this condition here and
302 * exit with code 4 immediately. */
304 #define MAGIC 0x20DE8101
307 recursion_check (void)
309 static int magic
= 0;
311 /* Don't even try to print something at this point */
319 /* os_error()-- Operating system error. We get a message from the
320 * operating system, show it and leave. Some operating system errors
321 * are caught and processed by the library. If not, we come here. */
324 os_error (const char *message
)
328 st_printf ("Operating system error: %s\n%s\n", get_oserror (), message
);
333 /* void runtime_error()-- These are errors associated with an
334 * invalid fortran program. */
337 runtime_error (const char *message
)
341 st_printf ("Fortran runtime error: %s\n", message
);
344 iexport(runtime_error
);
347 /* void internal_error()-- These are this-can't-happen errors
348 * that indicate something deeply wrong. */
351 internal_error (const char *message
)
355 st_printf ("Internal Error: %s\n", message
);
360 /* translate_error()-- Given an integer error code, return a string
361 * describing the error. */
364 translate_error (int code
)
379 p
= "Successful return";
383 p
= "Operating system error";
386 case ERROR_BAD_OPTION
:
387 p
= "Bad statement option";
390 case ERROR_MISSING_OPTION
:
391 p
= "Missing statement option";
394 case ERROR_OPTION_CONFLICT
:
395 p
= "Conflicting statement options";
398 case ERROR_ALREADY_OPEN
:
399 p
= "File already opened in another unit";
403 p
= "Unattached unit";
410 case ERROR_BAD_ACTION
:
411 p
= "Incorrect ACTION specified";
415 p
= "Read past ENDFILE record";
419 p
= "Corrupt unformatted sequential file";
422 case ERROR_READ_VALUE
:
423 p
= "Bad value during read";
426 case ERROR_READ_OVERFLOW
:
427 p
= "Numeric overflow on read";
431 p
= "Unknown error code";
439 /* generate_error()-- Come here when an error happens. This
440 * subroutine is called if it is possible to continue on after the error.
441 * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
442 * ERR labels are present, we return, otherwise we terminate the program
443 * after printing a message. The error code is always required but the
444 * message parameter can be NULL, in which case a string describing
445 * the most recent operating system error is used. */
448 generate_error (int family
, const char *message
)
450 /* Set the error status. */
451 if (ioparm
.iostat
!= NULL
)
452 *ioparm
.iostat
= family
;
456 (family
== ERROR_OS
) ? get_oserror () : translate_error (family
);
459 cf_strcpy (ioparm
.iomsg
, ioparm
.iomsg_len
, message
);
461 /* Report status back to the compiler. */
465 ioparm
.library_return
= LIBRARY_EOR
;
471 ioparm
.library_return
= LIBRARY_END
;
477 ioparm
.library_return
= LIBRARY_ERROR
;
483 /* Return if the user supplied an iostat variable. */
484 if (ioparm
.iostat
!= NULL
)
487 /* Terminate the program */
489 runtime_error (message
);
494 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
495 feature. An error/warning will be issued if the currently selected
496 standard does not contain the requested bits. */
499 notify_std (int std
, const char * message
)
503 warning
= compile_options
.warn_std
& std
;
504 if ((compile_options
.allow_std
& std
) != 0 && !warning
)
510 st_printf ("Fortran runtime error: %s\n", message
);
514 st_printf ("Fortran runtime warning: %s\n", message
);