1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009 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 95 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_value()-- Given a length (kind), return the maximum signed or
91 max_value (int length
, int signed_flag
)
93 GFC_UINTEGER_LARGEST value
;
94 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
100 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
104 for (n
= 1; n
< 4 * length
; n
++)
105 value
= (value
<< 2) + 3;
111 value
= signed_flag
? 0x7fffffffffffffff : 0xffffffffffffffff;
114 value
= signed_flag
? 0x7fffffff : 0xffffffff;
117 value
= signed_flag
? 0x7fff : 0xffff;
120 value
= signed_flag
? 0x7f : 0xff;
123 internal_error (NULL
, "Bad integer kind");
130 /* convert_real()-- Convert a character representation of a floating
131 * point number to the machine number. Returns nonzero if there is a
132 * range problem during conversion. Note: many architectures
133 * (e.g. IA-64, HP-PA) require that the storage pointed to by the dest
134 * argument is properly aligned for the type in question. TODO:
135 * handle not-a-numbers and infinities. */
138 convert_real (st_parameter_dt
*dtp
, void *dest
, const char *buffer
, int length
)
145 *((GFC_REAL_4
*) dest
) =
146 #if defined(HAVE_STRTOF)
147 strtof (buffer
, NULL
);
149 (GFC_REAL_4
) strtod (buffer
, NULL
);
154 *((GFC_REAL_8
*) dest
) = strtod (buffer
, NULL
);
157 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
159 *((GFC_REAL_10
*) dest
) = strtold (buffer
, NULL
);
163 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
165 *((GFC_REAL_16
*) dest
) = strtold (buffer
, NULL
);
170 internal_error (&dtp
->common
, "Unsupported real kind during IO");
175 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
176 "Error during floating point read");
177 next_record (dtp
, 1);
185 /* read_l()-- Read a logical value */
188 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
195 p
= read_block_form (dtp
, &w
);
218 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
222 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
226 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
227 "Bad value on logical read");
228 next_record (dtp
, 1);
235 read_utf8 (st_parameter_dt
*dtp
, int *nbytes
)
237 static const uchar masks
[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
238 static const uchar patns
[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
245 s
= read_block_form (dtp
, nbytes
);
249 /* If this is a short read, just return. */
257 /* The number of leading 1-bits in the first byte indicates how many
259 for (nb
= 2; nb
< 7; nb
++)
260 if ((c
& ~masks
[nb
-1]) == patns
[nb
-1])
265 c
= (c
& masks
[nb
-1]);
268 s
= read_block_form (dtp
, &nread
);
271 /* Decode the bytes read. */
272 for (i
= 1; i
< nb
; i
++)
274 gfc_char4_t n
= *s
++;
276 if ((n
& 0xC0) != 0x80)
279 c
= ((c
<< 6) + (n
& 0x3F));
282 /* Make sure the shortest possible encoding was used. */
283 if (c
<= 0x7F && nb
> 1) goto invalid
;
284 if (c
<= 0x7FF && nb
> 2) goto invalid
;
285 if (c
<= 0xFFFF && nb
> 3) goto invalid
;
286 if (c
<= 0x1FFFFF && nb
> 4) goto invalid
;
287 if (c
<= 0x3FFFFFF && nb
> 5) goto invalid
;
289 /* Make sure the character is valid. */
290 if (c
> 0x7FFFFFFF || (c
>= 0xD800 && c
<= 0xDFFF))
296 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
, "Invalid UTF-8 encoding");
297 return (gfc_char4_t
) '?';
302 read_utf8_char1 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
309 len
= (width
< len
) ? len
: width
;
313 /* Proceed with decoding one character at a time. */
314 for (j
= 0; j
< len
; j
++, dest
++)
316 c
= read_utf8 (dtp
, &nbytes
);
318 /* Check for a short read and if so, break out. */
322 *dest
= c
> 255 ? '?' : (uchar
) c
;
325 /* If there was a short read, pad the remaining characters. */
326 for (i
= j
; i
< len
; i
++)
332 read_default_char1 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
337 s
= read_block_form (dtp
, &width
);
344 m
= (width
> len
) ? len
: width
;
349 memset (p
+ m
, ' ', n
);
354 read_utf8_char4 (st_parameter_dt
*dtp
, void *p
, int len
, int width
)
360 len
= (width
< len
) ? len
: width
;
362 dest
= (gfc_char4_t
*) p
;
364 /* Proceed with decoding one character at a time. */
365 for (j
= 0; j
< len
; j
++, dest
++)
367 *dest
= read_utf8 (dtp
, &nbytes
);
369 /* Check for a short read and if so, break out. */
374 /* If there was a short read, pad the remaining characters. */
375 for (i
= j
; i
< len
; i
++)
376 *dest
++ = (gfc_char4_t
) ' ';
382 read_default_char4 (st_parameter_dt
*dtp
, char *p
, int len
, int width
)
388 s
= read_block_form (dtp
, &width
);
395 m
= ((int) width
> len
) ? len
: (int) width
;
397 dest
= (gfc_char4_t
*) p
;
399 for (n
= 0; n
< m
; n
++, dest
++, s
++)
400 *dest
= (unsigned char ) *s
;
402 for (n
= 0; n
< len
- (int) width
; n
++, dest
++)
403 *dest
= (unsigned char) ' ';
407 /* read_a()-- Read a character record into a KIND=1 character destination,
408 processing UTF-8 encoding if necessary. */
411 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
417 if (wi
== -1) /* '(A)' edit descriptor */
421 /* Read in w characters, treating comma as not a separator. */
422 dtp
->u
.p
.sf_read_comma
= 0;
424 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
425 read_utf8_char1 (dtp
, p
, length
, w
);
427 read_default_char1 (dtp
, p
, length
, w
);
429 dtp
->u
.p
.sf_read_comma
=
430 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
434 /* read_a_char4()-- Read a character record into a KIND=4 character destination,
435 processing UTF-8 encoding if necessary. */
438 read_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
443 if (w
== -1) /* '(A)' edit descriptor */
446 /* Read in w characters, treating comma as not a separator. */
447 dtp
->u
.p
.sf_read_comma
= 0;
449 if (dtp
->u
.p
.current_unit
->flags
.encoding
== ENCODING_UTF8
)
450 read_utf8_char4 (dtp
, p
, length
, w
);
452 read_default_char4 (dtp
, p
, length
, w
);
454 dtp
->u
.p
.sf_read_comma
=
455 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
458 /* eat_leading_spaces()-- Given a character pointer and a width,
459 * ignore the leading spaces. */
462 eat_leading_spaces (int *width
, char *p
)
466 if (*width
== 0 || *p
!= ' ')
478 next_char (st_parameter_dt
*dtp
, char **p
, int *w
)
493 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
494 return ' '; /* return a blank to signal a null */
496 /* At this point, the rest of the field has to be trailing blanks */
510 /* read_decimal()-- Read a decimal integer value. The values here are
514 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
516 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
517 GFC_INTEGER_LARGEST v
;
523 p
= read_block_form (dtp
, &w
);
528 p
= eat_leading_spaces (&w
, p
);
531 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
535 maxv
= max_value (length
, 1);
557 /* At this point we have a digit-string */
562 c
= next_char (dtp
, &p
, &w
);
568 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
569 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
572 if (c
< '0' || c
> '9')
575 if (value
> maxv_10
&& compile_options
.range_check
== 1)
581 if (value
> maxv
- c
&& compile_options
.range_check
== 1)
590 set_integer (dest
, v
, length
);
594 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
595 "Bad value during integer read");
596 next_record (dtp
, 1);
600 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
601 "Value overflowed during integer read");
602 next_record (dtp
, 1);
607 /* read_radix()-- This function reads values for non-decimal radixes.
608 * The difference here is that we treat the values here as unsigned
609 * values for the purposes of overflow. If minus sign is present and
610 * the top bit is set, the value will be incorrect. */
613 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
616 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
617 GFC_INTEGER_LARGEST v
;
623 p
= read_block_form (dtp
, &w
);
628 p
= eat_leading_spaces (&w
, p
);
631 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
635 maxv
= max_value (length
, 0);
636 maxv_r
= maxv
/ radix
;
657 /* At this point we have a digit-string */
662 c
= next_char (dtp
, &p
, &w
);
667 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
668 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
674 if (c
< '0' || c
> '1')
679 if (c
< '0' || c
> '7')
704 c
= c
- 'a' + '9' + 1;
713 c
= c
- 'A' + '9' + 1;
727 value
= radix
* value
;
729 if (maxv
- c
< value
)
738 set_integer (dest
, v
, length
);
742 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
743 "Bad value during integer read");
744 next_record (dtp
, 1);
748 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
749 "Value overflowed during integer read");
750 next_record (dtp
, 1);
755 /* read_f()-- Read a floating point number with F-style editing, which
756 is what all of the other floating point descriptors behave as. The
757 tricky part is that optional spaces are allowed after an E or D,
758 and the implicit decimal point if a decimal point is not present in
762 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
764 int w
, seen_dp
, exponent
;
769 int seen_int_digit
; /* Seen a digit before the decimal point? */
770 int seen_dec_digit
; /* Seen a digit after the decimal point? */
779 /* Read in the next block. */
780 p
= read_block_form (dtp
, &w
);
783 p
= eat_leading_spaces (&w
, (char*) p
);
787 /* In this buffer we're going to re-format the number cleanly to be parsed
788 by convert_real in the end; this assures we're using strtod from the
789 C library for parsing and thus probably get the best accuracy possible.
790 This process may add a '+0.0' in front of the number as well as change the
791 exponent because of an implicit decimal point or the like. Thus allocating
792 strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
793 original buffer had should be enough. */
794 buffer
= gfc_alloca (w
+ 11);
798 if (*p
== '-' || *p
== '+')
806 p
= eat_leading_spaces (&w
, (char*) p
);
810 /* Process the mantissa string. */
816 if (dtp
->u
.p
.current_unit
->decimal_status
!= DECIMAL_COMMA
)
829 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
834 else if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
837 /* TODO: Should we check instead that there are only trailing
838 blanks here, as is done below for exponents? */
879 /* No exponent has been seen, so we use the current scale factor. */
880 exponent
= - dtp
->u
.p
.scale_factor
;
883 /* At this point the start of an exponent has been found. */
885 p
= eat_leading_spaces (&w
, (char*) p
);
886 if (*p
== '-' || *p
== '+')
894 /* At this point a digit string is required. We calculate the value
895 of the exponent in order to take account of the scale factor and
896 the d parameter before explict conversion takes place. */
901 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
903 while (w
> 0 && isdigit (*p
))
906 exponent
+= *p
- '0';
911 /* Only allow trailing blanks. */
920 else /* BZ or BN status is enabled. */
926 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
)
929 assert (dtp
->u
.p
.blank_status
== BLANK_NULL
);
931 else if (!isdigit (*p
))
936 exponent
+= *p
- '0';
944 exponent
*= exponent_sign
;
947 /* Use the precision specified in the format if no decimal point has been
950 exponent
-= f
->u
.real
.d
;
952 /* Output a trailing '0' after decimal point if not yet found. */
953 if (seen_dp
&& !seen_dec_digit
)
956 /* Print out the exponent to finish the reformatted number. Maximum 4
957 digits for the exponent. */
966 exponent
= - exponent
;
969 assert (exponent
< 10000);
970 for (dig
= 3; dig
>= 0; --dig
)
972 out
[dig
] = (char) ('0' + exponent
% 10);
979 /* Do the actual conversion. */
980 convert_real (dtp
, dest
, buffer
, length
);
984 /* The value read is zero. */
989 *((GFC_REAL_4
*) dest
) = 0.0;
993 *((GFC_REAL_8
*) dest
) = 0.0;
996 #ifdef HAVE_GFC_REAL_10
998 *((GFC_REAL_10
*) dest
) = 0.0;
1002 #ifdef HAVE_GFC_REAL_16
1004 *((GFC_REAL_16
*) dest
) = 0.0;
1009 internal_error (&dtp
->common
, "Unsupported real kind during IO");
1014 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
1015 "Bad value during floating point read");
1016 next_record (dtp
, 1);
1021 /* read_x()-- Deal with the X/TR descriptor. We just read some data
1022 * and never look at it. */
1025 read_x (st_parameter_dt
* dtp
, int n
)
1027 if ((dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
|| is_internal_unit (dtp
))
1028 && dtp
->u
.p
.current_unit
->bytes_left
< n
)
1029 n
= dtp
->u
.p
.current_unit
->bytes_left
;
1031 dtp
->u
.p
.sf_read_comma
= 0;
1033 read_sf (dtp
, &n
, 1);
1034 dtp
->u
.p
.sf_read_comma
= 1;
1035 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;