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/>. */
35 typedef unsigned char uchar
;
37 /* read.c -- Deal with formatted reads */
40 /* set_integer()-- All of the integer assignments come here to
41 actually place the value into memory. */
44 set_integer (void *dest
, GFC_INTEGER_LARGEST value
, int length
)
46 NOTE ("set_integer: %lld %p", (long long int) value
, dest
);
49 #ifdef HAVE_GFC_INTEGER_16
50 /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
54 GFC_INTEGER_16 tmp
= value
;
55 memcpy (dest
, (void *) &tmp
, length
);
61 GFC_INTEGER_8 tmp
= value
;
62 memcpy (dest
, (void *) &tmp
, length
);
67 GFC_INTEGER_4 tmp
= value
;
68 memcpy (dest
, (void *) &tmp
, length
);
73 GFC_INTEGER_2 tmp
= value
;
74 memcpy (dest
, (void *) &tmp
, length
);
79 GFC_INTEGER_1 tmp
= value
;
80 memcpy (dest
, (void *) &tmp
, length
);
84 internal_error (NULL
, "Bad integer kind");
89 /* Max signed value of size give by length argument. */
94 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
95 GFC_UINTEGER_LARGEST value
;
100 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
104 for (int n
= 1; n
< 4 * length
; n
++)
105 value
= (value
<< 2) + 3;
109 return GFC_INTEGER_8_HUGE
;
111 return GFC_INTEGER_4_HUGE
;
113 return GFC_INTEGER_2_HUGE
;
115 return GFC_INTEGER_1_HUGE
;
117 internal_error (NULL
, "Bad integer kind");
122 /* convert_real()-- Convert a character representation of a floating
123 point number to the machine number. Returns nonzero if there is an
124 invalid input. Note: many architectures (e.g. IA-64, HP-PA)
125 require that the storage pointed to by the dest argument is
126 properly aligned for the type in question. */
129 convert_real (st_parameter_dt
*dtp
, void *dest
, const char *buffer
, int length
)
132 int round_mode
, old_round_mode
;
134 switch (dtp
->u
.p
.current_unit
->round_status
)
136 case ROUND_COMPATIBLE
:
137 /* FIXME: As NEAREST but round away from zero for a tie. */
138 case ROUND_UNSPECIFIED
:
139 /* Should not occur. */
140 case ROUND_PROCDEFINED
:
141 round_mode
= ROUND_NEAREST
;
144 round_mode
= dtp
->u
.p
.current_unit
->round_status
;
148 old_round_mode
= get_fpu_rounding_mode();
149 set_fpu_rounding_mode (round_mode
);
154 *((GFC_REAL_4
*) dest
) =
155 #if defined(HAVE_STRTOF)
156 gfc_strtof (buffer
, &endptr
);
158 (GFC_REAL_4
) gfc_strtod (buffer
, &endptr
);
163 *((GFC_REAL_8
*) dest
) = gfc_strtod (buffer
, &endptr
);
166 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
168 *((GFC_REAL_10
*) dest
) = gfc_strtold (buffer
, &endptr
);
172 #if defined(HAVE_GFC_REAL_16)
173 # if defined(GFC_REAL_16_IS_FLOAT128)
175 *((GFC_REAL_16
*) dest
) = __qmath_(strtoflt128
) (buffer
, &endptr
);
177 # elif defined(HAVE_STRTOLD)
179 *((GFC_REAL_16
*) dest
) = gfc_strtold (buffer
, &endptr
);
185 internal_error (&dtp
->common
, "Unsupported real kind during IO");
188 set_fpu_rounding_mode (old_round_mode
);
190 if (buffer
== endptr
)
192 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
193 "Error during floating point read");
194 next_record (dtp
, 1);
201 /* convert_infnan()-- Convert character INF/NAN representation to the
202 machine number. Note: many architectures (e.g. IA-64, HP-PA) require
203 that the storage pointed to by the dest argument is properly aligned
204 for the type in question. */
207 convert_infnan (st_parameter_dt
*dtp
, void *dest
, const char *buffer
,
210 const char *s
= buffer
;
211 int is_inf
, plus
= 1;
227 *((GFC_REAL_4
*) dest
) = plus
? __builtin_inff () : -__builtin_inff ();
229 *((GFC_REAL_4
*) dest
) = plus
? __builtin_nanf ("") : -__builtin_nanf ("");
234 *((GFC_REAL_8
*) dest
) = plus
? __builtin_inf () : -__builtin_inf ();
236 *((GFC_REAL_8
*) dest
) = plus
? __builtin_nan ("") : -__builtin_nan ("");
239 #if defined(HAVE_GFC_REAL_10)
242 *((GFC_REAL_10
*) dest
) = plus
? __builtin_infl () : -__builtin_infl ();
244 *((GFC_REAL_10
*) dest
) = plus
? __builtin_nanl ("") : -__builtin_nanl ("");
248 #if defined(HAVE_GFC_REAL_16)
249 # if defined(GFC_REAL_16_IS_FLOAT128)
251 *((GFC_REAL_16
*) dest
) = __qmath_(strtoflt128
) (buffer
, NULL
);
256 *((GFC_REAL_16
*) dest
) = plus
? __builtin_infl () : -__builtin_infl ();
258 *((GFC_REAL_16
*) dest
) = plus
? __builtin_nanl ("") : -__builtin_nanl ("");
264 internal_error (&dtp
->common
, "Unsupported real kind during IO");
271 /* read_l()-- Read a logical value */
274 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
281 p
= read_block_form (dtp
, &w
);
304 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
308 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
312 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
313 "Bad value on logical read");
314 next_record (dtp
, 1);
321 read_utf8 (st_parameter_dt
*dtp
, size_t *nbytes
)
323 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
324 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
331 s
= read_block_form (dtp
, nbytes
);
335 /* If this is a short read, just return. */
343 /* The number of leading 1-bits in the first byte indicates how many
345 for (nb
= 2; nb
< 7; nb
++)
346 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
351 c
= (c
& masks
[nb
-1]);
354 s
= read_block_form (dtp
, &nread
);
357 /* Decode the bytes read. */
358 for (size_t i
= 1; i
< nb
; i
++)
360 gfc_char4_t n
= *s
++;
362 if ((n
& 0xC0) != 0x80)
365 c
= ((c
<< 6) + (n
& 0x3F));
368 /* Make sure the shortest possible encoding was used. */
369 if (c
<= 0x7F && nb
> 1) goto invalid
;
370 if (c
<= 0x7FF && nb
> 2) goto invalid
;
371 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
372 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
373 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
375 /* Make sure the character is valid. */
376 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
382 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
383 return (gfc_char4_t
) '?';
388 read_utf8_char1 (st_parameter_dt
*dtp
, char *p
, size_t len
, size_t width
)
394 len
= (width
< len
) ? len
: width
;
398 /* Proceed with decoding one character at a time. */
399 for (j
= 0; j
< len
; j
++, dest
++)
401 c
= read_utf8 (dtp
, &nbytes
);
403 /* Check for a short read and if so, break out. */
407 *dest
= c
> 255 ? '?' : (uchar
) c
;
410 /* If there was a short read, pad the remaining characters. */
411 for (size_t i
= j
; i
< len
; i
++)
417 read_default_char1 (st_parameter_dt
*dtp
, char *p
, size_t len
, size_t width
)
422 s
= read_block_form (dtp
, &width
);
429 m
= (width
> len
) ? len
: width
;
433 memset (p
+ m
, ' ', len
- width
);
438 read_utf8_char4 (st_parameter_dt
*dtp
, void *p
, size_t len
, size_t width
)
443 len
= (width
< len
) ? len
: width
;
445 dest
= (gfc_char4_t
*) p
;
447 /* Proceed with decoding one character at a time. */
448 for (j
= 0; j
< len
; j
++, dest
++)
450 *dest
= read_utf8 (dtp
, &nbytes
);
452 /* Check for a short read and if so, break out. */
457 /* If there was a short read, pad the remaining characters. */
458 for (size_t i
= j
; i
< len
; i
++)
459 *dest
++ = (gfc_char4_t
) ' ';
465 read_default_char4 (st_parameter_dt
*dtp
, char *p
, size_t len
, size_t width
)
470 if (is_char4_unit(dtp
))
474 s4
= (gfc_char4_t
*) read_block_form4 (dtp
, &width
);
481 m
= (width
> len
) ? len
: width
;
483 dest
= (gfc_char4_t
*) p
;
485 for (n
= 0; n
< m
; n
++)
490 for (n
= 0; n
< len
- width
; n
++)
491 *dest
++ = (gfc_char4_t
) ' ';
498 s
= read_block_form (dtp
, &width
);
505 m
= (width
> len
) ? len
: width
;
507 dest
= (gfc_char4_t
*) p
;
509 for (n
= 0; n
< m
; n
++, dest
++, s
++)
510 *dest
= (unsigned char ) *s
;
514 for (n
= 0; n
< len
- width
; n
++, dest
++)
515 *dest
= (unsigned char) ' ';
521 /* read_a()-- Read a character record into a KIND=1 character destination,
522 processing UTF-8 encoding if necessary. */
525 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, size_t length
)
529 if (f
->u
.w
== -1) /* '(A)' edit descriptor */
534 /* Read in w characters, treating comma as not a separator. */
535 dtp
->u
.p
.sf_read_comma
= 0;
537 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
538 read_utf8_char1 (dtp
, p
, length
, w
);
540 read_default_char1 (dtp
, p
, length
, w
);
542 dtp
->u
.p
.sf_read_comma
=
543 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
547 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
548 processing UTF-8 encoding if necessary. */
551 read_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, size_t length
)
555 if (f
->u
.w
== -1) /* '(A)' edit descriptor */
560 /* Read in w characters, treating comma as not a separator. */
561 dtp
->u
.p
.sf_read_comma
= 0;
563 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
564 read_utf8_char4 (dtp
, p
, length
, w
);
566 read_default_char4 (dtp
, p
, length
, w
);
568 dtp
->u
.p
.sf_read_comma
=
569 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
572 /* eat_leading_spaces()-- Given a character pointer and a width,
573 ignore the leading spaces. */
576 eat_leading_spaces (size_t *width
, char *p
)
580 if (*width
== 0 || *p
!= ' ')
592 next_char (st_parameter_dt
*dtp
, char **p
, size_t *w
)
607 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
608 return ' '; /* return a blank to signal a null */
610 /* At this point, the rest of the field has to be trailing blanks */
624 /* read_decimal()-- Read a decimal integer value. The values here are
628 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
630 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
631 GFC_INTEGER_LARGEST v
;
638 p
= read_block_form (dtp
, &w
);
643 p
= eat_leading_spaces (&w
, p
);
646 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
668 maxv
= si_max (length
);
673 /* At this point we have a digit-string */
678 c
= next_char (dtp
, &p
, &w
);
684 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
687 for ( ; w
> 0; p
++, w
--)
688 if (*p
!= ' ') break;
691 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
694 if (c
< '0' || c
> '9')
703 if (value
> maxv
- c
)
713 set_integer (dest
, v
, length
);
717 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
718 "Bad value during integer read");
719 next_record (dtp
, 1);
723 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
724 "Value overflowed during integer read");
725 next_record (dtp
, 1);
730 /* read_radix()-- This function reads values for non-decimal radixes.
731 The difference here is that we treat the values here as unsigned
732 values for the purposes of overflow. If minus sign is present and
733 the top bit is set, the value will be incorrect. */
736 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
739 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
740 GFC_INTEGER_LARGEST v
;
747 p
= read_block_form (dtp
, &w
);
752 p
= eat_leading_spaces (&w
, p
);
755 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
759 /* Maximum unsigned value, assuming two's complement. */
760 maxv
= 2 * si_max (length
) + 1;
761 maxv_r
= maxv
/ radix
;
782 /* At this point we have a digit-string */
787 c
= next_char (dtp
, &p
, &w
);
792 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
793 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
799 if (c
< '0' || c
> '1')
804 if (c
< '0' || c
> '7')
829 c
= c
- 'a' + '9' + 1;
838 c
= c
- 'A' + '9' + 1;
852 value
= radix
* value
;
854 if (maxv
- c
< value
)
863 set_integer (dest
, v
, length
);
867 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
868 "Bad value during integer read");
869 next_record (dtp
, 1);
873 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
874 "Value overflowed during integer read");
875 next_record (dtp
, 1);
880 /* read_f()-- Read a floating point number with F-style editing, which
881 is what all of the other floating point descriptors behave as. The
882 tricky part is that optional spaces are allowed after an E or D,
883 and the implicit decimal point if a decimal point is not present in
887 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
893 int seen_dp
, exponent
;
898 int seen_int_digit
; /* Seen a digit before the decimal point? */
899 int seen_dec_digit
; /* Seen a digit after the decimal point? */
909 /* Read in the next block. */
910 p
= read_block_form (dtp
, &w
);
913 p
= eat_leading_spaces (&w
, (char*) p
);
917 /* In this buffer we're going to re-format the number cleanly to be parsed
918 by convert_real in the end; this assures we're using strtod from the
919 C library for parsing and thus probably get the best accuracy possible.
920 This process may add a '+0.0' in front of the number as well as change the
921 exponent because of an implicit decimal point or the like. Thus allocating
922 strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
923 original buffer had should be enough. */
925 if (buf_size
> READF_TMP
)
926 buffer
= xmalloc (buf_size
);
931 if (*p
== '-' || *p
== '+')
939 p
= eat_leading_spaces (&w
, (char*) p
);
943 /* Check for Infinity or NaN. */
944 if (unlikely ((w
>= 3 && (*p
== 'i' || *p
== 'I' || *p
== 'n' || *p
== 'N'))))
949 /* Scan through the buffer keeping track of spaces and parenthesis. We
950 null terminate the string as soon as we see a left paren or if we are
951 BLANK_NULL mode. Leading spaces have already been skipped above,
952 trailing spaces are ignored by converting to '\0'. A space
953 between "NaN" and the optional perenthesis is not permitted. */
960 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
974 if (seen_paren
++ != 1)
988 if (seen_paren
!= 0 && seen_paren
!= 2)
991 if ((strcmp (save
, "inf") == 0) || (strcmp (save
, "infinity") == 0))
996 else if (strcmp (save
, "nan") != 0)
999 convert_infnan (dtp
, dest
, buffer
, length
);
1000 if (buf_size
> READF_TMP
)
1005 /* Process the mantissa string. */
1011 if (dtp
->u
.p
.current_unit
->decimal_status
!= DECIMAL_COMMA
)
1017 if (!seen_int_digit
)
1024 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
1029 else if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
1032 /* TODO: Should we check instead that there are only trailing
1033 blanks here, as is done below for exponents? */
1076 /* No exponent has been seen, so we use the current scale factor. */
1077 exponent
= - dtp
->u
.p
.scale_factor
;
1080 /* At this point the start of an exponent has been found. */
1082 p
= eat_leading_spaces (&w
, (char*) p
);
1083 if (*p
== '-' || *p
== '+')
1091 /* At this point a digit string is required. We calculate the value
1092 of the exponent in order to take account of the scale factor and
1093 the d parameter before explict conversion takes place. */
1097 /* Extension: allow default exponent of 0 when omitted. */
1098 if (dtp
->common
.flags
& IOPARM_DT_DEC_EXT
)
1104 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
1106 while (w
> 0 && isdigit (*p
))
1109 exponent
+= *p
- '0';
1114 /* Only allow trailing blanks. */
1123 else /* BZ or BN status is enabled. */
1129 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
1132 assert (dtp
->u
.p
.blank_status
== BLANK_NULL
);
1134 else if (!isdigit (*p
))
1139 exponent
+= *p
- '0';
1147 exponent
*= exponent_sign
;
1150 /* Use the precision specified in the format if no decimal point has been
1153 exponent
-= f
->u
.real
.d
;
1155 /* Output a trailing '0' after decimal point if not yet found. */
1156 if (seen_dp
&& !seen_dec_digit
)
1158 /* Handle input of style "E+NN" by inserting a 0 for the
1160 else if (!seen_int_digit
&& !seen_dec_digit
)
1162 notify_std (&dtp
->common
, GFC_STD_LEGACY
,
1163 "REAL input of style 'E+NN'");
1167 /* Print out the exponent to finish the reformatted number. Maximum 4
1168 digits for the exponent. */
1177 exponent
= - exponent
;
1180 if (exponent
>= 10000)
1183 for (dig
= 3; dig
>= 0; --dig
)
1185 out
[dig
] = (char) ('0' + exponent
% 10);
1192 /* Do the actual conversion. */
1193 convert_real (dtp
, dest
, buffer
, length
);
1194 if (buf_size
> READF_TMP
)
1198 /* The value read is zero. */
1203 *((GFC_REAL_4
*) dest
) = 0.0;
1207 *((GFC_REAL_8
*) dest
) = 0.0;
1210 #ifdef HAVE_GFC_REAL_10
1212 *((GFC_REAL_10
*) dest
) = 0.0;
1216 #ifdef HAVE_GFC_REAL_16
1218 *((GFC_REAL_16
*) dest
) = 0.0;
1223 internal_error (&dtp
->common
, "Unsupported real kind during IO");
1228 if (buf_size
> READF_TMP
)
1230 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
1231 "Bad value during floating point read");
1232 next_record (dtp
, 1);
1237 /* read_x()-- Deal with the X/TR descriptor. We just read some data
1238 and never look at it. */
1241 read_x (st_parameter_dt
*dtp
, size_t n
)
1246 if ((dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
|| is_internal_unit (dtp
))
1247 && dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) n
)
1248 n
= dtp
->u
.p
.current_unit
->bytes_left
;
1255 if (is_internal_unit (dtp
))
1257 mem_alloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1258 if (unlikely (length
< n
))
1263 if (dtp
->u
.p
.sf_seen_eor
)
1269 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
1272 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
1273 && (q
== '\n' || q
== '\r'))
1275 /* Unexpected end of line. Set the position. */
1276 dtp
->u
.p
.sf_seen_eor
= 1;
1278 /* If we see an EOR during non-advancing I/O, we need to skip
1279 the rest of the I/O statement. Set the corresponding flag. */
1280 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
1281 dtp
->u
.p
.eor_condition
= 1;
1283 /* If we encounter a CR, it might be a CRLF. */
1284 if (q
== '\r') /* Probably a CRLF */
1286 /* See if there is an LF. */
1287 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
1289 dtp
->u
.p
.sf_seen_eor
= 2;
1290 else if (q2
!= EOF
) /* Oops, seek back. */
1291 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
1299 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
1300 dtp
->u
.p
.current_unit
->has_size
)
1301 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
1302 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
1303 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;