1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
37 typedef unsigned char uchar
;
39 /* read.c -- Deal with formatted reads */
42 /* set_integer()-- All of the integer assignments come here to
43 actually place the value into memory. */
46 set_integer (void *dest
, GFC_INTEGER_LARGEST value
, int length
)
50 #ifdef HAVE_GFC_INTEGER_16
51 /* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
55 GFC_INTEGER_16 tmp
= value
;
56 memcpy (dest
, (void *) &tmp
, length
);
62 GFC_INTEGER_8 tmp
= value
;
63 memcpy (dest
, (void *) &tmp
, length
);
68 GFC_INTEGER_4 tmp
= value
;
69 memcpy (dest
, (void *) &tmp
, length
);
74 GFC_INTEGER_2 tmp
= value
;
75 memcpy (dest
, (void *) &tmp
, length
);
80 GFC_INTEGER_1 tmp
= value
;
81 memcpy (dest
, (void *) &tmp
, length
);
85 internal_error (NULL
, "Bad integer kind");
90 /* max_value()-- Given a length (kind), return the maximum signed or
94 max_value (int length
, int signed_flag
)
96 GFC_UINTEGER_LARGEST value
;
97 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
103 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
107 for (n
= 1; n
< 4 * length
; n
++)
108 value
= (value
<< 2) + 3;
114 value
= signed_flag
? 0x7fffffffffffffff : 0xffffffffffffffff;
117 value
= signed_flag
? 0x7fffffff : 0xffffffff;
120 value
= signed_flag
? 0x7fff : 0xffff;
123 value
= signed_flag
? 0x7f : 0xff;
126 internal_error (NULL
, "Bad integer kind");
133 /* convert_real()-- Convert a character representation of a floating
134 point number to the machine number. Returns nonzero if there is a
135 range problem during conversion. Note: many architectures
136 (e.g. IA-64, HP-PA) require that the storage pointed to by the dest
137 argument is properly aligned for the type in question. */
140 convert_real (st_parameter_dt
*dtp
, void *dest
, const char *buffer
, int length
)
147 *((GFC_REAL_4
*) dest
) =
148 #if defined(HAVE_STRTOF)
149 gfc_strtof (buffer
, NULL
);
151 (GFC_REAL_4
) gfc_strtod (buffer
, NULL
);
156 *((GFC_REAL_8
*) dest
) = gfc_strtod (buffer
, NULL
);
159 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
161 *((GFC_REAL_10
*) dest
) = gfc_strtold (buffer
, NULL
);
165 #if defined(HAVE_GFC_REAL_16)
166 # if defined(GFC_REAL_16_IS_FLOAT128)
168 *((GFC_REAL_16
*) dest
) = __qmath_(strtoflt128
) (buffer
, NULL
);
170 # elif defined(HAVE_STRTOLD)
172 *((GFC_REAL_16
*) dest
) = gfc_strtold (buffer
, NULL
);
178 internal_error (&dtp
->common
, "Unsupported real kind during IO");
183 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
184 "Error during floating point read");
185 next_record (dtp
, 1);
192 /* convert_infnan()-- Convert character INF/NAN representation to the
193 machine number. Note: many architectures (e.g. IA-64, HP-PA) require
194 that the storage pointed to by the dest argument is properly aligned
195 for the type in question. */
198 convert_infnan (st_parameter_dt
*dtp
, void *dest
, const char *buffer
,
201 const char *s
= buffer
;
202 int is_inf
, plus
= 1;
218 *((GFC_REAL_4
*) dest
) = plus
? __builtin_inff () : -__builtin_inff ();
220 *((GFC_REAL_4
*) dest
) = plus
? __builtin_nanf ("") : -__builtin_nanf ("");
225 *((GFC_REAL_8
*) dest
) = plus
? __builtin_inf () : -__builtin_inf ();
227 *((GFC_REAL_8
*) dest
) = plus
? __builtin_nan ("") : -__builtin_nan ("");
230 #if defined(HAVE_GFC_REAL_10)
233 *((GFC_REAL_10
*) dest
) = plus
? __builtin_infl () : -__builtin_infl ();
235 *((GFC_REAL_10
*) dest
) = plus
? __builtin_nanl ("") : -__builtin_nanl ("");
239 #if defined(HAVE_GFC_REAL_16)
240 # if defined(GFC_REAL_16_IS_FLOAT128)
242 *((GFC_REAL_16
*) dest
) = __qmath_(strtoflt128
) (buffer
, NULL
);
247 *((GFC_REAL_16
*) dest
) = plus
? __builtin_infl () : -__builtin_infl ();
249 *((GFC_REAL_16
*) dest
) = plus
? __builtin_nanl ("") : -__builtin_nanl ("");
255 internal_error (&dtp
->common
, "Unsupported real kind during IO");
262 /* read_l()-- Read a logical value */
265 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
272 p
= read_block_form (dtp
, &w
);
295 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
299 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
303 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
304 "Bad value on logical read");
305 next_record (dtp
, 1);
312 read_utf8 (st_parameter_dt
*dtp
, int *nbytes
)
314 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
315 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
322 s
= read_block_form (dtp
, nbytes
);
326 /* If this is a short read, just return. */
334 /* The number of leading 1-bits in the first byte indicates how many
336 for (nb
= 2; nb
< 7; nb
++)
337 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
342 c
= (c
& masks
[nb
-1]);
345 s
= read_block_form (dtp
, &nread
);
348 /* Decode the bytes read. */
349 for (i
= 1; i
< nb
; i
++)
351 gfc_char4_t n
= *s
++;
353 if ((n
& 0xC0) != 0x80)
356 c
= ((c
<< 6) + (n
& 0x3F));
359 /* Make sure the shortest possible encoding was used. */
360 if (c
<= 0x7F && nb
> 1) goto invalid
;
361 if (c
<= 0x7FF && nb
> 2) goto invalid
;
362 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
363 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
364 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
366 /* Make sure the character is valid. */
367 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
373 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
374 return (gfc_char4_t
) '?';
379 read_utf8_char1 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
386 len
= (width
< len
) ? len
: width
;
390 /* Proceed with decoding one character at a time. */
391 for (j
= 0; j
< len
; j
++, dest
++)
393 c
= read_utf8 (dtp
, &nbytes
);
395 /* Check for a short read and if so, break out. */
399 *dest
= c
> 255 ? '?' : (uchar
) c
;
402 /* If there was a short read, pad the remaining characters. */
403 for (i
= j
; i
< len
; i
++)
409 read_default_char1 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
414 s
= read_block_form (dtp
, &width
);
421 m
= (width
> len
) ? len
: width
;
426 memset (p
+ m
, ' ', n
);
431 read_utf8_char4 (st_parameter_dt
*dtp
, void *p
, int len
, int width
)
437 len
= (width
< len
) ? len
: width
;
439 dest
= (gfc_char4_t
*) p
;
441 /* Proceed with decoding one character at a time. */
442 for (j
= 0; j
< len
; j
++, dest
++)
444 *dest
= read_utf8 (dtp
, &nbytes
);
446 /* Check for a short read and if so, break out. */
451 /* If there was a short read, pad the remaining characters. */
452 for (i
= j
; i
< len
; i
++)
453 *dest
++ = (gfc_char4_t
) ' ';
459 read_default_char4 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
464 if (is_char4_unit(dtp
))
468 s4
= (gfc_char4_t
*) read_block_form4 (dtp
, &width
);
475 m
= ((int) width
> len
) ? len
: (int) width
;
477 dest
= (gfc_char4_t
*) p
;
479 for (n
= 0; n
< m
; n
++)
482 for (n
= 0; n
< len
- (int) width
; n
++)
483 *dest
++ = (gfc_char4_t
) ' ';
489 s
= read_block_form (dtp
, &width
);
496 m
= ((int) width
> len
) ? len
: (int) width
;
498 dest
= (gfc_char4_t
*) p
;
500 for (n
= 0; n
< m
; n
++, dest
++, s
++)
501 *dest
= (unsigned char ) *s
;
503 for (n
= 0; n
< len
- (int) width
; n
++, dest
++)
504 *dest
= (unsigned char) ' ';
509 /* read_a()-- Read a character record into a KIND=1 character destination,
510 processing UTF-8 encoding if necessary. */
513 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
519 if (wi
== -1) /* '(A)' edit descriptor */
523 /* Read in w characters, treating comma as not a separator. */
524 dtp
->u
.p
.sf_read_comma
= 0;
526 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
527 read_utf8_char1 (dtp
, p
, length
, w
);
529 read_default_char1 (dtp
, p
, length
, w
);
531 dtp
->u
.p
.sf_read_comma
=
532 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
536 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
537 processing UTF-8 encoding if necessary. */
540 read_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
545 if (w
== -1) /* '(A)' edit descriptor */
548 /* Read in w characters, treating comma as not a separator. */
549 dtp
->u
.p
.sf_read_comma
= 0;
551 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
552 read_utf8_char4 (dtp
, p
, length
, w
);
554 read_default_char4 (dtp
, p
, length
, w
);
556 dtp
->u
.p
.sf_read_comma
=
557 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
560 /* eat_leading_spaces()-- Given a character pointer and a width,
561 * ignore the leading spaces. */
564 eat_leading_spaces (int *width
, char *p
)
568 if (*width
== 0 || *p
!= ' ')
580 next_char (st_parameter_dt
*dtp
, char **p
, int *w
)
595 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
596 return ' '; /* return a blank to signal a null */
598 /* At this point, the rest of the field has to be trailing blanks */
612 /* read_decimal()-- Read a decimal integer value. The values here are
616 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
618 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
619 GFC_INTEGER_LARGEST v
;
625 p
= read_block_form (dtp
, &w
);
630 p
= eat_leading_spaces (&w
, p
);
633 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
637 maxv
= max_value (length
, 1);
659 /* At this point we have a digit-string */
664 c
= next_char (dtp
, &p
, &w
);
670 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
671 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
674 if (c
< '0' || c
> '9')
677 if (value
> maxv_10
&& compile_options
.range_check
== 1)
683 if (value
> maxv
- c
&& compile_options
.range_check
== 1)
692 set_integer (dest
, v
, length
);
696 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
697 "Bad value during integer read");
698 next_record (dtp
, 1);
702 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
703 "Value overflowed during integer read");
704 next_record (dtp
, 1);
709 /* read_radix()-- This function reads values for non-decimal radixes.
710 * The difference here is that we treat the values here as unsigned
711 * values for the purposes of overflow. If minus sign is present and
712 * the top bit is set, the value will be incorrect. */
715 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
718 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
719 GFC_INTEGER_LARGEST v
;
725 p
= read_block_form (dtp
, &w
);
730 p
= eat_leading_spaces (&w
, p
);
733 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
737 maxv
= max_value (length
, 0);
738 maxv_r
= maxv
/ radix
;
759 /* At this point we have a digit-string */
764 c
= next_char (dtp
, &p
, &w
);
769 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
770 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
776 if (c
< '0' || c
> '1')
781 if (c
< '0' || c
> '7')
806 c
= c
- 'a' + '9' + 1;
815 c
= c
- 'A' + '9' + 1;
829 value
= radix
* value
;
831 if (maxv
- c
< value
)
840 set_integer (dest
, v
, length
);
844 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
845 "Bad value during integer read");
846 next_record (dtp
, 1);
850 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
851 "Value overflowed during integer read");
852 next_record (dtp
, 1);
857 /* read_f()-- Read a floating point number with F-style editing, which
858 is what all of the other floating point descriptors behave as. The
859 tricky part is that optional spaces are allowed after an E or D,
860 and the implicit decimal point if a decimal point is not present in
864 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
866 int w
, seen_dp
, exponent
;
871 int seen_int_digit
; /* Seen a digit before the decimal point? */
872 int seen_dec_digit
; /* Seen a digit after the decimal point? */
881 /* Read in the next block. */
882 p
= read_block_form (dtp
, &w
);
885 p
= eat_leading_spaces (&w
, (char*) p
);
889 /* In this buffer we're going to re-format the number cleanly to be parsed
890 by convert_real in the end; this assures we're using strtod from the
891 C library for parsing and thus probably get the best accuracy possible.
892 This process may add a '+0.0' in front of the number as well as change the
893 exponent because of an implicit decimal point or the like. Thus allocating
894 strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
895 original buffer had should be enough. */
896 buffer
= gfc_alloca (w
+ 11);
900 if (*p
== '-' || *p
== '+')
908 p
= eat_leading_spaces (&w
, (char*) p
);
912 /* Check for Infinity or NaN. */
913 if (unlikely ((w
>= 3 && (*p
== 'i' || *p
== 'I' || *p
== 'n' || *p
== 'N'))))
918 /* Scan through the buffer keeping track of spaces and parenthesis. We
919 null terminate the string as soon as we see a left paren or if we are
920 BLANK_NULL mode. Leading spaces have already been skipped above,
921 trailing spaces are ignored by converting to '\0'. A space
922 between "NaN" and the optional perenthesis is not permitted. */
929 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
943 if (seen_paren
++ != 1)
957 if (seen_paren
!= 0 && seen_paren
!= 2)
960 if ((strcmp (save
, "inf") == 0) || (strcmp (save
, "infinity") == 0))
965 else if (strcmp (save
, "nan") != 0)
968 convert_infnan (dtp
, dest
, buffer
, length
);
972 /* Process the mantissa string. */
978 if (dtp
->u
.p
.current_unit
->decimal_status
!= DECIMAL_COMMA
)
991 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
996 else if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
999 /* TODO: Should we check instead that there are only trailing
1000 blanks here, as is done below for exponents? */
1041 /* No exponent has been seen, so we use the current scale factor. */
1042 exponent
= - dtp
->u
.p
.scale_factor
;
1045 /* At this point the start of an exponent has been found. */
1047 p
= eat_leading_spaces (&w
, (char*) p
);
1048 if (*p
== '-' || *p
== '+')
1056 /* At this point a digit string is required. We calculate the value
1057 of the exponent in order to take account of the scale factor and
1058 the d parameter before explict conversion takes place. */
1063 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
1065 while (w
> 0 && isdigit (*p
))
1068 exponent
+= *p
- '0';
1073 /* Only allow trailing blanks. */
1082 else /* BZ or BN status is enabled. */
1088 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
1091 assert (dtp
->u
.p
.blank_status
== BLANK_NULL
);
1093 else if (!isdigit (*p
))
1098 exponent
+= *p
- '0';
1106 exponent
*= exponent_sign
;
1109 /* Use the precision specified in the format if no decimal point has been
1112 exponent
-= f
->u
.real
.d
;
1114 /* Output a trailing '0' after decimal point if not yet found. */
1115 if (seen_dp
&& !seen_dec_digit
)
1118 /* Print out the exponent to finish the reformatted number. Maximum 4
1119 digits for the exponent. */
1128 exponent
= - exponent
;
1131 assert (exponent
< 10000);
1132 for (dig
= 3; dig
>= 0; --dig
)
1134 out
[dig
] = (char) ('0' + exponent
% 10);
1141 /* Do the actual conversion. */
1142 convert_real (dtp
, dest
, buffer
, length
);
1146 /* The value read is zero. */
1151 *((GFC_REAL_4
*) dest
) = 0.0;
1155 *((GFC_REAL_8
*) dest
) = 0.0;
1158 #ifdef HAVE_GFC_REAL_10
1160 *((GFC_REAL_10
*) dest
) = 0.0;
1164 #ifdef HAVE_GFC_REAL_16
1166 *((GFC_REAL_16
*) dest
) = 0.0;
1171 internal_error (&dtp
->common
, "Unsupported real kind during IO");
1176 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
1177 "Bad value during floating point read");
1178 next_record (dtp
, 1);
1183 /* read_x()-- Deal with the X/TR descriptor. We just read some data
1184 * and never look at it. */
1187 read_x (st_parameter_dt
*dtp
, int n
)
1191 if ((dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
|| is_internal_unit (dtp
))
1192 && dtp
->u
.p
.current_unit
->bytes_left
< n
)
1193 n
= dtp
->u
.p
.current_unit
->bytes_left
;
1200 if (is_internal_unit (dtp
))
1202 mem_alloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1203 if (unlikely (length
< n
))
1208 if (dtp
->u
.p
.sf_seen_eor
)
1214 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
1217 else if (q
== '\n' || q
== '\r')
1219 /* Unexpected end of line. Set the position. */
1220 dtp
->u
.p
.sf_seen_eor
= 1;
1222 /* If we see an EOR during non-advancing I/O, we need to skip
1223 the rest of the I/O statement. Set the corresponding flag. */
1224 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
1225 dtp
->u
.p
.eor_condition
= 1;
1227 /* If we encounter a CR, it might be a CRLF. */
1228 if (q
== '\r') /* Probably a CRLF */
1230 /* See if there is an LF. */
1231 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
1233 dtp
->u
.p
.sf_seen_eor
= 2;
1234 else if (q2
!= EOF
) /* Oops, seek back. */
1235 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
1243 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
1244 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
1245 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
1246 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;