1 /* Copyright (C) 2002-2022 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
10 any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #include "io.h"
27 #include "fbuf.h"
28 #include "format.h"
29 #include "unix.h"
30 #include <string.h>
31 #include <assert.h>
32 #include "async.h"
33
34 typedef unsigned char uchar;
35
36 /* read.c -- Deal with formatted reads */
37
38
39 /* set_integer()-- All of the integer assignments come here to
40 actually place the value into memory. */
41
42 void
set_integer(void * dest,GFC_INTEGER_LARGEST value,int length)43 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
44 {
45 NOTE ("set_integer: %lld %p", (long long int) value, dest);
46 switch (length)
47 {
48 #ifdef HAVE_GFC_INTEGER_16
49 #ifdef HAVE_GFC_REAL_17
50 case 17:
51 {
52 GFC_INTEGER_16 tmp = value;
53 memcpy (dest, (void *) &tmp, 16);
54 }
55 break;
56 #endif
57 /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
58 case 10:
59 case 16:
60 {
61 GFC_INTEGER_16 tmp = value;
62 memcpy (dest, (void *) &tmp, length);
63 }
64 break;
65 #endif
66 case 8:
67 {
68 GFC_INTEGER_8 tmp = value;
69 memcpy (dest, (void *) &tmp, length);
70 }
71 break;
72 case 4:
73 {
74 GFC_INTEGER_4 tmp = value;
75 memcpy (dest, (void *) &tmp, length);
76 }
77 break;
78 case 2:
79 {
80 GFC_INTEGER_2 tmp = value;
81 memcpy (dest, (void *) &tmp, length);
82 }
83 break;
84 case 1:
85 {
86 GFC_INTEGER_1 tmp = value;
87 memcpy (dest, (void *) &tmp, length);
88 }
89 break;
90 default:
91 internal_error (NULL, "Bad integer kind");
92 }
93 }
94
95
96 /* Max signed value of size give by length argument. */
97
98 GFC_UINTEGER_LARGEST
si_max(int length)99 si_max (int length)
100 {
101 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
102 GFC_UINTEGER_LARGEST value;
103 #endif
104
105 switch (length)
106 {
107 #if defined HAVE_GFC_REAL_17
108 case 17:
109 value = 1;
110 for (int n = 1; n < 4 * 16; n++)
111 value = (value << 2) + 3;
112 return value;
113 #endif
114 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
115 case 16:
116 case 10:
117 value = 1;
118 for (int n = 1; n < 4 * length; n++)
119 value = (value << 2) + 3;
120 return value;
121 #endif
122 case 8:
123 return GFC_INTEGER_8_HUGE;
124 case 4:
125 return GFC_INTEGER_4_HUGE;
126 case 2:
127 return GFC_INTEGER_2_HUGE;
128 case 1:
129 return GFC_INTEGER_1_HUGE;
130 default:
131 internal_error (NULL, "Bad integer kind");
132 }
133 }
134
135
136 /* convert_real()-- Convert a character representation of a floating
137 point number to the machine number. Returns nonzero if there is an
138 invalid input. Note: many architectures (e.g. IA-64, HP-PA)
139 require that the storage pointed to by the dest argument is
140 properly aligned for the type in question. */
141
142 int
convert_real(st_parameter_dt * dtp,void * dest,const char * buffer,int length)143 convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
144 {
145 char *endptr = NULL;
146 int round_mode, old_round_mode;
147
148 switch (dtp->u.p.current_unit->round_status)
149 {
150 case ROUND_COMPATIBLE:
151 /* FIXME: As NEAREST but round away from zero for a tie. */
152 case ROUND_UNSPECIFIED:
153 /* Should not occur. */
154 case ROUND_PROCDEFINED:
155 round_mode = ROUND_NEAREST;
156 break;
157 default:
158 round_mode = dtp->u.p.current_unit->round_status;
159 break;
160 }
161
162 old_round_mode = get_fpu_rounding_mode();
163 set_fpu_rounding_mode (round_mode);
164
165 switch (length)
166 {
167 case 4:
168 *((GFC_REAL_4*) dest) =
169 #if defined(HAVE_STRTOF)
170 gfc_strtof (buffer, &endptr);
171 #else
172 (GFC_REAL_4) gfc_strtod (buffer, &endptr);
173 #endif
174 break;
175
176 case 8:
177 *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr);
178 break;
179
180 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
181 case 10:
182 *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr);
183 break;
184 #endif
185
186 #if defined(HAVE_GFC_REAL_16)
187 # if defined(GFC_REAL_16_IS_FLOAT128)
188 case 16:
189 *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr);
190 break;
191 # elif defined(HAVE_STRTOLD)
192 case 16:
193 *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr);
194 break;
195 # endif
196 #endif
197
198 #if defined(HAVE_GFC_REAL_17)
199 case 17:
200 # if defined(POWER_IEEE128)
201 *((GFC_REAL_17*) dest) = __strtoieee128 (buffer, &endptr);
202 # else
203 *((GFC_REAL_17*) dest) = __qmath_(strtoflt128) (buffer, &endptr);
204 # endif
205 break;
206 #endif
207
208 default:
209 internal_error (&dtp->common, "Unsupported real kind during IO");
210 }
211
212 set_fpu_rounding_mode (old_round_mode);
213
214 if (buffer == endptr)
215 {
216 generate_error (&dtp->common, LIBERROR_READ_VALUE,
217 "Error during floating point read");
218 next_record (dtp, 1);
219 return 1;
220 }
221
222 return 0;
223 }
224
225 /* convert_infnan()-- Convert character INF/NAN representation to the
226 machine number. Note: many architectures (e.g. IA-64, HP-PA) require
227 that the storage pointed to by the dest argument is properly aligned
228 for the type in question. */
229
230 int
convert_infnan(st_parameter_dt * dtp,void * dest,const char * buffer,int length)231 convert_infnan (st_parameter_dt *dtp, void *dest, const char *buffer,
232 int length)
233 {
234 const char *s = buffer;
235 int is_inf, plus = 1;
236
237 if (*s == '+')
238 s++;
239 else if (*s == '-')
240 {
241 s++;
242 plus = 0;
243 }
244
245 is_inf = *s == 'i';
246
247 switch (length)
248 {
249 case 4:
250 if (is_inf)
251 *((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff ();
252 else
253 *((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf ("");
254 break;
255
256 case 8:
257 if (is_inf)
258 *((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf ();
259 else
260 *((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan ("");
261 break;
262
263 #if defined(HAVE_GFC_REAL_10)
264 case 10:
265 if (is_inf)
266 *((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
267 else
268 *((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
269 break;
270 #endif
271
272 #if defined(HAVE_GFC_REAL_16)
273 # if defined(GFC_REAL_16_IS_FLOAT128)
274 case 16:
275 *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
276 break;
277 # else
278 case 16:
279 if (is_inf)
280 *((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
281 else
282 *((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
283 break;
284 # endif
285 #endif
286
287 #if defined(HAVE_GFC_REAL_17)
288 case 17:
289 if (is_inf)
290 *((GFC_REAL_17*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
291 else
292 *((GFC_REAL_17*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
293 break;
294 #endif
295
296 default:
297 internal_error (&dtp->common, "Unsupported real kind during IO");
298 }
299
300 return 0;
301 }
302
303
304 /* read_l()-- Read a logical value */
305
306 void
read_l(st_parameter_dt * dtp,const fnode * f,char * dest,int length)307 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
308 {
309 char *p;
310 size_t w;
311
312 w = f->u.w;
313
314 p = read_block_form (dtp, &w);
315
316 if (p == NULL)
317 return;
318
319 while (*p == ' ')
320 {
321 if (--w == 0)
322 goto bad;
323 p++;
324 }
325
326 if (*p == '.')
327 {
328 if (--w == 0)
329 goto bad;
330 p++;
331 }
332
333 switch (*p)
334 {
335 case 't':
336 case 'T':
337 set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
338 break;
339 case 'f':
340 case 'F':
341 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
342 break;
343 default:
344 bad:
345 generate_error (&dtp->common, LIBERROR_READ_VALUE,
346 "Bad value on logical read");
347 next_record (dtp, 1);
348 break;
349 }
350 }
351
352
353 static gfc_char4_t
read_utf8(st_parameter_dt * dtp,size_t * nbytes)354 read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
355 {
356 static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
357 static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
358 size_t nb, nread;
359 gfc_char4_t c;
360 char *s;
361
362 *nbytes = 1;
363
364 s = read_block_form (dtp, nbytes);
365 if (s == NULL)
366 return 0;
367
368 /* If this is a short read, just return. */
369 if (*nbytes == 0)
370 return 0;
371
372 c = (uchar) s[0];
373 if (c < 0x80)
374 return c;
375
376 /* The number of leading 1-bits in the first byte indicates how many
377 bytes follow. */
378 for (nb = 2; nb < 7; nb++)
379 if ((c & ~masks[nb-1]) == patns[nb-1])
380 goto found;
381 goto invalid;
382
383 found:
384 c = (c & masks[nb-1]);
385 nread = nb - 1;
386
387 s = read_block_form (dtp, &nread);
388 if (s == NULL)
389 return 0;
390 /* Decode the bytes read. */
391 for (size_t i = 1; i < nb; i++)
392 {
393 gfc_char4_t n = *s++;
394
395 if ((n & 0xC0) != 0x80)
396 goto invalid;
397
398 c = ((c << 6) + (n & 0x3F));
399 }
400
401 /* Make sure the shortest possible encoding was used. */
402 if (c <= 0x7F && nb > 1) goto invalid;
403 if (c <= 0x7FF && nb > 2) goto invalid;
404 if (c <= 0xFFFF && nb > 3) goto invalid;
405 if (c <= 0x1FFFFF && nb > 4) goto invalid;
406 if (c <= 0x3FFFFFF && nb > 5) goto invalid;
407
408 /* Make sure the character is valid. */
409 if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF))
410 goto invalid;
411
412 return c;
413
414 invalid:
415 generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
416 return (gfc_char4_t) '?';
417 }
418
419
420 static void
read_utf8_char1(st_parameter_dt * dtp,char * p,size_t len,size_t width)421 read_utf8_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
422 {
423 gfc_char4_t c;
424 char *dest;
425 size_t nbytes, j;
426
427 len = (width < len) ? len : width;
428
429 dest = (char *) p;
430
431 /* Proceed with decoding one character at a time. */
432 for (j = 0; j < len; j++, dest++)
433 {
434 c = read_utf8 (dtp, &nbytes);
435
436 /* Check for a short read and if so, break out. */
437 if (nbytes == 0)
438 break;
439
440 *dest = c > 255 ? '?' : (uchar) c;
441 }
442
443 /* If there was a short read, pad the remaining characters. */
444 for (size_t i = j; i < len; i++)
445 *dest++ = ' ';
446 return;
447 }
448
449 static void
read_default_char1(st_parameter_dt * dtp,char * p,size_t len,size_t width)450 read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
451 {
452 char *s;
453 size_t m;
454
455 s = read_block_form (dtp, &width);
456
457 if (s == NULL)
458 return;
459 if (width > len)
460 s += (width - len);
461
462 m = (width > len) ? len : width;
463 memcpy (p, s, m);
464
465 if (len > width)
466 memset (p + m, ' ', len - width);
467 }
468
469
470 static void
read_utf8_char4(st_parameter_dt * dtp,void * p,size_t len,size_t width)471 read_utf8_char4 (st_parameter_dt *dtp, void *p, size_t len, size_t width)
472 {
473 gfc_char4_t *dest;
474 size_t nbytes, j;
475
476 len = (width < len) ? len : width;
477
478 dest = (gfc_char4_t *) p;
479
480 /* Proceed with decoding one character at a time. */
481 for (j = 0; j < len; j++, dest++)
482 {
483 *dest = read_utf8 (dtp, &nbytes);
484
485 /* Check for a short read and if so, break out. */
486 if (nbytes == 0)
487 break;
488 }
489
490 /* If there was a short read, pad the remaining characters. */
491 for (size_t i = j; i < len; i++)
492 *dest++ = (gfc_char4_t) ' ';
493 return;
494 }
495
496
497 static void
read_default_char4(st_parameter_dt * dtp,char * p,size_t len,size_t width)498 read_default_char4 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
499 {
500 size_t m, n;
501 gfc_char4_t *dest;
502
503 if (is_char4_unit(dtp))
504 {
505 gfc_char4_t *s4;
506
507 s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
508
509 if (s4 == NULL)
510 return;
511 if (width > len)
512 s4 += (width - len);
513
514 m = (width > len) ? len : width;
515
516 dest = (gfc_char4_t *) p;
517
518 for (n = 0; n < m; n++)
519 *dest++ = *s4++;
520
521 if (len > width)
522 {
523 for (n = 0; n < len - width; n++)
524 *dest++ = (gfc_char4_t) ' ';
525 }
526 }
527 else
528 {
529 char *s;
530
531 s = read_block_form (dtp, &width);
532
533 if (s == NULL)
534 return;
535 if (width > len)
536 s += (width - len);
537
538 m = (width > len) ? len : width;
539
540 dest = (gfc_char4_t *) p;
541
542 for (n = 0; n < m; n++, dest++, s++)
543 *dest = (unsigned char ) *s;
544
545 if (len > width)
546 {
547 for (n = 0; n < len - width; n++, dest++)
548 *dest = (unsigned char) ' ';
549 }
550 }
551 }
552
553
554 /* read_a()-- Read a character record into a KIND=1 character destination,
555 processing UTF-8 encoding if necessary. */
556
557 void
read_a(st_parameter_dt * dtp,const fnode * f,char * p,size_t length)558 read_a (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
559 {
560 size_t w;
561
562 if (f->u.w == -1) /* '(A)' edit descriptor */
563 w = length;
564 else
565 w = f->u.w;
566
567 /* Read in w characters, treating comma as not a separator. */
568 dtp->u.p.sf_read_comma = 0;
569
570 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
571 read_utf8_char1 (dtp, p, length, w);
572 else
573 read_default_char1 (dtp, p, length, w);
574
575 dtp->u.p.sf_read_comma =
576 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
577 }
578
579
580 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
581 processing UTF-8 encoding if necessary. */
582
583 void
read_a_char4(st_parameter_dt * dtp,const fnode * f,char * p,size_t length)584 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
585 {
586 size_t w;
587
588 if (f->u.w == -1) /* '(A)' edit descriptor */
589 w = length;
590 else
591 w = f->u.w;
592
593 /* Read in w characters, treating comma as not a separator. */
594 dtp->u.p.sf_read_comma = 0;
595
596 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
597 read_utf8_char4 (dtp, p, length, w);
598 else
599 read_default_char4 (dtp, p, length, w);
600
601 dtp->u.p.sf_read_comma =
602 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
603 }
604
605 /* eat_leading_spaces()-- Given a character pointer and a width,
606 ignore the leading spaces. */
607
608 static char *
eat_leading_spaces(size_t * width,char * p)609 eat_leading_spaces (size_t *width, char *p)
610 {
611 for (;;)
612 {
613 if (*width == 0 || *p != ' ')
614 break;
615
616 (*width)--;
617 p++;
618 }
619
620 return p;
621 }
622
623
624 static char
next_char(st_parameter_dt * dtp,char ** p,size_t * w)625 next_char (st_parameter_dt *dtp, char **p, size_t *w)
626 {
627 char c, *q;
628
629 if (*w == 0)
630 return '\0';
631
632 q = *p;
633 c = *q++;
634 *p = q;
635
636 (*w)--;
637
638 if (c != ' ')
639 return c;
640 if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
641 return ' '; /* return a blank to signal a null */
642
643 /* At this point, the rest of the field has to be trailing blanks */
644
645 while (*w > 0)
646 {
647 if (*q++ != ' ')
648 return '?';
649 (*w)--;
650 }
651
652 *p = q;
653 return '\0';
654 }
655
656
657 /* read_decimal()-- Read a decimal integer value. The values here are
658 signed values. */
659
660 void
read_decimal(st_parameter_dt * dtp,const fnode * f,char * dest,int length)661 read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
662 {
663 GFC_UINTEGER_LARGEST value, maxv, maxv_10;
664 GFC_INTEGER_LARGEST v;
665 size_t w;
666 int negative;
667 char c, *p;
668
669 w = f->u.w;
670
671 /* This is a legacy extension, and the frontend will only allow such cases
672 * through when -fdec-format-defaults is passed.
673 */
674 if (w == (size_t) DEFAULT_WIDTH)
675 w = default_width_for_integer (length);
676
677 p = read_block_form (dtp, &w);
678
679 if (p == NULL)
680 return;
681
682 p = eat_leading_spaces (&w, p);
683 if (w == 0)
684 {
685 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
686 return;
687 }
688
689 negative = 0;
690
691 switch (*p)
692 {
693 case '-':
694 negative = 1;
695 /* Fall through */
696
697 case '+':
698 p++;
699 if (--w == 0)
700 goto bad;
701 /* Fall through */
702
703 default:
704 break;
705 }
706
707 maxv = si_max (length);
708 if (negative)
709 maxv++;
710 maxv_10 = maxv / 10;
711
712 /* At this point we have a digit-string */
713 value = 0;
714
715 for (;;)
716 {
717 c = next_char (dtp, &p, &w);
718 if (c == '\0')
719 break;
720
721 if (c == ' ')
722 {
723 if (dtp->u.p.blank_status == BLANK_NULL)
724 {
725 /* Skip spaces. */
726 for ( ; w > 0; p++, w--)
727 if (*p != ' ') break;
728 continue;
729 }
730 if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
731 }
732
733 if (c < '0' || c > '9')
734 goto bad;
735
736 if (value > maxv_10)
737 goto overflow;
738
739 c -= '0';
740 value = 10 * value;
741
742 if (value > maxv - c)
743 goto overflow;
744 value += c;
745 }
746
747 if (negative)
748 v = -value;
749 else
750 v = value;
751
752 set_integer (dest, v, length);
753 return;
754
755 bad:
756 generate_error (&dtp->common, LIBERROR_READ_VALUE,
757 "Bad value during integer read");
758 next_record (dtp, 1);
759 return;
760
761 overflow:
762 generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
763 "Value overflowed during integer read");
764 next_record (dtp, 1);
765
766 }
767
768
769 /* read_radix()-- This function reads values for non-decimal radixes.
770 The difference here is that we treat the values here as unsigned
771 values for the purposes of overflow. If minus sign is present and
772 the top bit is set, the value will be incorrect. */
773
774 void
read_radix(st_parameter_dt * dtp,const fnode * f,char * dest,int length,int radix)775 read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
776 int radix)
777 {
778 GFC_UINTEGER_LARGEST value, maxv, maxv_r;
779 GFC_INTEGER_LARGEST v;
780 size_t w;
781 int negative;
782 char c, *p;
783
784 w = f->u.w;
785
786 p = read_block_form (dtp, &w);
787
788 if (p == NULL)
789 return;
790
791 p = eat_leading_spaces (&w, p);
792 if (w == 0)
793 {
794 set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
795 return;
796 }
797
798 /* Maximum unsigned value, assuming two's complement. */
799 maxv = 2 * si_max (length) + 1;
800 maxv_r = maxv / radix;
801
802 negative = 0;
803 value = 0;
804
805 switch (*p)
806 {
807 case '-':
808 negative = 1;
809 /* Fall through */
810
811 case '+':
812 p++;
813 if (--w == 0)
814 goto bad;
815 /* Fall through */
816
817 default:
818 break;
819 }
820
821 /* At this point we have a digit-string */
822 value = 0;
823
824 for (;;)
825 {
826 c = next_char (dtp, &p, &w);
827 if (c == '\0')
828 break;
829 if (c == ' ')
830 {
831 if (dtp->u.p.blank_status == BLANK_NULL) continue;
832 if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
833 }
834
835 switch (radix)
836 {
837 case 2:
838 if (c < '0' || c > '1')
839 goto bad;
840 break;
841
842 case 8:
843 if (c < '0' || c > '7')
844 goto bad;
845 break;
846
847 case 16:
848 switch (c)
849 {
850 case '0':
851 case '1':
852 case '2':
853 case '3':
854 case '4':
855 case '5':
856 case '6':
857 case '7':
858 case '8':
859 case '9':
860 break;
861
862 case 'a':
863 case 'b':
864 case 'c':
865 case 'd':
866 case 'e':
867 case 'f':
868 c = c - 'a' + '9' + 1;
869 break;
870
871 case 'A':
872 case 'B':
873 case 'C':
874 case 'D':
875 case 'E':
876 case 'F':
877 c = c - 'A' + '9' + 1;
878 break;
879
880 default:
881 goto bad;
882 }
883
884 break;
885 }
886
887 if (value > maxv_r)
888 goto overflow;
889
890 c -= '0';
891 value = radix * value;
892
893 if (maxv - c < value)
894 goto overflow;
895 value += c;
896 }
897
898 v = value;
899 if (negative)
900 v = -v;
901
902 set_integer (dest, v, length);
903 return;
904
905 bad:
906 generate_error (&dtp->common, LIBERROR_READ_VALUE,
907 "Bad value during integer read");
908 next_record (dtp, 1);
909 return;
910
911 overflow:
912 generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
913 "Value overflowed during integer read");
914 next_record (dtp, 1);
915
916 }
917
918
919 /* read_f()-- Read a floating point number with F-style editing, which
920 is what all of the other floating point descriptors behave as. The
921 tricky part is that optional spaces are allowed after an E or D,
922 and the implicit decimal point if a decimal point is not present in
923 the input. */
924
925 void
read_f(st_parameter_dt * dtp,const fnode * f,char * dest,int length)926 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
927 {
928 #define READF_TMP 50
929 char tmp[READF_TMP];
930 size_t buf_size = 0;
931 size_t w;
932 int seen_dp, exponent;
933 int exponent_sign;
934 const char *p;
935 char *buffer;
936 char *out;
937 int seen_int_digit; /* Seen a digit before the decimal point? */
938 int seen_dec_digit; /* Seen a digit after the decimal point? */
939
940 seen_dp = 0;
941 seen_int_digit = 0;
942 seen_dec_digit = 0;
943 exponent_sign = 1;
944 exponent = 0;
945 w = f->u.w;
946 buffer = tmp;
947
948 /* Read in the next block. */
949 p = read_block_form (dtp, &w);
950 if (p == NULL)
951 return;
952 p = eat_leading_spaces (&w, (char*) p);
953 if (w == 0)
954 goto zero;
955
956 /* In this buffer we're going to re-format the number cleanly to be parsed
957 by convert_real in the end; this assures we're using strtod from the
958 C library for parsing and thus probably get the best accuracy possible.
959 This process may add a '+0.0' in front of the number as well as change the
960 exponent because of an implicit decimal point or the like. Thus allocating
961 strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
962 original buffer had should be enough. */
963 buf_size = w + 11;
964 if (buf_size > READF_TMP)
965 buffer = xmalloc (buf_size);
966
967 out = buffer;
968
969 /* Optional sign */
970 if (*p == '-' || *p == '+')
971 {
972 if (*p == '-')
973 *(out++) = '-';
974 ++p;
975 --w;
976 }
977
978 p = eat_leading_spaces (&w, (char*) p);
979 if (w == 0)
980 goto zero;
981
982 /* Check for Infinity or NaN. */
983 if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
984 {
985 int seen_paren = 0;
986 char *save = out;
987
988 /* Scan through the buffer keeping track of spaces and parenthesis. We
989 null terminate the string as soon as we see a left paren or if we are
990 BLANK_NULL mode. Leading spaces have already been skipped above,
991 trailing spaces are ignored by converting to '\0'. A space
992 between "NaN" and the optional perenthesis is not permitted. */
993 while (w > 0)
994 {
995 *out = safe_tolower (*p);
996 switch (*p)
997 {
998 case ' ':
999 if (dtp->u.p.blank_status == BLANK_ZERO)
1000 {
1001 *out = '0';
1002 break;
1003 }
1004 *out = '\0';
1005 if (seen_paren == 1)
1006 goto bad_float;
1007 break;
1008 case '(':
1009 seen_paren++;
1010 *out = '\0';
1011 break;
1012 case ')':
1013 if (seen_paren++ != 1)
1014 goto bad_float;
1015 break;
1016 default:
1017 if (!safe_isalnum (*out))
1018 goto bad_float;
1019 }
1020 --w;
1021 ++p;
1022 ++out;
1023 }
1024
1025 *out = '\0';
1026
1027 if (seen_paren != 0 && seen_paren != 2)
1028 goto bad_float;
1029
1030 if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
1031 {
1032 if (seen_paren)
1033 goto bad_float;
1034 }
1035 else if (strcmp (save, "nan") != 0)
1036 goto bad_float;
1037
1038 convert_infnan (dtp, dest, buffer, length);
1039 if (buf_size > READF_TMP)
1040 free (buffer);
1041 return;
1042 }
1043
1044 /* Process the mantissa string. */
1045 while (w > 0)
1046 {
1047 switch (*p)
1048 {
1049 case ',':
1050 if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
1051 goto bad_float;
1052 /* Fall through. */
1053 case '.':
1054 if (seen_dp)
1055 goto bad_float;
1056 if (!seen_int_digit)
1057 *(out++) = '0';
1058 *(out++) = '.';
1059 seen_dp = 1;
1060 break;
1061
1062 case ' ':
1063 if (dtp->u.p.blank_status == BLANK_ZERO)
1064 {
1065 *(out++) = '0';
1066 goto found_digit;
1067 }
1068 else if (dtp->u.p.blank_status == BLANK_NULL)
1069 break;
1070 else
1071 /* TODO: Should we check instead that there are only trailing
1072 blanks here, as is done below for exponents? */
1073 goto done;
1074 /* Fall through. */
1075 case '0':
1076 case '1':
1077 case '2':
1078 case '3':
1079 case '4':
1080 case '5':
1081 case '6':
1082 case '7':
1083 case '8':
1084 case '9':
1085 *(out++) = *p;
1086 found_digit:
1087 if (!seen_dp)
1088 seen_int_digit = 1;
1089 else
1090 seen_dec_digit = 1;
1091 break;
1092
1093 case '-':
1094 case '+':
1095 goto exponent;
1096
1097 case 'e':
1098 case 'E':
1099 case 'd':
1100 case 'D':
1101 case 'q':
1102 case 'Q':
1103 ++p;
1104 --w;
1105 goto exponent;
1106
1107 default:
1108 goto bad_float;
1109 }
1110
1111 ++p;
1112 --w;
1113 }
1114
1115 /* No exponent has been seen, so we use the current scale factor. */
1116 exponent = - dtp->u.p.scale_factor;
1117 goto done;
1118
1119 /* At this point the start of an exponent has been found. */
1120 exponent:
1121 p = eat_leading_spaces (&w, (char*) p);
1122 if (*p == '-' || *p == '+')
1123 {
1124 if (*p == '-')
1125 exponent_sign = -1;
1126 ++p;
1127 --w;
1128 }
1129
1130 /* At this point a digit string is required. We calculate the value
1131 of the exponent in order to take account of the scale factor and
1132 the d parameter before explict conversion takes place. */
1133
1134 if (w == 0)
1135 {
1136 /* Extension: allow default exponent of 0 when omitted. */
1137 if (dtp->common.flags & IOPARM_DT_DEC_EXT)
1138 goto done;
1139 else
1140 goto bad_float;
1141 }
1142
1143 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
1144 {
1145 while (w > 0 && safe_isdigit (*p))
1146 {
1147 exponent *= 10;
1148 exponent += *p - '0';
1149 ++p;
1150 --w;
1151 }
1152
1153 /* Only allow trailing blanks. */
1154 while (w > 0)
1155 {
1156 if (*p != ' ')
1157 goto bad_float;
1158 ++p;
1159 --w;
1160 }
1161 }
1162 else /* BZ or BN status is enabled. */
1163 {
1164 while (w > 0)
1165 {
1166 if (*p == ' ')
1167 {
1168 if (dtp->u.p.blank_status == BLANK_ZERO)
1169 exponent *= 10;
1170 else
1171 assert (dtp->u.p.blank_status == BLANK_NULL);
1172 }
1173 else if (!safe_isdigit (*p))
1174 goto bad_float;
1175 else
1176 {
1177 exponent *= 10;
1178 exponent += *p - '0';
1179 }
1180
1181 ++p;
1182 --w;
1183 }
1184 }
1185
1186 exponent *= exponent_sign;
1187
1188 done:
1189 /* Use the precision specified in the format if no decimal point has been
1190 seen. */
1191 if (!seen_dp)
1192 exponent -= f->u.real.d;
1193
1194 /* Output a trailing '0' after decimal point if not yet found. */
1195 if (seen_dp && !seen_dec_digit)
1196 *(out++) = '0';
1197 /* Handle input of style "E+NN" by inserting a 0 for the
1198 significand. */
1199 else if (!seen_int_digit && !seen_dec_digit)
1200 {
1201 notify_std (&dtp->common, GFC_STD_LEGACY,
1202 "REAL input of style 'E+NN'");
1203 *(out++) = '0';
1204 }
1205
1206 /* Print out the exponent to finish the reformatted number. Maximum 4
1207 digits for the exponent. */
1208 if (exponent != 0)
1209 {
1210 int dig;
1211
1212 *(out++) = 'e';
1213 if (exponent < 0)
1214 {
1215 *(out++) = '-';
1216 exponent = - exponent;
1217 }
1218
1219 if (exponent >= 10000)
1220 goto bad_float;
1221
1222 for (dig = 3; dig >= 0; --dig)
1223 {
1224 out[dig] = (char) ('0' + exponent % 10);
1225 exponent /= 10;
1226 }
1227 out += 4;
1228 }
1229 *(out++) = '\0';
1230
1231 /* Do the actual conversion. */
1232 convert_real (dtp, dest, buffer, length);
1233 if (buf_size > READF_TMP)
1234 free (buffer);
1235 return;
1236
1237 /* The value read is zero. */
1238 zero:
1239 switch (length)
1240 {
1241 case 4:
1242 *((GFC_REAL_4 *) dest) = 0.0;
1243 break;
1244
1245 case 8:
1246 *((GFC_REAL_8 *) dest) = 0.0;
1247 break;
1248
1249 #ifdef HAVE_GFC_REAL_10
1250 case 10:
1251 *((GFC_REAL_10 *) dest) = 0.0;
1252 break;
1253 #endif
1254
1255 #ifdef HAVE_GFC_REAL_16
1256 case 16:
1257 *((GFC_REAL_16 *) dest) = 0.0;
1258 break;
1259 #endif
1260
1261 #ifdef HAVE_GFC_REAL_17
1262 case 17:
1263 *((GFC_REAL_17 *) dest) = 0.0;
1264 break;
1265 #endif
1266
1267 default:
1268 internal_error (&dtp->common, "Unsupported real kind during IO");
1269 }
1270 return;
1271
1272 bad_float:
1273 if (buf_size > READF_TMP)
1274 free (buffer);
1275 generate_error (&dtp->common, LIBERROR_READ_VALUE,
1276 "Bad value during floating point read");
1277 next_record (dtp, 1);
1278 return;
1279 }
1280
1281
1282 /* read_x()-- Deal with the X/TR descriptor. We just read some data
1283 and never look at it. */
1284
1285 void
read_x(st_parameter_dt * dtp,size_t n)1286 read_x (st_parameter_dt *dtp, size_t n)
1287 {
1288 size_t length;
1289 int q, q2;
1290
1291 if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
1292 && dtp->u.p.current_unit->bytes_left < (gfc_offset) n)
1293 n = dtp->u.p.current_unit->bytes_left;
1294
1295 if (n == 0)
1296 return;
1297
1298 length = n;
1299
1300 if (is_internal_unit (dtp))
1301 {
1302 mem_alloc_r (dtp->u.p.current_unit->s, &length);
1303 if (unlikely (length < n))
1304 n = length;
1305 goto done;
1306 }
1307
1308 if (dtp->u.p.sf_seen_eor)
1309 return;
1310
1311 n = 0;
1312 while (n < length)
1313 {
1314 q = fbuf_getc (dtp->u.p.current_unit);
1315 if (q == EOF)
1316 break;
1317 else if (dtp->u.p.current_unit->flags.cc != CC_NONE
1318 && (q == '\n' || q == '\r'))
1319 {
1320 /* Unexpected end of line. Set the position. */
1321 dtp->u.p.sf_seen_eor = 1;
1322
1323 /* If we see an EOR during non-advancing I/O, we need to skip
1324 the rest of the I/O statement. Set the corresponding flag. */
1325 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
1326 dtp->u.p.eor_condition = 1;
1327
1328 /* If we encounter a CR, it might be a CRLF. */
1329 if (q == '\r') /* Probably a CRLF */
1330 {
1331 /* See if there is an LF. */
1332 q2 = fbuf_getc (dtp->u.p.current_unit);
1333 if (q2 == '\n')
1334 dtp->u.p.sf_seen_eor = 2;
1335 else if (q2 != EOF) /* Oops, seek back. */
1336 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
1337 }
1338 goto done;
1339 }
1340 n++;
1341 }
1342
1343 done:
1344 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
1345 dtp->u.p.current_unit->has_size)
1346 dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
1347 dtp->u.p.current_unit->bytes_left -= n;
1348 dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
1349 }
1350
1351