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