re PR libfortran/20788 (Loading libgfortran.so clobbers C redirection of stdin/stdout...
[gcc.git] / libgfortran / io / read.c
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 (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 <string.h>
33 #include <errno.h>
34 #include <ctype.h>
35 #include <stdlib.h>
36 #include <stdio.h>
37 #include "libgfortran.h"
38 #include "io.h"
39
40 /* read.c -- Deal with formatted reads */
41
42 /* set_integer()-- All of the integer assignments come here to
43 * actually place the value into memory. */
44
45 void
46 set_integer (void *dest, int64_t value, int length)
47 {
48 switch (length)
49 {
50 case 8:
51 *((int64_t *) dest) = value;
52 break;
53 case 4:
54 *((int32_t *) dest) = value;
55 break;
56 case 2:
57 *((int16_t *) dest) = value;
58 break;
59 case 1:
60 *((int8_t *) dest) = value;
61 break;
62 default:
63 internal_error ("Bad integer kind");
64 }
65 }
66
67
68 /* max_value()-- Given a length (kind), return the maximum signed or
69 * unsigned value */
70
71 uint64_t
72 max_value (int length, int signed_flag)
73 {
74 uint64_t value;
75
76 switch (length)
77 {
78 case 8:
79 value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
80 break;
81 case 4:
82 value = signed_flag ? 0x7fffffff : 0xffffffff;
83 break;
84 case 2:
85 value = signed_flag ? 0x7fff : 0xffff;
86 break;
87 case 1:
88 value = signed_flag ? 0x7f : 0xff;
89 break;
90 default:
91 internal_error ("Bad integer kind");
92 }
93
94 return value;
95 }
96
97
98 /* convert_real()-- Convert a character representation of a floating
99 * point number to the machine number. Returns nonzero if there is a
100 * range problem during conversion. TODO: handle not-a-numbers and
101 * infinities. */
102
103 int
104 convert_real (void *dest, const char *buffer, int length)
105 {
106 errno = 0;
107
108 switch (length)
109 {
110 case 4:
111 *((float *) dest) =
112 #if defined(HAVE_STRTOF)
113 strtof (buffer, NULL);
114 #else
115 (float) strtod (buffer, NULL);
116 #endif
117 break;
118 case 8:
119 *((double *) dest) = strtod (buffer, NULL);
120 break;
121 default:
122 internal_error ("Unsupported real kind during IO");
123 }
124
125 if (errno != 0)
126 {
127 generate_error (ERROR_READ_VALUE,
128 "Range error during floating point read");
129 return 1;
130 }
131
132 return 0;
133 }
134
135
136 /* read_l()-- Read a logical value */
137
138 void
139 read_l (fnode * f, char *dest, int length)
140 {
141 char *p;
142 int w;
143
144 w = f->u.w;
145 p = read_block (&w);
146 if (p == NULL)
147 return;
148
149 while (*p == ' ')
150 {
151 if (--w == 0)
152 goto bad;
153 p++;
154 }
155
156 if (*p == '.')
157 {
158 if (--w == 0)
159 goto bad;
160 p++;
161 }
162
163 switch (*p)
164 {
165 case 't':
166 case 'T':
167 set_integer (dest, 1, length);
168 break;
169 case 'f':
170 case 'F':
171 set_integer (dest, 0, length);
172 break;
173 default:
174 bad:
175 generate_error (ERROR_READ_VALUE, "Bad value on logical read");
176 break;
177 }
178 }
179
180
181 /* read_a()-- Read a character record. This one is pretty easy. */
182
183 void
184 read_a (fnode * f, char *p, int length)
185 {
186 char *source;
187 int w, m, n;
188
189 w = f->u.w;
190 if (w == -1) /* '(A)' edit descriptor */
191 w = length;
192
193 source = read_block (&w);
194 if (source == NULL)
195 return;
196 if (w > length)
197 source += (w - length);
198
199 m = (w > length) ? length : w;
200 memcpy (p, source, m);
201
202 n = length - w;
203 if (n > 0)
204 memset (p + m, ' ', n);
205 }
206
207
208 /* eat_leading_spaces()-- Given a character pointer and a width,
209 * ignore the leading spaces. */
210
211 static char *
212 eat_leading_spaces (int *width, char *p)
213 {
214 for (;;)
215 {
216 if (*width == 0 || *p != ' ')
217 break;
218
219 (*width)--;
220 p++;
221 }
222
223 return p;
224 }
225
226
227 static char
228 next_char (char **p, int *w)
229 {
230 char c, *q;
231
232 if (*w == 0)
233 return '\0';
234
235 q = *p;
236 c = *q++;
237 *p = q;
238
239 (*w)--;
240
241 if (c != ' ')
242 return c;
243 if (g.blank_status == BLANK_ZERO)
244 return '0';
245
246 /* At this point, the rest of the field has to be trailing blanks */
247
248 while (*w > 0)
249 {
250 if (*q++ != ' ')
251 return '?';
252 (*w)--;
253 }
254
255 *p = q;
256 return '\0';
257 }
258
259
260 /* read_decimal()-- Read a decimal integer value. The values here are
261 * signed values. */
262
263 void
264 read_decimal (fnode * f, char *dest, int length)
265 {
266 unsigned value, maxv, maxv_10;
267 int v, w, negative;
268 char c, *p;
269
270 w = f->u.w;
271 p = read_block (&w);
272 if (p == NULL)
273 return;
274
275 p = eat_leading_spaces (&w, p);
276 if (w == 0)
277 {
278 set_integer (dest, 0, length);
279 return;
280 }
281
282 maxv = max_value (length, 1);
283 maxv_10 = maxv / 10;
284
285 negative = 0;
286 value = 0;
287
288 switch (*p)
289 {
290 case '-':
291 negative = 1;
292 /* Fall through */
293
294 case '+':
295 p++;
296 if (--w == 0)
297 goto bad;
298 /* Fall through */
299
300 default:
301 break;
302 }
303
304 /* At this point we have a digit-string */
305 value = 0;
306
307 for (;;)
308 {
309 c = next_char (&p, &w);
310 if (c == '\0')
311 break;
312
313 if (c < '0' || c > '9')
314 goto bad;
315
316 if (value > maxv_10)
317 goto overflow;
318
319 c -= '0';
320 value = 10 * value;
321
322 if (value > maxv - c)
323 goto overflow;
324 value += c;
325 }
326
327 v = (signed int) value;
328 if (negative)
329 v = -v;
330
331 set_integer (dest, v, length);
332 return;
333
334 bad:
335 generate_error (ERROR_READ_VALUE, "Bad value during integer read");
336 return;
337
338 overflow:
339 generate_error (ERROR_READ_OVERFLOW,
340 "Value overflowed during integer read");
341 return;
342 }
343
344
345 /* read_radix()-- This function reads values for non-decimal radixes.
346 * The difference here is that we treat the values here as unsigned
347 * values for the purposes of overflow. If minus sign is present and
348 * the top bit is set, the value will be incorrect. */
349
350 void
351 read_radix (fnode * f, char *dest, int length, int radix)
352 {
353 unsigned value, maxv, maxv_r;
354 int v, w, negative;
355 char c, *p;
356
357 w = f->u.w;
358 p = read_block (&w);
359 if (p == NULL)
360 return;
361
362 p = eat_leading_spaces (&w, p);
363 if (w == 0)
364 {
365 set_integer (dest, 0, length);
366 return;
367 }
368
369 maxv = max_value (length, 0);
370 maxv_r = maxv / radix;
371
372 negative = 0;
373 value = 0;
374
375 switch (*p)
376 {
377 case '-':
378 negative = 1;
379 /* Fall through */
380
381 case '+':
382 p++;
383 if (--w == 0)
384 goto bad;
385 /* Fall through */
386
387 default:
388 break;
389 }
390
391 /* At this point we have a digit-string */
392 value = 0;
393
394 for (;;)
395 {
396 c = next_char (&p, &w);
397 if (c == '\0')
398 break;
399
400 switch (radix)
401 {
402 case 2:
403 if (c < '0' || c > '1')
404 goto bad;
405 break;
406
407 case 8:
408 if (c < '0' || c > '7')
409 goto bad;
410 break;
411
412 case 16:
413 switch (c)
414 {
415 case '0':
416 case '1':
417 case '2':
418 case '3':
419 case '4':
420 case '5':
421 case '6':
422 case '7':
423 case '8':
424 case '9':
425 break;
426
427 case 'a':
428 case 'b':
429 case 'c':
430 case 'd':
431 case 'e':
432 case 'f':
433 c = c - 'a' + '9' + 1;
434 break;
435
436 case 'A':
437 case 'B':
438 case 'C':
439 case 'D':
440 case 'E':
441 case 'F':
442 c = c - 'A' + '9' + 1;
443 break;
444
445 default:
446 goto bad;
447 }
448
449 break;
450 }
451
452 if (value > maxv_r)
453 goto overflow;
454
455 c -= '0';
456 value = radix * value;
457
458 if (maxv - c < value)
459 goto overflow;
460 value += c;
461 }
462
463 v = (signed int) value;
464 if (negative)
465 v = -v;
466
467 set_integer (dest, v, length);
468 return;
469
470 bad:
471 generate_error (ERROR_READ_VALUE, "Bad value during integer read");
472 return;
473
474 overflow:
475 generate_error (ERROR_READ_OVERFLOW,
476 "Value overflowed during integer read");
477 return;
478 }
479
480
481 /* read_f()-- Read a floating point number with F-style editing, which
482 is what all of the other floating point descriptors behave as. The
483 tricky part is that optional spaces are allowed after an E or D,
484 and the implicit decimal point if a decimal point is not present in
485 the input. */
486
487 void
488 read_f (fnode * f, char *dest, int length)
489 {
490 int w, seen_dp, exponent;
491 int exponent_sign, val_sign;
492 int ndigits;
493 int edigits;
494 int i;
495 char *p, *buffer;
496 char *digits;
497
498 val_sign = 1;
499 seen_dp = 0;
500 w = f->u.w;
501 p = read_block (&w);
502 if (p == NULL)
503 return;
504
505 p = eat_leading_spaces (&w, p);
506 if (w == 0)
507 {
508 switch (length)
509 {
510 case 4:
511 *((float *) dest) = 0.0f;
512 break;
513
514 case 8:
515 *((double *) dest) = 0.0;
516 break;
517
518 default:
519 internal_error ("Unsupported real kind during IO");
520 }
521
522 return;
523 }
524
525 /* Optional sign */
526
527 if (*p == '-' || *p == '+')
528 {
529 if (*p == '-')
530 val_sign = -1;
531 p++;
532
533 if (--w == 0)
534 goto bad_float;
535 }
536
537 exponent_sign = 1;
538
539 /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
540 is required at this point */
541
542 if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
543 && *p != 'e' && *p != 'E')
544 goto bad_float;
545
546 /* Remember the position of the first digit. */
547 digits = p;
548 ndigits = 0;
549
550 /* Scan through the string to find the exponent. */
551 while (w > 0)
552 {
553 switch (*p)
554 {
555 case '.':
556 if (seen_dp)
557 goto bad_float;
558 seen_dp = 1;
559 /* Fall through */
560
561 case '0':
562 case '1':
563 case '2':
564 case '3':
565 case '4':
566 case '5':
567 case '6':
568 case '7':
569 case '8':
570 case '9':
571 case ' ':
572 ndigits++;
573 *p++;
574 w--;
575 break;
576
577 case '-':
578 exponent_sign = -1;
579 /* Fall through */
580
581 case '+':
582 p++;
583 w--;
584 goto exp2;
585
586 case 'd':
587 case 'e':
588 case 'D':
589 case 'E':
590 p++;
591 w--;
592 goto exp1;
593
594 default:
595 goto bad_float;
596 }
597 }
598
599 /* No exponent has been seen, so we use the current scale factor */
600 exponent = -g.scale_factor;
601 goto done;
602
603 bad_float:
604 generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
605 return;
606
607 /* At this point the start of an exponent has been found */
608 exp1:
609 while (w > 0 && *p == ' ')
610 {
611 w--;
612 p++;
613 }
614
615 switch (*p)
616 {
617 case '-':
618 exponent_sign = -1;
619 /* Fall through */
620
621 case '+':
622 p++;
623 w--;
624 break;
625 }
626
627 if (w == 0)
628 goto bad_float;
629
630 /* At this point a digit string is required. We calculate the value
631 of the exponent in order to take account of the scale factor and
632 the d parameter before explict conversion takes place. */
633 exp2:
634 if (!isdigit (*p))
635 goto bad_float;
636
637 exponent = *p - '0';
638 p++;
639 w--;
640
641 while (w > 0 && isdigit (*p))
642 {
643 exponent = 10 * exponent + *p - '0';
644 p++;
645 w--;
646 }
647
648 /* Only allow trailing blanks */
649
650 while (w > 0)
651 {
652 if (*p != ' ')
653 goto bad_float;
654 p++;
655 w--;
656 }
657
658 exponent = exponent * exponent_sign;
659
660 done:
661 /* Use the precision specified in the format if no decimal point has been
662 seen. */
663 if (!seen_dp)
664 exponent -= f->u.real.d;
665
666 if (exponent > 0)
667 {
668 edigits = 2;
669 i = exponent;
670 }
671 else
672 {
673 edigits = 3;
674 i = -exponent;
675 }
676
677 while (i >= 10)
678 {
679 i /= 10;
680 edigits++;
681 }
682
683 i = ndigits + edigits + 1;
684 if (val_sign < 0)
685 i++;
686
687 if (i < SCRATCH_SIZE)
688 buffer = scratch;
689 else
690 buffer = get_mem (i);
691
692 /* Reformat the string into a temporary buffer. As we're using atof it's
693 easiest to just leave the dcimal point in place. */
694 p = buffer;
695 if (val_sign < 0)
696 *(p++) = '-';
697 for (; ndigits > 0; ndigits--)
698 {
699 if (*digits == ' ' && g.blank_status == BLANK_ZERO)
700 *p = '0';
701 else
702 *p = *digits;
703 p++;
704 digits++;
705 }
706 *(p++) = 'e';
707 sprintf (p, "%d", exponent);
708
709 /* Do the actual conversion. */
710 convert_real (dest, buffer, length);
711
712 if (buffer != scratch)
713 free_mem (buffer);
714
715 return;
716 }
717
718
719 /* read_x()-- Deal with the X/TR descriptor. We just read some data
720 * and never look at it. */
721
722 void
723 read_x (fnode * f)
724 {
725 int n;
726
727 n = f->u.n;
728 read_block (&n);
729 }