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) && defined (HAVE_STRTOLD)
167 *((GFC_REAL_16
*) dest
) = gfc_strtold (buffer
, NULL
);
172 internal_error (&dtp
->common
, "Unsupported real kind during IO");
177 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
178 "Error during floating point read");
179 next_record (dtp
, 1);
187 /* read_l()-- Read a logical value */
190 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
197 p
= read_block_form (dtp
, &w
);
220 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
224 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
228 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
229 "Bad value on logical read");
230 next_record (dtp
, 1);
237 read_utf8 (st_parameter_dt
*dtp
, int *nbytes
)
239 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
240 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
247 s
= read_block_form (dtp
, nbytes
);
251 /* If this is a short read, just return. */
259 /* The number of leading 1-bits in the first byte indicates how many
261 for (nb
= 2; nb
< 7; nb
++)
262 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
267 c
= (c
& masks
[nb
-1]);
270 s
= read_block_form (dtp
, &nread
);
273 /* Decode the bytes read. */
274 for (i
= 1; i
< nb
; i
++)
276 gfc_char4_t n
= *s
++;
278 if ((n
& 0xC0) != 0x80)
281 c
= ((c
<< 6) + (n
& 0x3F));
284 /* Make sure the shortest possible encoding was used. */
285 if (c
<= 0x7F && nb
> 1) goto invalid
;
286 if (c
<= 0x7FF && nb
> 2) goto invalid
;
287 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
288 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
289 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
291 /* Make sure the character is valid. */
292 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
298 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
299 return (gfc_char4_t
) '?';
304 read_utf8_char1 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
311 len
= (width
< len
) ? len
: width
;
315 /* Proceed with decoding one character at a time. */
316 for (j
= 0; j
< len
; j
++, dest
++)
318 c
= read_utf8 (dtp
, &nbytes
);
320 /* Check for a short read and if so, break out. */
324 *dest
= c
> 255 ? '?' : (uchar
) c
;
327 /* If there was a short read, pad the remaining characters. */
328 for (i
= j
; i
< len
; i
++)
334 read_default_char1 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
339 s
= read_block_form (dtp
, &width
);
346 m
= (width
> len
) ? len
: width
;
351 memset (p
+ m
, ' ', n
);
356 read_utf8_char4 (st_parameter_dt
*dtp
, void *p
, int len
, int width
)
362 len
= (width
< len
) ? len
: width
;
364 dest
= (gfc_char4_t
*) p
;
366 /* Proceed with decoding one character at a time. */
367 for (j
= 0; j
< len
; j
++, dest
++)
369 *dest
= read_utf8 (dtp
, &nbytes
);
371 /* Check for a short read and if so, break out. */
376 /* If there was a short read, pad the remaining characters. */
377 for (i
= j
; i
< len
; i
++)
378 *dest
++ = (gfc_char4_t
) ' ';
384 read_default_char4 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
389 if (is_char4_unit(dtp
))
393 s4
= (gfc_char4_t
*) read_block_form4 (dtp
, &width
);
400 m
= ((int) width
> len
) ? len
: (int) width
;
402 dest
= (gfc_char4_t
*) p
;
404 for (n
= 0; n
< m
; n
++)
407 for (n
= 0; n
< len
- (int) width
; n
++)
408 *dest
++ = (gfc_char4_t
) ' ';
414 s
= read_block_form (dtp
, &width
);
421 m
= ((int) width
> len
) ? len
: (int) width
;
423 dest
= (gfc_char4_t
*) p
;
425 for (n
= 0; n
< m
; n
++, dest
++, s
++)
426 *dest
= (unsigned char ) *s
;
428 for (n
= 0; n
< len
- (int) width
; n
++, dest
++)
429 *dest
= (unsigned char) ' ';
434 /* read_a()-- Read a character record into a KIND=1 character destination,
435 processing UTF-8 encoding if necessary. */
438 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
444 if (wi
== -1) /* '(A)' edit descriptor */
448 /* Read in w characters, treating comma as not a separator. */
449 dtp
->u
.p
.sf_read_comma
= 0;
451 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
452 read_utf8_char1 (dtp
, p
, length
, w
);
454 read_default_char1 (dtp
, p
, length
, w
);
456 dtp
->u
.p
.sf_read_comma
=
457 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
461 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
462 processing UTF-8 encoding if necessary. */
465 read_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
470 if (w
== -1) /* '(A)' edit descriptor */
473 /* Read in w characters, treating comma as not a separator. */
474 dtp
->u
.p
.sf_read_comma
= 0;
476 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
477 read_utf8_char4 (dtp
, p
, length
, w
);
479 read_default_char4 (dtp
, p
, length
, w
);
481 dtp
->u
.p
.sf_read_comma
=
482 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
485 /* eat_leading_spaces()-- Given a character pointer and a width,
486 * ignore the leading spaces. */
489 eat_leading_spaces (int *width
, char *p
)
493 if (*width
== 0 || *p
!= ' ')
505 next_char (st_parameter_dt
*dtp
, char **p
, int *w
)
520 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
521 return ' '; /* return a blank to signal a null */
523 /* At this point, the rest of the field has to be trailing blanks */
537 /* read_decimal()-- Read a decimal integer value. The values here are
541 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
543 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
544 GFC_INTEGER_LARGEST v
;
550 p
= read_block_form (dtp
, &w
);
555 p
= eat_leading_spaces (&w
, p
);
558 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
562 maxv
= max_value (length
, 1);
584 /* At this point we have a digit-string */
589 c
= next_char (dtp
, &p
, &w
);
595 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
596 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
599 if (c
< '0' || c
> '9')
602 if (value
> maxv_10
&& compile_options
.range_check
== 1)
608 if (value
> maxv
- c
&& compile_options
.range_check
== 1)
617 set_integer (dest
, v
, length
);
621 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
622 "Bad value during integer read");
623 next_record (dtp
, 1);
627 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
628 "Value overflowed during integer read");
629 next_record (dtp
, 1);
634 /* read_radix()-- This function reads values for non-decimal radixes.
635 * The difference here is that we treat the values here as unsigned
636 * values for the purposes of overflow. If minus sign is present and
637 * the top bit is set, the value will be incorrect. */
640 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
643 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
644 GFC_INTEGER_LARGEST v
;
650 p
= read_block_form (dtp
, &w
);
655 p
= eat_leading_spaces (&w
, p
);
658 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
662 maxv
= max_value (length
, 0);
663 maxv_r
= maxv
/ radix
;
684 /* At this point we have a digit-string */
689 c
= next_char (dtp
, &p
, &w
);
694 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
695 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
701 if (c
< '0' || c
> '1')
706 if (c
< '0' || c
> '7')
731 c
= c
- 'a' + '9' + 1;
740 c
= c
- 'A' + '9' + 1;
754 value
= radix
* value
;
756 if (maxv
- c
< value
)
765 set_integer (dest
, v
, length
);
769 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
770 "Bad value during integer read");
771 next_record (dtp
, 1);
775 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
776 "Value overflowed during integer read");
777 next_record (dtp
, 1);
782 /* read_f()-- Read a floating point number with F-style editing, which
783 is what all of the other floating point descriptors behave as. The
784 tricky part is that optional spaces are allowed after an E or D,
785 and the implicit decimal point if a decimal point is not present in
789 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
791 int w
, seen_dp
, exponent
;
796 int seen_int_digit
; /* Seen a digit before the decimal point? */
797 int seen_dec_digit
; /* Seen a digit after the decimal point? */
806 /* Read in the next block. */
807 p
= read_block_form (dtp
, &w
);
810 p
= eat_leading_spaces (&w
, (char*) p
);
814 /* In this buffer we're going to re-format the number cleanly to be parsed
815 by convert_real in the end; this assures we're using strtod from the
816 C library for parsing and thus probably get the best accuracy possible.
817 This process may add a '+0.0' in front of the number as well as change the
818 exponent because of an implicit decimal point or the like. Thus allocating
819 strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
820 original buffer had should be enough. */
821 buffer
= gfc_alloca (w
+ 11);
825 if (*p
== '-' || *p
== '+')
833 p
= eat_leading_spaces (&w
, (char*) p
);
837 /* Check for Infinity or NaN. */
838 if (unlikely ((w
>= 3 && (*p
== 'i' || *p
== 'I' || *p
== 'n' || *p
== 'N'))))
843 /* Scan through the buffer keeping track of spaces and parenthesis. We
844 null terminate the string as soon as we see a left paren or if we are
845 BLANK_NULL mode. Leading spaces have already been skipped above,
846 trailing spaces are ignored by converting to '\0'. A space
847 between "NaN" and the optional perenthesis is not permitted. */
854 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
868 if (seen_paren
++ != 1)
882 if (seen_paren
!= 0 && seen_paren
!= 2)
885 if ((strcmp (save
, "inf") == 0) || (strcmp (save
, "infinity") == 0))
890 else if (strcmp (save
, "nan") != 0)
893 convert_real (dtp
, dest
, buffer
, length
);
897 /* Process the mantissa string. */
903 if (dtp
->u
.p
.current_unit
->decimal_status
!= DECIMAL_COMMA
)
916 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
921 else if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
924 /* TODO: Should we check instead that there are only trailing
925 blanks here, as is done below for exponents? */
966 /* No exponent has been seen, so we use the current scale factor. */
967 exponent
= - dtp
->u
.p
.scale_factor
;
970 /* At this point the start of an exponent has been found. */
972 p
= eat_leading_spaces (&w
, (char*) p
);
973 if (*p
== '-' || *p
== '+')
981 /* At this point a digit string is required. We calculate the value
982 of the exponent in order to take account of the scale factor and
983 the d parameter before explict conversion takes place. */
988 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
990 while (w
> 0 && isdigit (*p
))
993 exponent
+= *p
- '0';
998 /* Only allow trailing blanks. */
1007 else /* BZ or BN status is enabled. */
1013 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
1016 assert (dtp
->u
.p
.blank_status
== BLANK_NULL
);
1018 else if (!isdigit (*p
))
1023 exponent
+= *p
- '0';
1031 exponent
*= exponent_sign
;
1034 /* Use the precision specified in the format if no decimal point has been
1037 exponent
-= f
->u
.real
.d
;
1039 /* Output a trailing '0' after decimal point if not yet found. */
1040 if (seen_dp
&& !seen_dec_digit
)
1043 /* Print out the exponent to finish the reformatted number. Maximum 4
1044 digits for the exponent. */
1053 exponent
= - exponent
;
1056 assert (exponent
< 10000);
1057 for (dig
= 3; dig
>= 0; --dig
)
1059 out
[dig
] = (char) ('0' + exponent
% 10);
1066 /* Do the actual conversion. */
1067 convert_real (dtp
, dest
, buffer
, length
);
1071 /* The value read is zero. */
1076 *((GFC_REAL_4
*) dest
) = 0.0;
1080 *((GFC_REAL_8
*) dest
) = 0.0;
1083 #ifdef HAVE_GFC_REAL_10
1085 *((GFC_REAL_10
*) dest
) = 0.0;
1089 #ifdef HAVE_GFC_REAL_16
1091 *((GFC_REAL_16
*) dest
) = 0.0;
1096 internal_error (&dtp
->common
, "Unsupported real kind during IO");
1101 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
1102 "Bad value during floating point read");
1103 next_record (dtp
, 1);
1108 /* read_x()-- Deal with the X/TR descriptor. We just read some data
1109 * and never look at it. */
1112 read_x (st_parameter_dt
*dtp
, int n
)
1117 if ((dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
|| is_internal_unit (dtp
))
1118 && dtp
->u
.p
.current_unit
->bytes_left
< n
)
1119 n
= dtp
->u
.p
.current_unit
->bytes_left
;
1126 if (is_internal_unit (dtp
))
1128 p
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1129 if (unlikely (length
< n
))
1134 if (dtp
->u
.p
.sf_seen_eor
)
1137 p
= fbuf_read (dtp
->u
.p
.current_unit
, &length
);
1144 if (length
== 0 && dtp
->u
.p
.item_count
== 1)
1146 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
1159 if (q
== '\n' || q
== '\r')
1161 /* Unexpected end of line. Set the position. */
1162 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ 1 ,SEEK_CUR
);
1163 dtp
->u
.p
.sf_seen_eor
= 1;
1165 /* If we encounter a CR, it might be a CRLF. */
1166 if (q
== '\r') /* Probably a CRLF */
1168 /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
1169 the position is not advanced unless it really is an LF. */
1171 p
= fbuf_read (dtp
->u
.p
.current_unit
, &readlen
);
1172 if (*p
== '\n' && readlen
== 1)
1174 dtp
->u
.p
.sf_seen_eor
= 2;
1175 fbuf_seek (dtp
->u
.p
.current_unit
, 1 ,SEEK_CUR
);
1184 fbuf_seek (dtp
->u
.p
.current_unit
, n
, SEEK_CUR
);
1187 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
1188 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
1189 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
1190 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;