1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
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)
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.
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.
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/>. */
34 typedef unsigned char uchar
;
36 /* read.c -- Deal with formatted reads */
39 /* set_integer()-- All of the integer assignments come here to
40 actually place the value into memory. */
43 set_integer (void *dest
, GFC_INTEGER_LARGEST value
, int length
)
47 #ifdef HAVE_GFC_INTEGER_16
48 /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
52 GFC_INTEGER_16 tmp
= value
;
53 memcpy (dest
, (void *) &tmp
, length
);
59 GFC_INTEGER_8 tmp
= value
;
60 memcpy (dest
, (void *) &tmp
, length
);
65 GFC_INTEGER_4 tmp
= value
;
66 memcpy (dest
, (void *) &tmp
, length
);
71 GFC_INTEGER_2 tmp
= value
;
72 memcpy (dest
, (void *) &tmp
, length
);
77 GFC_INTEGER_1 tmp
= value
;
78 memcpy (dest
, (void *) &tmp
, length
);
82 internal_error (NULL
, "Bad integer kind");
87 /* Max signed value of size give by length argument. */
92 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
93 GFC_UINTEGER_LARGEST value
;
98 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
102 for (int n
= 1; n
< 4 * length
; n
++)
103 value
= (value
<< 2) + 3;
107 return GFC_INTEGER_8_HUGE
;
109 return GFC_INTEGER_4_HUGE
;
111 return GFC_INTEGER_2_HUGE
;
113 return GFC_INTEGER_1_HUGE
;
115 internal_error (NULL
, "Bad integer kind");
120 /* convert_real()-- Convert a character representation of a floating
121 point number to the machine number. Returns nonzero if there is an
122 invalid input. Note: many architectures (e.g. IA-64, HP-PA)
123 require that the storage pointed to by the dest argument is
124 properly aligned for the type in question. */
127 convert_real (st_parameter_dt
*dtp
, void *dest
, const char *buffer
, int length
)
130 int round_mode
, old_round_mode
;
132 switch (dtp
->u
.p
.current_unit
->round_status
)
134 case ROUND_COMPATIBLE
:
135 /* FIXME: As NEAREST but round away from zero for a tie. */
136 case ROUND_UNSPECIFIED
:
137 /* Should not occur. */
138 case ROUND_PROCDEFINED
:
139 round_mode
= ROUND_NEAREST
;
142 round_mode
= dtp
->u
.p
.current_unit
->round_status
;
146 old_round_mode
= get_fpu_rounding_mode();
147 set_fpu_rounding_mode (round_mode
);
152 *((GFC_REAL_4
*) dest
) =
153 #if defined(HAVE_STRTOF)
154 gfc_strtof (buffer
, &endptr
);
156 (GFC_REAL_4
) gfc_strtod (buffer
, &endptr
);
161 *((GFC_REAL_8
*) dest
) = gfc_strtod (buffer
, &endptr
);
164 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
166 *((GFC_REAL_10
*) dest
) = gfc_strtold (buffer
, &endptr
);
170 #if defined(HAVE_GFC_REAL_16)
171 # if defined(GFC_REAL_16_IS_FLOAT128)
173 *((GFC_REAL_16
*) dest
) = __qmath_(strtoflt128
) (buffer
, &endptr
);
175 # elif defined(HAVE_STRTOLD)
177 *((GFC_REAL_16
*) dest
) = gfc_strtold (buffer
, &endptr
);
183 internal_error (&dtp
->common
, "Unsupported real kind during IO");
186 set_fpu_rounding_mode (old_round_mode
);
188 if (buffer
== endptr
)
190 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
191 "Error during floating point read");
192 next_record (dtp
, 1);
199 /* convert_infnan()-- Convert character INF/NAN representation to the
200 machine number. Note: many architectures (e.g. IA-64, HP-PA) require
201 that the storage pointed to by the dest argument is properly aligned
202 for the type in question. */
205 convert_infnan (st_parameter_dt
*dtp
, void *dest
, const char *buffer
,
208 const char *s
= buffer
;
209 int is_inf
, plus
= 1;
225 *((GFC_REAL_4
*) dest
) = plus
? __builtin_inff () : -__builtin_inff ();
227 *((GFC_REAL_4
*) dest
) = plus
? __builtin_nanf ("") : -__builtin_nanf ("");
232 *((GFC_REAL_8
*) dest
) = plus
? __builtin_inf () : -__builtin_inf ();
234 *((GFC_REAL_8
*) dest
) = plus
? __builtin_nan ("") : -__builtin_nan ("");
237 #if defined(HAVE_GFC_REAL_10)
240 *((GFC_REAL_10
*) dest
) = plus
? __builtin_infl () : -__builtin_infl ();
242 *((GFC_REAL_10
*) dest
) = plus
? __builtin_nanl ("") : -__builtin_nanl ("");
246 #if defined(HAVE_GFC_REAL_16)
247 # if defined(GFC_REAL_16_IS_FLOAT128)
249 *((GFC_REAL_16
*) dest
) = __qmath_(strtoflt128
) (buffer
, NULL
);
254 *((GFC_REAL_16
*) dest
) = plus
? __builtin_infl () : -__builtin_infl ();
256 *((GFC_REAL_16
*) dest
) = plus
? __builtin_nanl ("") : -__builtin_nanl ("");
262 internal_error (&dtp
->common
, "Unsupported real kind during IO");
269 /* read_l()-- Read a logical value */
272 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
279 p
= read_block_form (dtp
, &w
);
302 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
306 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
310 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
311 "Bad value on logical read");
312 next_record (dtp
, 1);
319 read_utf8 (st_parameter_dt
*dtp
, size_t *nbytes
)
321 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
322 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
329 s
= read_block_form (dtp
, nbytes
);
333 /* If this is a short read, just return. */
341 /* The number of leading 1-bits in the first byte indicates how many
343 for (nb
= 2; nb
< 7; nb
++)
344 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
349 c
= (c
& masks
[nb
-1]);
352 s
= read_block_form (dtp
, &nread
);
355 /* Decode the bytes read. */
356 for (size_t i
= 1; i
< nb
; i
++)
358 gfc_char4_t n
= *s
++;
360 if ((n
& 0xC0) != 0x80)
363 c
= ((c
<< 6) + (n
& 0x3F));
366 /* Make sure the shortest possible encoding was used. */
367 if (c
<= 0x7F && nb
> 1) goto invalid
;
368 if (c
<= 0x7FF && nb
> 2) goto invalid
;
369 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
370 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
371 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
373 /* Make sure the character is valid. */
374 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
380 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
381 return (gfc_char4_t
) '?';
386 read_utf8_char1 (st_parameter_dt
*dtp
, char *p
, size_t len
, size_t width
)
392 len
= (width
< len
) ? len
: width
;
396 /* Proceed with decoding one character at a time. */
397 for (j
= 0; j
< len
; j
++, dest
++)
399 c
= read_utf8 (dtp
, &nbytes
);
401 /* Check for a short read and if so, break out. */
405 *dest
= c
> 255 ? '?' : (uchar
) c
;
408 /* If there was a short read, pad the remaining characters. */
409 for (size_t i
= j
; i
< len
; i
++)
415 read_default_char1 (st_parameter_dt
*dtp
, char *p
, size_t len
, size_t width
)
420 s
= read_block_form (dtp
, &width
);
427 m
= (width
> len
) ? len
: width
;
431 memset (p
+ m
, ' ', len
- width
);
436 read_utf8_char4 (st_parameter_dt
*dtp
, void *p
, size_t len
, size_t width
)
441 len
= (width
< len
) ? len
: width
;
443 dest
= (gfc_char4_t
*) p
;
445 /* Proceed with decoding one character at a time. */
446 for (j
= 0; j
< len
; j
++, dest
++)
448 *dest
= read_utf8 (dtp
, &nbytes
);
450 /* Check for a short read and if so, break out. */
455 /* If there was a short read, pad the remaining characters. */
456 for (size_t i
= j
; i
< len
; i
++)
457 *dest
++ = (gfc_char4_t
) ' ';
463 read_default_char4 (st_parameter_dt
*dtp
, char *p
, size_t len
, size_t width
)
468 if (is_char4_unit(dtp
))
472 s4
= (gfc_char4_t
*) read_block_form4 (dtp
, &width
);
479 m
= (width
> len
) ? len
: width
;
481 dest
= (gfc_char4_t
*) p
;
483 for (n
= 0; n
< m
; n
++)
488 for (n
= 0; n
< len
- width
; n
++)
489 *dest
++ = (gfc_char4_t
) ' ';
496 s
= read_block_form (dtp
, &width
);
503 m
= (width
> len
) ? len
: width
;
505 dest
= (gfc_char4_t
*) p
;
507 for (n
= 0; n
< m
; n
++, dest
++, s
++)
508 *dest
= (unsigned char ) *s
;
512 for (n
= 0; n
< len
- width
; n
++, dest
++)
513 *dest
= (unsigned char) ' ';
519 /* read_a()-- Read a character record into a KIND=1 character destination,
520 processing UTF-8 encoding if necessary. */
523 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, size_t length
)
527 if (f
->u
.w
== -1) /* '(A)' edit descriptor */
532 /* Read in w characters, treating comma as not a separator. */
533 dtp
->u
.p
.sf_read_comma
= 0;
535 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
536 read_utf8_char1 (dtp
, p
, length
, w
);
538 read_default_char1 (dtp
, p
, length
, w
);
540 dtp
->u
.p
.sf_read_comma
=
541 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
545 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
546 processing UTF-8 encoding if necessary. */
549 read_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, size_t length
)
553 if (f
->u
.w
== -1) /* '(A)' edit descriptor */
558 /* Read in w characters, treating comma as not a separator. */
559 dtp
->u
.p
.sf_read_comma
= 0;
561 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
562 read_utf8_char4 (dtp
, p
, length
, w
);
564 read_default_char4 (dtp
, p
, length
, w
);
566 dtp
->u
.p
.sf_read_comma
=
567 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
570 /* eat_leading_spaces()-- Given a character pointer and a width,
571 ignore the leading spaces. */
574 eat_leading_spaces (size_t *width
, char *p
)
578 if (*width
== 0 || *p
!= ' ')
590 next_char (st_parameter_dt
*dtp
, char **p
, size_t *w
)
605 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
606 return ' '; /* return a blank to signal a null */
608 /* At this point, the rest of the field has to be trailing blanks */
622 /* read_decimal()-- Read a decimal integer value. The values here are
626 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
628 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
629 GFC_INTEGER_LARGEST v
;
636 p
= read_block_form (dtp
, &w
);
641 p
= eat_leading_spaces (&w
, p
);
644 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
666 maxv
= si_max (length
);
671 /* At this point we have a digit-string */
676 c
= next_char (dtp
, &p
, &w
);
682 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
685 for ( ; w
> 0; p
++, w
--)
686 if (*p
!= ' ') break;
689 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
692 if (c
< '0' || c
> '9')
701 if (value
> maxv
- c
)
711 set_integer (dest
, v
, length
);
715 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
716 "Bad value during integer read");
717 next_record (dtp
, 1);
721 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
722 "Value overflowed during integer read");
723 next_record (dtp
, 1);
728 /* read_radix()-- This function reads values for non-decimal radixes.
729 The difference here is that we treat the values here as unsigned
730 values for the purposes of overflow. If minus sign is present and
731 the top bit is set, the value will be incorrect. */
734 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
737 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
738 GFC_INTEGER_LARGEST v
;
745 p
= read_block_form (dtp
, &w
);
750 p
= eat_leading_spaces (&w
, p
);
753 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
757 /* Maximum unsigned value, assuming two's complement. */
758 maxv
= 2 * si_max (length
) + 1;
759 maxv_r
= maxv
/ radix
;
780 /* At this point we have a digit-string */
785 c
= next_char (dtp
, &p
, &w
);
790 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
791 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
797 if (c
< '0' || c
> '1')
802 if (c
< '0' || c
> '7')
827 c
= c
- 'a' + '9' + 1;
836 c
= c
- 'A' + '9' + 1;
850 value
= radix
* value
;
852 if (maxv
- c
< value
)
861 set_integer (dest
, v
, length
);
865 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
866 "Bad value during integer read");
867 next_record (dtp
, 1);
871 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
872 "Value overflowed during integer read");
873 next_record (dtp
, 1);
878 /* read_f()-- Read a floating point number with F-style editing, which
879 is what all of the other floating point descriptors behave as. The
880 tricky part is that optional spaces are allowed after an E or D,
881 and the implicit decimal point if a decimal point is not present in
885 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
891 int seen_dp
, exponent
;
896 int seen_int_digit
; /* Seen a digit before the decimal point? */
897 int seen_dec_digit
; /* Seen a digit after the decimal point? */
907 /* Read in the next block. */
908 p
= read_block_form (dtp
, &w
);
911 p
= eat_leading_spaces (&w
, (char*) p
);
915 /* In this buffer we're going to re-format the number cleanly to be parsed
916 by convert_real in the end; this assures we're using strtod from the
917 C library for parsing and thus probably get the best accuracy possible.
918 This process may add a '+0.0' in front of the number as well as change the
919 exponent because of an implicit decimal point or the like. Thus allocating
920 strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
921 original buffer had should be enough. */
923 if (buf_size
> READF_TMP
)
924 buffer
= xmalloc (buf_size
);
929 if (*p
== '-' || *p
== '+')
937 p
= eat_leading_spaces (&w
, (char*) p
);
941 /* Check for Infinity or NaN. */
942 if (unlikely ((w
>= 3 && (*p
== 'i' || *p
== 'I' || *p
== 'n' || *p
== 'N'))))
947 /* Scan through the buffer keeping track of spaces and parenthesis. We
948 null terminate the string as soon as we see a left paren or if we are
949 BLANK_NULL mode. Leading spaces have already been skipped above,
950 trailing spaces are ignored by converting to '\0'. A space
951 between "NaN" and the optional perenthesis is not permitted. */
958 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
972 if (seen_paren
++ != 1)
986 if (seen_paren
!= 0 && seen_paren
!= 2)
989 if ((strcmp (save
, "inf") == 0) || (strcmp (save
, "infinity") == 0))
994 else if (strcmp (save
, "nan") != 0)
997 convert_infnan (dtp
, dest
, buffer
, length
);
998 if (buf_size
> READF_TMP
)
1003 /* Process the mantissa string. */
1009 if (dtp
->u
.p
.current_unit
->decimal_status
!= DECIMAL_COMMA
)
1015 if (!seen_int_digit
)
1022 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
1027 else if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
1030 /* TODO: Should we check instead that there are only trailing
1031 blanks here, as is done below for exponents? */
1074 /* No exponent has been seen, so we use the current scale factor. */
1075 exponent
= - dtp
->u
.p
.scale_factor
;
1078 /* At this point the start of an exponent has been found. */
1080 p
= eat_leading_spaces (&w
, (char*) p
);
1081 if (*p
== '-' || *p
== '+')
1089 /* At this point a digit string is required. We calculate the value
1090 of the exponent in order to take account of the scale factor and
1091 the d parameter before explict conversion takes place. */
1095 /* Extension: allow default exponent of 0 when omitted. */
1096 if (dtp
->common
.flags
& IOPARM_DT_DEC_EXT
)
1102 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
1104 while (w
> 0 && isdigit (*p
))
1107 exponent
+= *p
- '0';
1112 /* Only allow trailing blanks. */
1121 else /* BZ or BN status is enabled. */
1127 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
1130 assert (dtp
->u
.p
.blank_status
== BLANK_NULL
);
1132 else if (!isdigit (*p
))
1137 exponent
+= *p
- '0';
1145 exponent
*= exponent_sign
;
1148 /* Use the precision specified in the format if no decimal point has been
1151 exponent
-= f
->u
.real
.d
;
1153 /* Output a trailing '0' after decimal point if not yet found. */
1154 if (seen_dp
&& !seen_dec_digit
)
1156 /* Handle input of style "E+NN" by inserting a 0 for the
1158 else if (!seen_int_digit
&& !seen_dec_digit
)
1160 notify_std (&dtp
->common
, GFC_STD_LEGACY
,
1161 "REAL input of style 'E+NN'");
1165 /* Print out the exponent to finish the reformatted number. Maximum 4
1166 digits for the exponent. */
1175 exponent
= - exponent
;
1178 if (exponent
>= 10000)
1181 for (dig
= 3; dig
>= 0; --dig
)
1183 out
[dig
] = (char) ('0' + exponent
% 10);
1190 /* Do the actual conversion. */
1191 convert_real (dtp
, dest
, buffer
, length
);
1192 if (buf_size
> READF_TMP
)
1196 /* The value read is zero. */
1201 *((GFC_REAL_4
*) dest
) = 0.0;
1205 *((GFC_REAL_8
*) dest
) = 0.0;
1208 #ifdef HAVE_GFC_REAL_10
1210 *((GFC_REAL_10
*) dest
) = 0.0;
1214 #ifdef HAVE_GFC_REAL_16
1216 *((GFC_REAL_16
*) dest
) = 0.0;
1221 internal_error (&dtp
->common
, "Unsupported real kind during IO");
1226 if (buf_size
> READF_TMP
)
1228 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
1229 "Bad value during floating point read");
1230 next_record (dtp
, 1);
1235 /* read_x()-- Deal with the X/TR descriptor. We just read some data
1236 and never look at it. */
1239 read_x (st_parameter_dt
*dtp
, size_t n
)
1244 if ((dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
|| is_internal_unit (dtp
))
1245 && dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) n
)
1246 n
= dtp
->u
.p
.current_unit
->bytes_left
;
1253 if (is_internal_unit (dtp
))
1255 mem_alloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1256 if (unlikely (length
< n
))
1261 if (dtp
->u
.p
.sf_seen_eor
)
1267 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
1270 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
1271 && (q
== '\n' || q
== '\r'))
1273 /* Unexpected end of line. Set the position. */
1274 dtp
->u
.p
.sf_seen_eor
= 1;
1276 /* If we see an EOR during non-advancing I/O, we need to skip
1277 the rest of the I/O statement. Set the corresponding flag. */
1278 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
1279 dtp
->u
.p
.eor_condition
= 1;
1281 /* If we encounter a CR, it might be a CRLF. */
1282 if (q
== '\r') /* Probably a CRLF */
1284 /* See if there is an LF. */
1285 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
1287 dtp
->u
.p
.sf_seen_eor
= 2;
1288 else if (q2
!= EOF
) /* Oops, seek back. */
1289 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
1297 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
1298 dtp
->u
.p
.current_unit
->has_size
)
1299 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
1300 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
1301 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;