-/* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010, 2011
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
F2003 I/O support contributed by Jerry DeLisle
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
<http://www.gnu.org/licenses/>. */
#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
#include <string.h>
#include <errno.h>
#include <ctype.h>
/* set_integer()-- All of the integer assignments come here to
- * actually place the value into memory. */
+ actually place the value into memory. */
void
set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
switch (length)
{
#ifdef HAVE_GFC_INTEGER_16
+/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
+ case 10:
case 16:
{
GFC_INTEGER_16 tmp = value;
/* convert_real()-- Convert a character representation of a floating
- * point number to the machine number. Returns nonzero if there is a
- * range problem during conversion. TODO: handle not-a-numbers and
- * infinities. */
+ point number to the machine number. Returns nonzero if there is an
+ invalid input. Note: many architectures (e.g. IA-64, HP-PA)
+ require that the storage pointed to by the dest argument is
+ properly aligned for the type in question. */
int
convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
{
- errno = 0;
+ char *endptr = NULL;
switch (length)
{
case 4:
*((GFC_REAL_4*) dest) =
#if defined(HAVE_STRTOF)
- strtof (buffer, NULL);
+ gfc_strtof (buffer, &endptr);
#else
- (GFC_REAL_4) strtod (buffer, NULL);
+ (GFC_REAL_4) gfc_strtod (buffer, &endptr);
#endif
break;
case 8:
- *((GFC_REAL_8*) dest) = strtod (buffer, NULL);
+ *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr);
break;
#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
case 10:
- *((GFC_REAL_10*) dest) = strtold (buffer, NULL);
+ *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr);
break;
#endif
-#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
+#if defined(HAVE_GFC_REAL_16)
+# if defined(GFC_REAL_16_IS_FLOAT128)
+ case 16:
+ *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr);
+ break;
+# elif defined(HAVE_STRTOLD)
case 16:
- *((GFC_REAL_16*) dest) = strtold (buffer, NULL);
+ *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr);
break;
+# endif
#endif
default:
internal_error (&dtp->common, "Unsupported real kind during IO");
}
- if (errno == EINVAL)
+ if (buffer == endptr)
{
generate_error (&dtp->common, LIBERROR_READ_VALUE,
- "Error during floating point read");
+ "Error during floating point read");
next_record (dtp, 1);
return 1;
}
return 0;
}
+/* convert_infnan()-- Convert character INF/NAN representation to the
+ machine number. Note: many architectures (e.g. IA-64, HP-PA) require
+ that the storage pointed to by the dest argument is properly aligned
+ for the type in question. */
+
+int
+convert_infnan (st_parameter_dt *dtp, void *dest, const char *buffer,
+ int length)
+{
+ const char *s = buffer;
+ int is_inf, plus = 1;
+
+ if (*s == '+')
+ s++;
+ else if (*s == '-')
+ {
+ s++;
+ plus = 0;
+ }
+
+ is_inf = *s == 'i';
+
+ switch (length)
+ {
+ case 4:
+ if (is_inf)
+ *((GFC_REAL_4*) dest) = plus ? __builtin_inff () : -__builtin_inff ();
+ else
+ *((GFC_REAL_4*) dest) = plus ? __builtin_nanf ("") : -__builtin_nanf ("");
+ break;
+
+ case 8:
+ if (is_inf)
+ *((GFC_REAL_8*) dest) = plus ? __builtin_inf () : -__builtin_inf ();
+ else
+ *((GFC_REAL_8*) dest) = plus ? __builtin_nan ("") : -__builtin_nan ("");
+ break;
+
+#if defined(HAVE_GFC_REAL_10)
+ case 10:
+ if (is_inf)
+ *((GFC_REAL_10*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
+ else
+ *((GFC_REAL_10*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
+ break;
+#endif
+
+#if defined(HAVE_GFC_REAL_16)
+# if defined(GFC_REAL_16_IS_FLOAT128)
+ case 16:
+ *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, NULL);
+ break;
+# else
+ case 16:
+ if (is_inf)
+ *((GFC_REAL_16*) dest) = plus ? __builtin_infl () : -__builtin_infl ();
+ else
+ *((GFC_REAL_16*) dest) = plus ? __builtin_nanl ("") : -__builtin_nanl ("");
+ break;
+# endif
+#endif
+
+ default:
+ internal_error (&dtp->common, "Unsupported real kind during IO");
+ }
+
+ return 0;
+}
+
/* read_l()-- Read a logical value */
static void
read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
{
- char *s;
- gfc_char4_t *dest;
int m, n;
+ gfc_char4_t *dest;
- s = read_block_form (dtp, &width);
-
- if (s == NULL)
- return;
- if (width > len)
- s += (width - len);
+ if (is_char4_unit(dtp))
+ {
+ gfc_char4_t *s4;
- m = ((int) width > len) ? len : (int) width;
-
- dest = (gfc_char4_t *) p;
-
- for (n = 0; n < m; n++, dest++, s++)
- *dest = (unsigned char ) *s;
+ s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
+
+ if (s4 == NULL)
+ return;
+ if (width > len)
+ s4 += (width - len);
+
+ m = ((int) width > len) ? len : (int) width;
+
+ dest = (gfc_char4_t *) p;
- for (n = 0; n < len - (int) width; n++, dest++)
- *dest = (unsigned char) ' ';
+ for (n = 0; n < m; n++)
+ *dest++ = *s4++;
+
+ for (n = 0; n < len - (int) width; n++)
+ *dest++ = (gfc_char4_t) ' ';
+ }
+ else
+ {
+ char *s;
+
+ s = read_block_form (dtp, &width);
+
+ if (s == NULL)
+ return;
+ if (width > len)
+ s += (width - len);
+
+ m = ((int) width > len) ? len : (int) width;
+
+ dest = (gfc_char4_t *) p;
+
+ for (n = 0; n < m; n++, dest++, s++)
+ *dest = (unsigned char ) *s;
+
+ for (n = 0; n < len - (int) width; n++, dest++)
+ *dest = (unsigned char) ' ';
+ }
}
if (w == 0)
goto zero;
+ /* Check for Infinity or NaN. */
+ if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
+ {
+ int seen_paren = 0;
+ char *save = out;
+
+ /* Scan through the buffer keeping track of spaces and parenthesis. We
+ null terminate the string as soon as we see a left paren or if we are
+ BLANK_NULL mode. Leading spaces have already been skipped above,
+ trailing spaces are ignored by converting to '\0'. A space
+ between "NaN" and the optional perenthesis is not permitted. */
+ while (w > 0)
+ {
+ *out = tolower (*p);
+ switch (*p)
+ {
+ case ' ':
+ if (dtp->u.p.blank_status == BLANK_ZERO)
+ {
+ *out = '0';
+ break;
+ }
+ *out = '\0';
+ if (seen_paren == 1)
+ goto bad_float;
+ break;
+ case '(':
+ seen_paren++;
+ *out = '\0';
+ break;
+ case ')':
+ if (seen_paren++ != 1)
+ goto bad_float;
+ break;
+ default:
+ if (!isalnum (*out))
+ goto bad_float;
+ }
+ --w;
+ ++p;
+ ++out;
+ }
+
+ *out = '\0';
+
+ if (seen_paren != 0 && seen_paren != 2)
+ goto bad_float;
+
+ if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
+ {
+ if (seen_paren)
+ goto bad_float;
+ }
+ else if (strcmp (save, "nan") != 0)
+ goto bad_float;
+
+ convert_infnan (dtp, dest, buffer, length);
+ return;
+ }
+
/* Process the mantissa string. */
while (w > 0)
{
/* Output a trailing '0' after decimal point if not yet found. */
if (seen_dp && !seen_dec_digit)
*(out++) = '0';
+ /* Handle input of style "E+NN" by inserting a 0 for the
+ significand. */
+ else if (!seen_int_digit && !seen_dec_digit)
+ {
+ notify_std (&dtp->common, GFC_STD_LEGACY,
+ "REAL input of style 'E+NN'");
+ *(out++) = '0';
+ }
/* Print out the exponent to finish the reformatted number. Maximum 4
digits for the exponent. */
* and never look at it. */
void
-read_x (st_parameter_dt * dtp, int n)
+read_x (st_parameter_dt *dtp, int n)
{
+ int length, q, q2;
+
if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
+
+ if (n == 0)
+ return;
- dtp->u.p.sf_read_comma = 0;
- if (n > 0)
- read_sf (dtp, &n, 1);
- dtp->u.p.sf_read_comma = 1;
+ length = n;
+
+ if (is_internal_unit (dtp))
+ {
+ mem_alloc_r (dtp->u.p.current_unit->s, &length);
+ if (unlikely (length < n))
+ n = length;
+ goto done;
+ }
+
+ if (dtp->u.p.sf_seen_eor)
+ return;
+
+ n = 0;
+ while (n < length)
+ {
+ q = fbuf_getc (dtp->u.p.current_unit);
+ if (q == EOF)
+ break;
+ else if (q == '\n' || q == '\r')
+ {
+ /* Unexpected end of line. Set the position. */
+ dtp->u.p.sf_seen_eor = 1;
+
+ /* If we see an EOR during non-advancing I/O, we need to skip
+ the rest of the I/O statement. Set the corresponding flag. */
+ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
+ dtp->u.p.eor_condition = 1;
+
+ /* If we encounter a CR, it might be a CRLF. */
+ if (q == '\r') /* Probably a CRLF */
+ {
+ /* See if there is an LF. */
+ q2 = fbuf_getc (dtp->u.p.current_unit);
+ if (q2 == '\n')
+ dtp->u.p.sf_seen_eor = 2;
+ else if (q2 != EOF) /* Oops, seek back. */
+ fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
+ }
+ goto done;
+ }
+ n++;
+ }
+
+ done:
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (GFC_IO_INT) n;
+ dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}
OSDN Git Service
