All files: Update FSF address.
[gcc.git] / libgfortran / runtime / error.c
1 /* Copyright (C) 2002, 2003, 2005 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 <stdio.h>
33 #include <stdarg.h>
34 #include <string.h>
35 #include <float.h>
36
37 #include "libgfortran.h"
38 #include "../io/io.h"
39
40 /* Error conditions. The tricky part here is printing a message when
41 * it is the I/O subsystem that is severely wounded. Our goal is to
42 * try and print something making the fewest assumptions possible,
43 * then try to clean up before actually exiting.
44 *
45 * The following exit conditions are defined:
46 * 0 Normal program exit.
47 * 1 Terminated because of operating system error.
48 * 2 Error in the runtime library
49 * 3 Internal error in runtime library
50 * 4 Error during error processing (very bad)
51 *
52 * Other error returns are reserved for the STOP statement with a numeric code.
53 */
54
55 /* locus variables. These are optionally set by a caller before a
56 * library subroutine is called. They are always cleared on exit so
57 * that files that report loci and those that do not can be linked
58 * together without reporting an erroneous position. */
59
60 char *filename = 0;
61 iexport_data(filename);
62
63 unsigned line = 0;
64 iexport_data(line);
65
66 /* buffer for integer/ascii conversions. */
67 static char buffer[sizeof (GFC_UINTEGER_LARGEST) * 8 + 1];
68
69
70 /* Returns a pointer to a static buffer. */
71
72 char *
73 gfc_itoa (GFC_INTEGER_LARGEST n)
74 {
75 int negative;
76 char *p;
77 GFC_UINTEGER_LARGEST t;
78
79 if (n == 0)
80 {
81 buffer[0] = '0';
82 buffer[1] = '\0';
83 return buffer;
84 }
85
86 negative = 0;
87 t = n;
88 if (n < 0)
89 {
90 negative = 1;
91 t = -n; /*must use unsigned to protect from overflow*/
92 }
93
94 p = buffer + sizeof (buffer) - 1;
95 *p-- = '\0';
96
97 while (t != 0)
98 {
99 *p-- = '0' + (t % 10);
100 t /= 10;
101 }
102
103 if (negative)
104 *p-- = '-';
105 return ++p;
106 }
107
108
109 /* xtoa()-- Integer to hexadecimal conversion. Returns a pointer to a
110 * static buffer. */
111
112 char *
113 xtoa (GFC_UINTEGER_LARGEST n)
114 {
115 int digit;
116 char *p;
117
118 if (n == 0)
119 {
120 buffer[0] = '0';
121 buffer[1] = '\0';
122 return buffer;
123 }
124
125 p = buffer + sizeof (buffer) - 1;
126 *p-- = '\0';
127
128 while (n != 0)
129 {
130 digit = n & 0xF;
131 if (digit > 9)
132 digit += 'A' - '0' - 10;
133
134 *p-- = '0' + digit;
135 n >>= 4;
136 }
137
138 return ++p;
139 }
140
141
142 /* st_printf()-- simple printf() function for streams that handles the
143 * formats %d, %s and %c. This function handles printing of error
144 * messages that originate within the library itself, not from a user
145 * program. */
146
147 int
148 st_printf (const char *format, ...)
149 {
150 int count, total;
151 va_list arg;
152 char *p, *q;
153 stream *s;
154
155 total = 0;
156 s = init_error_stream ();
157 va_start (arg, format);
158
159 for (;;)
160 {
161 count = 0;
162
163 while (format[count] != '%' && format[count] != '\0')
164 count++;
165
166 if (count != 0)
167 {
168 p = salloc_w (s, &count);
169 memmove (p, format, count);
170 sfree (s);
171 }
172
173 total += count;
174 format += count;
175 if (*format++ == '\0')
176 break;
177
178 switch (*format)
179 {
180 case 'c':
181 count = 1;
182
183 p = salloc_w (s, &count);
184 *p = (char) va_arg (arg, int);
185
186 sfree (s);
187 break;
188
189 case 'd':
190 q = gfc_itoa (va_arg (arg, int));
191 count = strlen (q);
192
193 p = salloc_w (s, &count);
194 memmove (p, q, count);
195 sfree (s);
196 break;
197
198 case 'x':
199 q = xtoa (va_arg (arg, unsigned));
200 count = strlen (q);
201
202 p = salloc_w (s, &count);
203 memmove (p, q, count);
204 sfree (s);
205 break;
206
207 case 's':
208 q = va_arg (arg, char *);
209 count = strlen (q);
210
211 p = salloc_w (s, &count);
212 memmove (p, q, count);
213 sfree (s);
214 break;
215
216 case '\0':
217 return total;
218
219 default:
220 count = 2;
221 p = salloc_w (s, &count);
222 p[0] = format[-1];
223 p[1] = format[0];
224 sfree (s);
225 break;
226 }
227
228 total += count;
229 format++;
230 }
231
232 va_end (arg);
233 return total;
234 }
235
236
237 /* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
238
239 void
240 st_sprintf (char *buffer, const char *format, ...)
241 {
242 va_list arg;
243 char c, *p;
244 int count;
245
246 va_start (arg, format);
247
248 for (;;)
249 {
250 c = *format++;
251 if (c != '%')
252 {
253 *buffer++ = c;
254 if (c == '\0')
255 break;
256 continue;
257 }
258
259 c = *format++;
260 switch (c)
261 {
262 case 'c':
263 *buffer++ = (char) va_arg (arg, int);
264 break;
265
266 case 'd':
267 p = gfc_itoa (va_arg (arg, int));
268 count = strlen (p);
269
270 memcpy (buffer, p, count);
271 buffer += count;
272 break;
273
274 case 's':
275 p = va_arg (arg, char *);
276 count = strlen (p);
277
278 memcpy (buffer, p, count);
279 buffer += count;
280 break;
281
282 default:
283 *buffer++ = c;
284 }
285 }
286
287 va_end (arg);
288 }
289
290
291 /* show_locus()-- Print a line number and filename describing where
292 * something went wrong */
293
294 void
295 show_locus (void)
296 {
297 if (!options.locus || filename == NULL)
298 return;
299
300 st_printf ("At line %d of file %s\n", line, filename);
301 }
302
303
304 /* recursion_check()-- It's possible for additional errors to occur
305 * during fatal error processing. We detect this condition here and
306 * exit with code 4 immediately. */
307
308 #define MAGIC 0x20DE8101
309
310 static void
311 recursion_check (void)
312 {
313 static int magic = 0;
314
315 /* Don't even try to print something at this point */
316 if (magic == MAGIC)
317 sys_exit (4);
318
319 magic = MAGIC;
320 }
321
322
323 /* os_error()-- Operating system error. We get a message from the
324 * operating system, show it and leave. Some operating system errors
325 * are caught and processed by the library. If not, we come here. */
326
327 void
328 os_error (const char *message)
329 {
330 recursion_check ();
331 show_locus ();
332 st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
333 sys_exit (1);
334 }
335
336
337 /* void runtime_error()-- These are errors associated with an
338 * invalid fortran program. */
339
340 void
341 runtime_error (const char *message)
342 {
343 recursion_check ();
344 show_locus ();
345 st_printf ("Fortran runtime error: %s\n", message);
346 sys_exit (2);
347 }
348 iexport(runtime_error);
349
350
351 /* void internal_error()-- These are this-can't-happen errors
352 * that indicate something deeply wrong. */
353
354 void
355 internal_error (const char *message)
356 {
357 recursion_check ();
358 show_locus ();
359 st_printf ("Internal Error: %s\n", message);
360 sys_exit (3);
361 }
362
363
364 /* translate_error()-- Given an integer error code, return a string
365 * describing the error. */
366
367 const char *
368 translate_error (int code)
369 {
370 const char *p;
371
372 switch (code)
373 {
374 case ERROR_EOR:
375 p = "End of record";
376 break;
377
378 case ERROR_END:
379 p = "End of file";
380 break;
381
382 case ERROR_OK:
383 p = "Successful return";
384 break;
385
386 case ERROR_OS:
387 p = "Operating system error";
388 break;
389
390 case ERROR_BAD_OPTION:
391 p = "Bad statement option";
392 break;
393
394 case ERROR_MISSING_OPTION:
395 p = "Missing statement option";
396 break;
397
398 case ERROR_OPTION_CONFLICT:
399 p = "Conflicting statement options";
400 break;
401
402 case ERROR_ALREADY_OPEN:
403 p = "File already opened in another unit";
404 break;
405
406 case ERROR_BAD_UNIT:
407 p = "Unattached unit";
408 break;
409
410 case ERROR_FORMAT:
411 p = "FORMAT error";
412 break;
413
414 case ERROR_BAD_ACTION:
415 p = "Incorrect ACTION specified";
416 break;
417
418 case ERROR_ENDFILE:
419 p = "Read past ENDFILE record";
420 break;
421
422 case ERROR_BAD_US:
423 p = "Corrupt unformatted sequential file";
424 break;
425
426 case ERROR_READ_VALUE:
427 p = "Bad value during read";
428 break;
429
430 case ERROR_READ_OVERFLOW:
431 p = "Numeric overflow on read";
432 break;
433
434 default:
435 p = "Unknown error code";
436 break;
437 }
438
439 return p;
440 }
441
442
443 /* generate_error()-- Come here when an error happens. This
444 * subroutine is called if it is possible to continue on after the
445 * error. If an IOSTAT variable exists, we set it. If the IOSTAT or
446 * ERR label is present, we return, otherwise we terminate the program
447 * after print a message. The error code is always required but the
448 * message parameter can be NULL, in which case a string describing
449 * the most recent operating system error is used. */
450
451 void
452 generate_error (int family, const char *message)
453 {
454 /* Set the error status. */
455 if (ioparm.iostat != NULL)
456 *ioparm.iostat = family;
457
458 /* Report status back to the compiler. */
459 switch (family)
460 {
461 case ERROR_EOR:
462 ioparm.library_return = LIBRARY_EOR;
463 if (ioparm.eor != 0)
464 return;
465 break;
466
467 case ERROR_END:
468 ioparm.library_return = LIBRARY_END;
469 if (ioparm.end != 0)
470 return;
471 break;
472
473 default:
474 ioparm.library_return = LIBRARY_ERROR;
475 if (ioparm.err != 0)
476 return;
477 break;
478 }
479
480 /* Return if the user supplied an iostat variable. */
481 if (ioparm.iostat != NULL)
482 return;
483
484 /* Terminate the program */
485
486 if (message == NULL)
487 message =
488 (family == ERROR_OS) ? get_oserror () : translate_error (family);
489
490 runtime_error (message);
491 }
492
493
494
495 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
496 feature. An error/warning will be issued if the currently selected
497 standard does not contain the requested bits. */
498
499 try
500 notify_std (int std, const char * message)
501 {
502 int warning;
503
504 warning = compile_options.warn_std & std;
505 if ((compile_options.allow_std & std) != 0 && !warning)
506 return SUCCESS;
507
508 show_locus ();
509 if (!warning)
510 {
511 st_printf ("Fortran runtime error: %s\n", message);
512 sys_exit (2);
513 }
514 else
515 st_printf ("Fortran runtime warning: %s\n", message);
516 return FAILURE;
517 }