-/* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2018 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>
-#include <stdlib.h>
#include <assert.h>
typedef unsigned char uchar;
/* 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)
}
-/* max_value()-- Given a length (kind), return the maximum signed or
- * unsigned value */
+/* Max signed value of size give by length argument. */
GFC_UINTEGER_LARGEST
-max_value (int length, int signed_flag)
+si_max (int length)
{
- GFC_UINTEGER_LARGEST value;
#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
- int n;
+ GFC_UINTEGER_LARGEST value;
#endif
switch (length)
- {
+ {
#if defined HAVE_GFC_REAL_16 || defined HAVE_GFC_REAL_10
case 16:
case 10:
value = 1;
- for (n = 1; n < 4 * length; n++)
+ for (int n = 1; n < 4 * length; n++)
value = (value << 2) + 3;
- if (! signed_flag)
- value = 2*value+1;
- break;
+ return value;
#endif
case 8:
- value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
- break;
+ return GFC_INTEGER_8_HUGE;
case 4:
- value = signed_flag ? 0x7fffffff : 0xffffffff;
- break;
+ return GFC_INTEGER_4_HUGE;
case 2:
- value = signed_flag ? 0x7fff : 0xffff;
- break;
+ return GFC_INTEGER_2_HUGE;
case 1:
- value = signed_flag ? 0x7f : 0xff;
- break;
+ return GFC_INTEGER_1_HUGE;
default:
internal_error (NULL, "Bad integer kind");
}
-
- return 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. 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. 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;
+ int round_mode, old_round_mode;
+
+ switch (dtp->u.p.current_unit->round_status)
+ {
+ case ROUND_COMPATIBLE:
+ /* FIXME: As NEAREST but round away from zero for a tie. */
+ case ROUND_UNSPECIFIED:
+ /* Should not occur. */
+ case ROUND_PROCDEFINED:
+ round_mode = ROUND_NEAREST;
+ break;
+ default:
+ round_mode = dtp->u.p.current_unit->round_status;
+ break;
+ }
+
+ old_round_mode = get_fpu_rounding_mode();
+ set_fpu_rounding_mode (round_mode);
switch (length)
{
case 4:
*((GFC_REAL_4*) dest) =
#if defined(HAVE_STRTOF)
- gfc_strtof (buffer, NULL);
+ gfc_strtof (buffer, &endptr);
#else
- (GFC_REAL_4) gfc_strtod (buffer, NULL);
+ (GFC_REAL_4) gfc_strtod (buffer, &endptr);
#endif
break;
case 8:
- *((GFC_REAL_8*) dest) = gfc_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) = gfc_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) = gfc_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)
+ set_fpu_rounding_mode (old_round_mode);
+
+ 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 */
read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
char *p;
- int w;
+ size_t w;
w = f->u.w;
static gfc_char4_t
-read_utf8 (st_parameter_dt *dtp, int *nbytes)
+read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
{
static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
- int i, nb, nread;
+ size_t nb, nread;
gfc_char4_t c;
char *s;
if (s == NULL)
return 0;
/* Decode the bytes read. */
- for (i = 1; i < nb; i++)
+ for (size_t i = 1; i < nb; i++)
{
gfc_char4_t n = *s++;
static void
-read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
+read_utf8_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
{
gfc_char4_t c;
char *dest;
- int nbytes;
- int i, j;
+ size_t nbytes, j;
len = (width < len) ? len : width;
}
/* If there was a short read, pad the remaining characters. */
- for (i = j; i < len; i++)
+ for (size_t i = j; i < len; i++)
*dest++ = ' ';
return;
}
static void
-read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
+read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
{
char *s;
- int m, n;
+ size_t m;
s = read_block_form (dtp, &width);
m = (width > len) ? len : width;
memcpy (p, s, m);
- n = len - width;
- if (n > 0)
- memset (p + m, ' ', n);
+ if (len > width)
+ memset (p + m, ' ', len - width);
}
static void
-read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
+read_utf8_char4 (st_parameter_dt *dtp, void *p, size_t len, size_t width)
{
gfc_char4_t *dest;
- int nbytes;
- int i, j;
+ size_t nbytes, j;
len = (width < len) ? len : width;
}
/* If there was a short read, pad the remaining characters. */
- for (i = j; i < len; i++)
+ for (size_t i = j; i < len; i++)
*dest++ = (gfc_char4_t) ' ';
return;
}
static void
-read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
+read_default_char4 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
{
- char *s;
+ size_t m, n;
gfc_char4_t *dest;
- int m, n;
- 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 = (width > len) ? len : 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++;
+
+ if (len > width)
+ {
+ for (n = 0; n < len - 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 = (width > len) ? len : width;
+
+ dest = (gfc_char4_t *) p;
+
+ for (n = 0; n < m; n++, dest++, s++)
+ *dest = (unsigned char ) *s;
+
+ if (len > width)
+ {
+ for (n = 0; n < len - width; n++, dest++)
+ *dest = (unsigned char) ' ';
+ }
+ }
}
processing UTF-8 encoding if necessary. */
void
-read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+read_a (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
{
- int wi;
- int w;
+ size_t w;
- wi = f->u.w;
- if (wi == -1) /* '(A)' edit descriptor */
- wi = length;
- w = wi;
+ if (f->u.w == -1) /* '(A)' edit descriptor */
+ w = length;
+ else
+ w = f->u.w;
/* Read in w characters, treating comma as not a separator. */
dtp->u.p.sf_read_comma = 0;
processing UTF-8 encoding if necessary. */
void
-read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
{
- int w;
+ size_t w;
- w = f->u.w;
- if (w == -1) /* '(A)' edit descriptor */
+ if (f->u.w == -1) /* '(A)' edit descriptor */
w = length;
+ else
+ w = f->u.w;
/* Read in w characters, treating comma as not a separator. */
dtp->u.p.sf_read_comma = 0;
}
/* eat_leading_spaces()-- Given a character pointer and a width,
- * ignore the leading spaces. */
+ ignore the leading spaces. */
static char *
-eat_leading_spaces (int *width, char *p)
+eat_leading_spaces (size_t *width, char *p)
{
for (;;)
{
static char
-next_char (st_parameter_dt *dtp, char **p, int *w)
+next_char (st_parameter_dt *dtp, char **p, size_t *w)
{
char c, *q;
/* read_decimal()-- Read a decimal integer value. The values here are
- * signed values. */
+ signed values. */
void
read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
- int w, negative;
+ size_t w;
+ int negative;
char c, *p;
w = f->u.w;
return;
}
- maxv = max_value (length, 1);
- maxv_10 = maxv / 10;
-
negative = 0;
- value = 0;
switch (*p)
{
break;
}
+ maxv = si_max (length);
+ if (negative)
+ maxv++;
+ maxv_10 = maxv / 10;
+
/* At this point we have a digit-string */
value = 0;
if (c == ' ')
{
- if (dtp->u.p.blank_status == BLANK_NULL) continue;
+ if (dtp->u.p.blank_status == BLANK_NULL)
+ {
+ /* Skip spaces. */
+ for ( ; w > 0; p++, w--)
+ if (*p != ' ') break;
+ continue;
+ }
if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
if (c < '0' || c > '9')
goto bad;
- if (value > maxv_10 && compile_options.range_check == 1)
+ if (value > maxv_10)
goto overflow;
c -= '0';
value = 10 * value;
- if (value > maxv - c && compile_options.range_check == 1)
+ if (value > maxv - c)
goto overflow;
value += c;
}
- v = value;
if (negative)
- v = -v;
+ v = -value;
+ else
+ v = value;
set_integer (dest, v, length);
return;
/* read_radix()-- This function reads values for non-decimal radixes.
- * The difference here is that we treat the values here as unsigned
- * values for the purposes of overflow. If minus sign is present and
- * the top bit is set, the value will be incorrect. */
+ The difference here is that we treat the values here as unsigned
+ values for the purposes of overflow. If minus sign is present and
+ the top bit is set, the value will be incorrect. */
void
read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
{
GFC_UINTEGER_LARGEST value, maxv, maxv_r;
GFC_INTEGER_LARGEST v;
- int w, negative;
+ size_t w;
+ int negative;
char c, *p;
w = f->u.w;
return;
}
- maxv = max_value (length, 0);
+ /* Maximum unsigned value, assuming two's complement. */
+ maxv = 2 * si_max (length) + 1;
maxv_r = maxv / radix;
negative = 0;
void
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
- int w, seen_dp, exponent;
+#define READF_TMP 50
+ char tmp[READF_TMP];
+ size_t buf_size = 0;
+ size_t w;
+ int seen_dp, exponent;
int exponent_sign;
const char *p;
char *buffer;
exponent_sign = 1;
exponent = 0;
w = f->u.w;
+ buffer = tmp;
/* Read in the next block. */
p = read_block_form (dtp, &w);
exponent because of an implicit decimal point or the like. Thus allocating
strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
original buffer had should be enough. */
- buffer = gfc_alloca (w + 11);
+ buf_size = w + 11;
+ if (buf_size > READF_TMP)
+ buffer = xmalloc (buf_size);
+
out = buffer;
/* Optional sign */
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);
+ if (buf_size > READF_TMP)
+ free (buffer);
+ return;
+ }
+
/* Process the mantissa string. */
while (w > 0)
{
case 'E':
case 'd':
case 'D':
+ case 'q':
+ case 'Q':
++p;
--w;
goto exponent;
the d parameter before explict conversion takes place. */
if (w == 0)
- goto bad_float;
+ {
+ /* Extension: allow default exponent of 0 when omitted. */
+ if (dtp->common.flags & IOPARM_DT_DEFAULT_EXP)
+ goto done;
+ else
+ goto bad_float;
+ }
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
{
/* 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. */
exponent = - exponent;
}
- assert (exponent < 10000);
+ if (exponent >= 10000)
+ goto bad_float;
+
for (dig = 3; dig >= 0; --dig)
{
out[dig] = (char) ('0' + exponent % 10);
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
-
+ if (buf_size > READF_TMP)
+ free (buffer);
return;
/* The value read is zero. */
return;
bad_float:
+ if (buf_size > READF_TMP)
+ free (buffer);
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during floating point read");
next_record (dtp, 1);
/* read_x()-- Deal with the X/TR descriptor. We just read some data
- * and never look at it. */
+ and never look at it. */
void
-read_x (st_parameter_dt * dtp, int n)
+read_x (st_parameter_dt *dtp, size_t n)
{
+ size_t length;
+ int q, q2;
+
if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
- && dtp->u.p.current_unit->bytes_left < n)
+ && dtp->u.p.current_unit->bytes_left < (gfc_offset) 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 (dtp->u.p.current_unit->flags.cc != CC_NONE
+ && (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.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
+ dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}
projects / gcc.git / blobdiff