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 /* eat_leading_spaces()-- Given a character pointer and a width,
275 * ignore the leading spaces. */
278 eat_leading_spaces (int *width
, char *p
)
282 if (*width
== 0 || *p
!= ' ')
294 next_char (st_parameter_dt
*dtp
, char **p
, int *w
)
309 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
310 return ' '; /* return a blank to signal a null */
312 /* At this point, the rest of the field has to be trailing blanks */
326 /* read_decimal()-- Read a decimal integer value. The values here are
330 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
332 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
333 GFC_INTEGER_LARGEST v
;
342 if (read_block_form (dtp
, p
, &wu
) == FAILURE
)
347 p
= eat_leading_spaces (&w
, p
);
350 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
354 maxv
= max_value (length
, 1);
376 /* At this point we have a digit-string */
381 c
= next_char (dtp
, &p
, &w
);
387 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
388 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
391 if (c
< '0' || c
> '9')
400 if (value
> maxv
- c
)
409 set_integer (dest
, v
, length
);
413 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
414 "Bad value during integer read");
415 next_record (dtp
, 1);
419 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
420 "Value overflowed during integer read");
421 next_record (dtp
, 1);
426 /* read_radix()-- This function reads values for non-decimal radixes.
427 * The difference here is that we treat the values here as unsigned
428 * values for the purposes of overflow. If minus sign is present and
429 * the top bit is set, the value will be incorrect. */
432 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
435 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
436 GFC_INTEGER_LARGEST v
;
445 if (read_block_form (dtp
, p
, &wu
) == FAILURE
)
450 p
= eat_leading_spaces (&w
, p
);
453 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
457 maxv
= max_value (length
, 0);
458 maxv_r
= maxv
/ radix
;
479 /* At this point we have a digit-string */
484 c
= next_char (dtp
, &p
, &w
);
489 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
490 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
496 if (c
< '0' || c
> '1')
501 if (c
< '0' || c
> '7')
526 c
= c
- 'a' + '9' + 1;
535 c
= c
- 'A' + '9' + 1;
549 value
= radix
* value
;
551 if (maxv
- c
< value
)
560 set_integer (dest
, v
, length
);
564 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
565 "Bad value during integer read");
566 next_record (dtp
, 1);
570 generate_error (&dtp
->common
, LIBERROR_READ_OVERFLOW
,
571 "Value overflowed during integer read");
572 next_record (dtp
, 1);
577 /* read_f()-- Read a floating point number with F-style editing, which
578 is what all of the other floating point descriptors behave as. The
579 tricky part is that optional spaces are allowed after an E or D,
580 and the implicit decimal point if a decimal point is not present in
584 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
587 int w
, seen_dp
, exponent
;
588 int exponent_sign
, val_sign
;
594 char scratch
[SCRATCH_SIZE
];
602 if (read_block_form (dtp
, p
, &wu
) == FAILURE
)
607 p
= eat_leading_spaces (&w
, p
);
613 if (*p
== '-' || *p
== '+')
622 p
= eat_leading_spaces (&w
, p
);
626 /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
627 is required at this point */
629 if (!isdigit (*p
) && *p
!= '.' && *p
!= ',' && *p
!= 'd' && *p
!= 'D'
630 && *p
!= 'e' && *p
!= 'E')
633 /* Remember the position of the first digit. */
637 /* Scan through the string to find the exponent. */
643 if (dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
&& *p
== ',')
690 /* No exponent has been seen, so we use the current scale factor */
691 exponent
= -dtp
->u
.p
.scale_factor
;
695 generate_error (&dtp
->common
, LIBERROR_READ_VALUE
,
696 "Bad value during floating point read");
697 next_record (dtp
, 1);
700 /* The value read is zero */
705 *((GFC_REAL_4
*) dest
) = 0;
709 *((GFC_REAL_8
*) dest
) = 0;
712 #ifdef HAVE_GFC_REAL_10
714 *((GFC_REAL_10
*) dest
) = 0;
718 #ifdef HAVE_GFC_REAL_16
720 *((GFC_REAL_16
*) dest
) = 0;
725 internal_error (&dtp
->common
, "Unsupported real kind during IO");
729 /* At this point the start of an exponent has been found */
731 while (w
> 0 && *p
== ' ')
752 /* At this point a digit string is required. We calculate the value
753 of the exponent in order to take account of the scale factor and
754 the d parameter before explict conversion takes place. */
763 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
) /* Normal processing of exponent */
765 while (w
> 0 && isdigit (*p
))
767 exponent
= 10 * exponent
+ *p
- '0';
772 /* Only allow trailing blanks */
782 else /* BZ or BN status is enabled */
788 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) *p
= '0';
789 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
796 else if (!isdigit (*p
))
799 exponent
= 10 * exponent
+ *p
- '0';
805 exponent
= exponent
* exponent_sign
;
808 /* Use the precision specified in the format if no decimal point has been
811 exponent
-= f
->u
.real
.d
;
830 i
= ndigits
+ edigits
+ 1;
834 if (i
< SCRATCH_SIZE
)
837 buffer
= get_mem (i
);
839 /* Reformat the string into a temporary buffer. As we're using atof it's
840 easiest to just leave the decimal point in place. */
844 for (; ndigits
> 0; ndigits
--)
848 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) *digits
= '0';
849 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
860 sprintf (p
, "%d", exponent
);
862 /* Do the actual conversion. */
863 convert_real (dtp
, dest
, buffer
, length
);
865 if (buffer
!= scratch
)
871 /* read_x()-- Deal with the X/TR descriptor. We just read some data
872 * and never look at it. */
875 read_x (st_parameter_dt
* dtp
, int n
)
877 if ((dtp
->u
.p
.pad_status
== PAD_NO
|| is_internal_unit (dtp
))
878 && dtp
->u
.p
.current_unit
->bytes_left
< n
)
879 n
= dtp
->u
.p
.current_unit
->bytes_left
;
881 dtp
->u
.p
.sf_read_comma
= 0;
883 read_sf (dtp
, &n
, 1);
884 dtp
->u
.p
.sf_read_comma
= 1;
885 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;