1 /* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
37 #include "libgfortran.h"
40 /* 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
53 GFC_INTEGER_16 tmp
= value
;
54 memcpy (dest
, (void *) &tmp
, length
);
60 GFC_INTEGER_8 tmp
= value
;
61 memcpy (dest
, (void *) &tmp
, length
);
66 GFC_INTEGER_4 tmp
= value
;
67 memcpy (dest
, (void *) &tmp
, length
);
72 GFC_INTEGER_2 tmp
= value
;
73 memcpy (dest
, (void *) &tmp
, length
);
78 GFC_INTEGER_1 tmp
= value
;
79 memcpy (dest
, (void *) &tmp
, length
);
83 internal_error (NULL
, "Bad integer kind");
88 /* max_value()-- Given a length (kind), return the maximum signed or
92 max_value (int length
, int signed_flag
)
94 GFC_UINTEGER_LARGEST value
;
95 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
101 #if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
105 for (n
= 1; n
< 4 * length
; n
++)
106 value
= (value
<< 2) + 3;
112 value
= signed_flag
? 0x7fffffffffffffff : 0xffffffffffffffff;
115 value
= signed_flag
? 0x7fffffff : 0xffffffff;
118 value
= signed_flag
? 0x7fff : 0xffff;
121 value
= signed_flag
? 0x7f : 0xff;
124 internal_error (NULL
, "Bad integer kind");
131 /* convert_real()-- Convert a character representation of a floating
132 * point number to the machine number. Returns nonzero if there is a
133 * range problem during conversion. TODO: handle not-a-numbers and
137 convert_real (st_parameter_dt
*dtp
, void *dest
, const char *buffer
, int length
)
146 #if defined(HAVE_STRTOF)
147 strtof (buffer
, NULL
);
149 (GFC_REAL_4
) strtod (buffer
, NULL
);
151 memcpy (dest
, (void *) &tmp
, length
);
156 GFC_REAL_8 tmp
= strtod (buffer
, NULL
);
157 memcpy (dest
, (void *) &tmp
, length
);
160 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
163 GFC_REAL_10 tmp
= strtold (buffer
, NULL
);
164 memcpy (dest
, (void *) &tmp
, length
);
168 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
171 GFC_REAL_16 tmp
= strtold (buffer
, NULL
);
172 memcpy (dest
, (void *) &tmp
, length
);
177 internal_error (&dtp
->common
, "Unsupported real kind during IO");
180 if (errno
!= 0 && errno
!= EINVAL
)
182 generate_error (&dtp
->common
, ERROR_READ_VALUE
,
183 "Range error during floating point read");
191 /* read_l()-- Read a logical value */
194 read_l (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
200 p
= read_block (dtp
, &w
);
222 set_integer (dest
, (GFC_INTEGER_LARGEST
) 1, length
);
226 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
230 generate_error (&dtp
->common
, ERROR_READ_VALUE
,
231 "Bad value on logical read");
237 /* read_a()-- Read a character record. This one is pretty easy. */
240 read_a (st_parameter_dt
*dtp
, const fnode
*f
, char *p
, int length
)
246 if (w
== -1) /* '(A)' edit descriptor */
249 dtp
->u
.p
.sf_read_comma
= 0;
250 source
= read_block (dtp
, &w
);
251 dtp
->u
.p
.sf_read_comma
= 1;
255 source
+= (w
- length
);
257 m
= (w
> length
) ? length
: w
;
258 memcpy (p
, source
, m
);
262 memset (p
+ m
, ' ', n
);
266 /* eat_leading_spaces()-- Given a character pointer and a width,
267 * ignore the leading spaces. */
270 eat_leading_spaces (int *width
, char *p
)
274 if (*width
== 0 || *p
!= ' ')
286 next_char (st_parameter_dt
*dtp
, char **p
, int *w
)
301 if (dtp
->u
.p
.blank_status
!= BLANK_UNSPECIFIED
)
302 return ' '; /* return a blank to signal a null */
304 /* At this point, the rest of the field has to be trailing blanks */
318 /* read_decimal()-- Read a decimal integer value. The values here are
322 read_decimal (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
324 GFC_UINTEGER_LARGEST value
, maxv
, maxv_10
;
325 GFC_INTEGER_LARGEST v
;
330 p
= read_block (dtp
, &w
);
334 p
= eat_leading_spaces (&w
, p
);
337 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
341 maxv
= max_value (length
, 1);
363 /* At this point we have a digit-string */
368 c
= next_char (dtp
, &p
, &w
);
374 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
375 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
378 if (c
< '0' || c
> '9')
387 if (value
> maxv
- c
)
396 set_integer (dest
, v
, length
);
400 generate_error (&dtp
->common
, ERROR_READ_VALUE
,
401 "Bad value during integer read");
405 generate_error (&dtp
->common
, ERROR_READ_OVERFLOW
,
406 "Value overflowed during integer read");
411 /* read_radix()-- This function reads values for non-decimal radixes.
412 * The difference here is that we treat the values here as unsigned
413 * values for the purposes of overflow. If minus sign is present and
414 * the top bit is set, the value will be incorrect. */
417 read_radix (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
,
420 GFC_UINTEGER_LARGEST value
, maxv
, maxv_r
;
421 GFC_INTEGER_LARGEST v
;
426 p
= read_block (dtp
, &w
);
430 p
= eat_leading_spaces (&w
, p
);
433 set_integer (dest
, (GFC_INTEGER_LARGEST
) 0, length
);
437 maxv
= max_value (length
, 0);
438 maxv_r
= maxv
/ radix
;
459 /* At this point we have a digit-string */
464 c
= next_char (dtp
, &p
, &w
);
469 if (dtp
->u
.p
.blank_status
== BLANK_NULL
) continue;
470 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) c
= '0';
476 if (c
< '0' || c
> '1')
481 if (c
< '0' || c
> '7')
506 c
= c
- 'a' + '9' + 1;
515 c
= c
- 'A' + '9' + 1;
529 value
= radix
* value
;
531 if (maxv
- c
< value
)
540 set_integer (dest
, v
, length
);
544 generate_error (&dtp
->common
, ERROR_READ_VALUE
,
545 "Bad value during integer read");
549 generate_error (&dtp
->common
, ERROR_READ_OVERFLOW
,
550 "Value overflowed during integer read");
555 /* read_f()-- Read a floating point number with F-style editing, which
556 is what all of the other floating point descriptors behave as. The
557 tricky part is that optional spaces are allowed after an E or D,
558 and the implicit decimal point if a decimal point is not present in
562 read_f (st_parameter_dt
*dtp
, const fnode
*f
, char *dest
, int length
)
564 int w
, seen_dp
, exponent
;
565 int exponent_sign
, val_sign
;
571 char scratch
[SCRATCH_SIZE
];
576 p
= read_block (dtp
, &w
);
580 p
= eat_leading_spaces (&w
, p
);
586 if (*p
== '-' || *p
== '+')
595 p
= eat_leading_spaces (&w
, p
);
599 /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
600 is required at this point */
602 if (!isdigit (*p
) && *p
!= '.' && *p
!= 'd' && *p
!= 'D'
603 && *p
!= 'e' && *p
!= 'E')
606 /* Remember the position of the first digit. */
610 /* Scan through the string to find the exponent. */
659 /* No exponent has been seen, so we use the current scale factor */
660 exponent
= -dtp
->u
.p
.scale_factor
;
664 generate_error (&dtp
->common
, ERROR_READ_VALUE
,
665 "Bad value during floating point read");
668 /* The value read is zero */
673 *((GFC_REAL_4
*) dest
) = 0;
677 *((GFC_REAL_8
*) dest
) = 0;
680 #ifdef HAVE_GFC_REAL_10
682 *((GFC_REAL_10
*) dest
) = 0;
686 #ifdef HAVE_GFC_REAL_16
688 *((GFC_REAL_16
*) dest
) = 0;
693 internal_error (&dtp
->common
, "Unsupported real kind during IO");
697 /* At this point the start of an exponent has been found */
699 while (w
> 0 && *p
== ' ')
720 /* At this point a digit string is required. We calculate the value
721 of the exponent in order to take account of the scale factor and
722 the d parameter before explict conversion takes place. */
731 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
) /* Normal processing of exponent */
733 while (w
> 0 && isdigit (*p
))
735 exponent
= 10 * exponent
+ *p
- '0';
740 /* Only allow trailing blanks */
750 else /* BZ or BN status is enabled */
756 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) *p
= '0';
757 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
764 else if (!isdigit (*p
))
767 exponent
= 10 * exponent
+ *p
- '0';
773 exponent
= exponent
* exponent_sign
;
776 /* Use the precision specified in the format if no decimal point has been
779 exponent
-= f
->u
.real
.d
;
798 i
= ndigits
+ edigits
+ 1;
802 if (i
< SCRATCH_SIZE
)
805 buffer
= get_mem (i
);
807 /* Reformat the string into a temporary buffer. As we're using atof it's
808 easiest to just leave the decimal point in place. */
812 for (; ndigits
> 0; ndigits
--)
816 if (dtp
->u
.p
.blank_status
== BLANK_ZERO
) *digits
= '0';
817 if (dtp
->u
.p
.blank_status
== BLANK_NULL
)
828 sprintf (p
, "%d", exponent
);
830 /* Do the actual conversion. */
831 convert_real (dtp
, dest
, buffer
, length
);
833 if (buffer
!= scratch
)
840 /* read_x()-- Deal with the X/TR descriptor. We just read some data
841 * and never look at it. */
844 read_x (st_parameter_dt
*dtp
, int n
)
846 if (!is_stream_io (dtp
))
848 if ((dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
|| is_internal_unit (dtp
))
849 && dtp
->u
.p
.current_unit
->bytes_left
< n
)
850 n
= dtp
->u
.p
.current_unit
->bytes_left
;
852 dtp
->u
.p
.sf_read_comma
= 0;
854 read_sf (dtp
, &n
, 1);
855 dtp
->u
.p
.sf_read_comma
= 1;
858 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) n
;