1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008 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 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
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
)
48 #ifdef HAVE_GFC_INTEGER_16
51 GFC_INTEGER_16 tmp
= value
;
52 memcpy (dest
, (void *) &tmp
, length
);
58 GFC_INTEGER_8 tmp
= value
;
59 memcpy (dest
, (void *) &tmp
, length
);
64 GFC_INTEGER_4 tmp
= value
;
65 memcpy (dest
, (void *) &tmp
, length
);
70 GFC_INTEGER_2 tmp
= value
;
71 memcpy (dest
, (void *) &tmp
, length
);
76 GFC_INTEGER_1 tmp
= value
;
77 memcpy (dest
, (void *) &tmp
, length
);
81 internal_error (NULL
, "Bad integer kind");
86 /* max_value()-- Given a length (kind), return the maximum signed or
90 max_value (int length
, int signed_flag
)
92 GFC_UINTEGER_LARGEST value
;
93 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
99 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
103 for (n
= 1; n
< 4 * length
; n
++)
104 value
= (value
<< 2) + 3;
110 value
= signed_flag
? 0x7fffffffffffffff : 0xffffffffffffffff;
113 value
= signed_flag
? 0x7fffffff : 0xffffffff;
116 value
= signed_flag
? 0x7fff : 0xffff;
119 value
= signed_flag
? 0x7f : 0xff;
122 internal_error (NULL
, "Bad integer kind");
129 /* convert_real()-- Convert a character representation of a floating
130 * point number to the machine number. Returns nonzero if there is a
131 * range problem during conversion. TODO: handle not-a-numbers and
135 convert_real (st_parameter_dt
*dtp
, void *dest
, const char *buffer
, int length
)
144 #if defined(HAVE_STRTOF)
145 strtof (buffer
, NULL
);
147 (GFC_REAL_4
) strtod (buffer
, NULL
);
149 memcpy (dest
, (void *) &tmp
, length
);
154 GFC_REAL_8 tmp
= strtod (buffer
, NULL
);
155 memcpy (dest
, (void *) &tmp
, length
);
158 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
161 GFC_REAL_10 tmp
= strtold (buffer
, NULL
);
162 memcpy (dest
, (void *) &tmp
, length
);
166 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
169 GFC_REAL_16 tmp
= strtold (buffer
, NULL
);
170 memcpy (dest
, (void *) &tmp
, length
);
175 internal_error (&dtp
->common
, "Unsupported real kind during IO");
180 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
181 "Error during floating point read");
182 next_record (dtp
, 1);
190 /* read_l()-- Read a logical value */
193 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
202 if (read_block_form (dtp
, p
, &w
) == FAILURE
)
223 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
227 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
231 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
232 "Bad value on logical read");
233 next_record (dtp
, 1);
239 /* read_a()-- Read a character record. This one is pretty easy. */
242 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
245 int m
, n
, wi
, status
;
249 if (wi
== -1) /* '(A)' edit descriptor */
256 dtp
->u
.p
.sf_read_comma
= 0;
257 status
= read_block_form (dtp
, s
, &w
);
258 dtp
->u
.p
.sf_read_comma
=
259 dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
? 0 : 1;
260 if (status
== FAILURE
)
262 if (w
> (size_t) length
)
265 m
= ((int) w
> length
) ? length
: (int) w
;
270 memset (p
+ m
, ' ', n
);
274 read_a_char4 (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
278 int m
, n
, wi
, status
;
282 if (wi
== -1) /* '(A)' edit descriptor */
289 /* Read in w bytes, treating comma as not a separator. */
290 dtp
->u
.p
.sf_read_comma
= 0;
291 status
= read_block_form (dtp
, s
, &w
);
292 dtp
->u
.p
.sf_read_comma
=
293 dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
? 0 : 1;
295 if (status
== FAILURE
)
297 if (w
> (size_t) length
)
300 m
= ((int) w
> length
) ? length
: (int) w
;
302 dest
= (gfc_char4_t
*) p
;
304 for (n
= 0; n
< m
; n
++, dest
++, s
++)
305 *dest
= (unsigned char ) *s
;
307 for (n
= 0; n
< length
- (int) w
; n
++, dest
++)
308 *dest
= (unsigned char) ' ';
311 /* eat_leading_spaces()-- Given a character pointer and a width,
312 * ignore the leading spaces. */
315 eat_leading_spaces (int *width
, char *p
)
319 if (*width
== 0 || *p
!= ' ')
331 next_char (st_parameter_dt
*dtp
, char **p
, int *w
)
346 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
347 return ' '; /* return a blank to signal a null */
349 /* At this point, the rest of the field has to be trailing blanks */
363 /* read_decimal()-- Read a decimal integer value. The values here are
367 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
369 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
370 GFC_INTEGER_LARGEST v
;
379 if (read_block_form (dtp
, p
, &wu
) == FAILURE
)
384 p
= eat_leading_spaces (&w
, p
);
387 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
391 maxv
= max_value (length
, 1);
413 /* At this point we have a digit-string */
418 c
= next_char (dtp
, &p
, &w
);
424 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
425 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
428 if (c
< '0' || c
> '9')
437 if (value
> maxv
- c
)
446 set_integer (dest
, v
, length
);
450 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
451 "Bad value during integer read");
452 next_record (dtp
, 1);
456 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
457 "Value overflowed during integer read");
458 next_record (dtp
, 1);
463 /* read_radix()-- This function reads values for non-decimal radixes.
464 * The difference here is that we treat the values here as unsigned
465 * values for the purposes of overflow. If minus sign is present and
466 * the top bit is set, the value will be incorrect. */
469 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
472 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
473 GFC_INTEGER_LARGEST v
;
482 if (read_block_form (dtp
, p
, &wu
) == FAILURE
)
487 p
= eat_leading_spaces (&w
, p
);
490 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
494 maxv
= max_value (length
, 0);
495 maxv_r
= maxv
/ radix
;
516 /* At this point we have a digit-string */
521 c
= next_char (dtp
, &p
, &w
);
526 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
527 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
533 if (c
< '0' || c
> '1')
538 if (c
< '0' || c
> '7')
563 c
= c
- 'a' + '9' + 1;
572 c
= c
- 'A' + '9' + 1;
586 value
= radix
* value
;
588 if (maxv
- c
< value
)
597 set_integer (dest
, v
, length
);
601 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
602 "Bad value during integer read");
603 next_record (dtp
, 1);
607 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
608 "Value overflowed during integer read");
609 next_record (dtp
, 1);
614 /* read_f()-- Read a floating point number with F-style editing, which
615 is what all of the other floating point descriptors behave as. The
616 tricky part is that optional spaces are allowed after an E or D,
617 and the implicit decimal point if a decimal point is not present in
621 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
624 int w
, seen_dp
, exponent
;
625 int exponent_sign
, val_sign
;
631 char scratch
[SCRATCH_SIZE
];
639 if (read_block_form (dtp
, p
, &wu
) == FAILURE
)
644 p
= eat_leading_spaces (&w
, p
);
650 if (*p
== '-' || *p
== '+')
659 p
= eat_leading_spaces (&w
, p
);
663 /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
664 is required at this point */
666 if (!isdigit (*p
) && *p
!= '.' && *p
!= ',' && *p
!= 'd' && *p
!= 'D'
667 && *p
!= 'e' && *p
!= 'E')
670 /* Remember the position of the first digit. */
674 /* Scan through the string to find the exponent. */
680 if (dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
&& *p
== ',')
727 /* No exponent has been seen, so we use the current scale factor */
728 exponent
= -dtp
->u
.p
.scale_factor
;
732 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
733 "Bad value during floating point read");
734 next_record (dtp
, 1);
737 /* The value read is zero */
742 *((GFC_REAL_4
*) dest
) = 0;
746 *((GFC_REAL_8
*) dest
) = 0;
749 #ifdef HAVE_GFC_REAL_10
751 *((GFC_REAL_10
*) dest
) = 0;
755 #ifdef HAVE_GFC_REAL_16
757 *((GFC_REAL_16
*) dest
) = 0;
762 internal_error (&dtp
->common
, "Unsupported real kind during IO");
766 /* At this point the start of an exponent has been found */
768 while (w
> 0 && *p
== ' ')
789 /* At this point a digit string is required. We calculate the value
790 of the exponent in order to take account of the scale factor and
791 the d parameter before explict conversion takes place. */
800 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
) /* Normal processing of exponent */
802 while (w
> 0 && isdigit (*p
))
804 exponent
= 10 * exponent
+ *p
- '0';
809 /* Only allow trailing blanks */
819 else /* BZ or BN status is enabled */
825 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) *p
= '0';
826 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
833 else if (!isdigit (*p
))
836 exponent
= 10 * exponent
+ *p
- '0';
842 exponent
= exponent
* exponent_sign
;
845 /* Use the precision specified in the format if no decimal point has been
848 exponent
-= f
->u
.real
.d
;
867 i
= ndigits
+ edigits
+ 1;
871 if (i
< SCRATCH_SIZE
)
874 buffer
= get_mem (i
);
876 /* Reformat the string into a temporary buffer. As we're using atof it's
877 easiest to just leave the decimal point in place. */
881 for (; ndigits
> 0; ndigits
--)
885 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) *digits
= '0';
886 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
897 sprintf (p
, "%d", exponent
);
899 /* Do the actual conversion. */
900 convert_real (dtp
, dest
, buffer
, length
);
902 if (buffer
!= scratch
)
908 /* read_x()-- Deal with the X/TR descriptor. We just read some data
909 * and never look at it. */
912 read_x (st_parameter_dt
* dtp
, int n
)
914 if ((dtp
->u
.p
.pad_status
== PAD_NO
|| is_internal_unit (dtp
))
915 && dtp
->u
.p
.current_unit
->bytes_left
< n
)
916 n
= dtp
->u
.p
.current_unit
->bytes_left
;
918 dtp
->u
.p
.sf_read_comma
= 0;
920 read_sf (dtp
, &n
, 1);
921 dtp
->u
.p
.sf_read_comma
= 1;
922 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;