OSDN Git Service

PR libfortran/20006
[pf3gnuchains/gcc-fork.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, 59 Temple Place - Suite 330,
28 Boston, MA 02111-1307, 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 }