the Free Software Foundation; either version 2, or (at your option)
any later version.
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
#include "config.h"
#include <errno.h>
#include <ctype.h>
#include <stdlib.h>
+#include <stdio.h>
#include "libgfortran.h"
#include "io.h"
* actually place the value into memory. */
void
-set_integer (void *dest, int64_t value, int length)
+set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
{
-
switch (length)
{
+#ifdef HAVE_GFC_INTEGER_16
+ case 16:
+ *((GFC_INTEGER_16 *) dest) = value;
+ break;
+#endif
case 8:
- *((int64_t *) dest) = value;
+ *((GFC_INTEGER_8 *) dest) = value;
break;
case 4:
- *((int32_t *) dest) = value;
+ *((GFC_INTEGER_4 *) dest) = value;
break;
case 2:
- *((int16_t *) dest) = value;
+ *((GFC_INTEGER_2 *) dest) = value;
break;
case 1:
- *((int8_t *) dest) = value;
+ *((GFC_INTEGER_1 *) dest) = value;
break;
default:
internal_error ("Bad integer kind");
/* max_value()-- Given a length (kind), return the maximum signed or
* unsigned value */
-uint64_t
+GFC_UINTEGER_LARGEST
max_value (int length, int signed_flag)
{
- uint64_t value;
+ GFC_UINTEGER_LARGEST value;
+ int n;
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++)
+ value = (value << 2) + 3;
+ if (! signed_flag)
+ value = 2*value+1;
+ break;
+#endif
case 8:
value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
break;
/* 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. Handling of kind 4 is probably wrong because of double
- * rounding. */
+ * infinities. */
int
convert_real (void *dest, const char *buffer, int length)
{
-
errno = 0;
switch (length)
{
case 4:
- *((float *) dest) = (float) strtod (buffer, NULL);
+ {
+ GFC_REAL_4 tmp =
+#if defined(HAVE_STRTOF)
+ strtof (buffer, NULL);
+#else
+ (GFC_REAL_4) strtod (buffer, NULL);
+#endif
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
case 8:
- *((double *) dest) = strtod (buffer, NULL);
+ {
+ GFC_REAL_8 tmp = strtod (buffer, NULL);
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
+ case 10:
+ {
+ GFC_REAL_10 tmp = strtold (buffer, NULL);
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+#endif
+#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
+ case 16:
+ {
+ GFC_REAL_16 tmp = strtold (buffer, NULL);
+ memcpy (dest, (void *) &tmp, length);
+ }
break;
+#endif
default:
- internal_error ("Bad real number kind");
+ internal_error ("Unsupported real kind during IO");
}
- if (errno != 0)
+ if (errno != 0 && errno != EINVAL)
{
generate_error (ERROR_READ_VALUE,
"Range error during floating point read");
return 0;
}
-static int
-convert_precision_real (void *dest, int sign,
- char *buffer, int length, int exponent)
-{
- int w, new_dp_pos, i, slen, k, dp;
- char * p, c;
- double fval;
- float tf;
-
- fval =0.0;
- tf = 0.0;
- dp = 0;
- new_dp_pos = 0;
-
- slen = strlen (buffer);
- w = slen;
- p = buffer;
-
-/* for (i = w - 1; i > 0; i --)
- {
- if (buffer[i] == '0' || buffer[i] == 0)
- buffer[i] = 0;
- else
- break;
- }
-*/
- for (i = 0; i < w; i++)
- {
- if (buffer[i] == '.')
- break;
- }
-
- new_dp_pos = i;
- new_dp_pos += exponent;
-
- while (w > 0)
- {
- c = *p;
- switch (c)
- {
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- fval = fval * 10.0 + c - '0';
- p++;
- w--;
- break;
-
- case '.':
- dp = 1;
- p++;
- w--;
- break;
-
- default:
- p++;
- w--;
- break;
- }
- }
-
- if (sign)
- fval = - fval;
-
- i = new_dp_pos - slen + dp;
- k = abs(i);
- tf = 1.0;
-
- while (k > 0)
- {
- tf *= 10.0 ;
- k -- ;
- }
-
- if (fval != 0.0)
- {
- if (i < 0)
- {
- fval = fval / tf;
- }
- else
- {
- fval = fval * tf;
- }
- }
-
- switch (length)
- {
- case 4:
- *((float *) dest) = (float)fval;
- break;
- case 8:
- *((double *) dest) = fval;
- break;
- default:
- internal_error ("Bad real number kind");
- }
-
- return 0;
-}
-
/* read_l()-- Read a logical value */
{
case 't':
case 'T':
- set_integer (dest, 1, length);
+ set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
break;
case 'f':
case 'F':
- set_integer (dest, 0, length);
+ set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
break;
default:
bad:
static char *
eat_leading_spaces (int *width, char *p)
{
-
for (;;)
{
if (*width == 0 || *p != ' ')
if (c != ' ')
return c;
- if (g.blank_status == BLANK_ZERO)
- return '0';
+ if (g.blank_status != BLANK_UNSPECIFIED)
+ return ' '; /* return a blank to signal a null */
/* At this point, the rest of the field has to be trailing blanks */
void
read_decimal (fnode * f, char *dest, int length)
{
- unsigned value, maxv, maxv_10;
- int v, w, negative;
+ GFC_UINTEGER_LARGEST value, maxv, maxv_10;
+ GFC_INTEGER_LARGEST v;
+ int w, negative;
char c, *p;
w = f->u.w;
p = eat_leading_spaces (&w, p);
if (w == 0)
{
- set_integer (dest, 0, length);
+ set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
return;
}
c = next_char (&p, &w);
if (c == '\0')
break;
-
+
+ if (c == ' ')
+ {
+ if (g.blank_status == BLANK_NULL) continue;
+ if (g.blank_status == BLANK_ZERO) c = '0';
+ }
+
if (c < '0' || c > '9')
goto bad;
value += c;
}
- v = (signed int) value;
+ v = value;
if (negative)
v = -v;
set_integer (dest, v, length);
return;
-bad:
+ bad:
generate_error (ERROR_READ_VALUE, "Bad value during integer read");
return;
-overflow:
+ overflow:
generate_error (ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
void
read_radix (fnode * f, char *dest, int length, int radix)
{
- unsigned value, maxv, maxv_r;
- int v, w, negative;
+ GFC_UINTEGER_LARGEST value, maxv, maxv_r;
+ GFC_INTEGER_LARGEST v;
+ int w, negative;
char c, *p;
w = f->u.w;
p = eat_leading_spaces (&w, p);
if (w == 0)
{
- set_integer (dest, 0, length);
+ set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
return;
}
c = next_char (&p, &w);
if (c == '\0')
break;
+ if (c == ' ')
+ {
+ if (g.blank_status == BLANK_NULL) continue;
+ if (g.blank_status == BLANK_ZERO) c = '0';
+ }
switch (radix)
{
value += c;
}
- v = (signed int) value;
+ v = value;
if (negative)
v = -v;
set_integer (dest, v, length);
return;
-bad:
+ bad:
generate_error (ERROR_READ_VALUE, "Bad value during integer read");
return;
-overflow:
+ overflow:
generate_error (ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
/* read_f()-- Read a floating point number with F-style editing, which
- * is what all of the other floating point descriptors behave as. The
- * tricky part is that optional spaces are allowed after an E or D,
- * and the implicit decimal point if a decimal point is not present in
- * the input. */
+ is what all of the other floating point descriptors behave as. The
+ tricky part is that optional spaces are allowed after an E or D,
+ and the implicit decimal point if a decimal point is not present in
+ the input. */
void
read_f (fnode * f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign, val_sign;
- char *p, *buffer, *n;
+ int ndigits;
+ int edigits;
+ int i;
+ char *p, *buffer;
+ char *digits;
- val_sign = 0;
+ val_sign = 1;
seen_dp = 0;
w = f->u.w;
p = read_block (&w);
p = eat_leading_spaces (&w, p);
if (w == 0)
- {
- switch (length)
- {
- case 4:
- *((float *) dest) = 0.0;
- break;
-
- case 8:
- *((double *) dest) = 0.0;
- break;
- }
-
- return;
- }
-
- if (w + 2 < SCRATCH_SIZE)
- buffer = scratch;
- else
- buffer = get_mem (w + 2);
-
- memset(buffer, 0, w + 2);
-
- n = buffer;
+ goto zero;
/* Optional sign */
if (*p == '-' || *p == '+')
{
if (*p == '-')
- val_sign = 1;
+ val_sign = -1;
p++;
-
- if (--w == 0)
- goto bad_float;
+ w--;
}
exponent_sign = 1;
+ p = eat_leading_spaces (&w, p);
+ if (w == 0)
+ goto zero;
- /* A digit (or a '.') is required at this point */
+ /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
+ is required at this point */
- if (!isdigit (*p) && *p != '.')
+ if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
+ && *p != 'e' && *p != 'E')
goto bad_float;
+ /* Remember the position of the first digit. */
+ digits = p;
+ ndigits = 0;
+
+ /* Scan through the string to find the exponent. */
while (w > 0)
{
switch (*p)
{
+ case '.':
+ if (seen_dp)
+ goto bad_float;
+ seen_dp = 1;
+ /* Fall through */
+
case '0':
case '1':
case '2':
case '7':
case '8':
case '9':
- *n++ = *p++;
- w--;
- break;
-
- case '.':
- if (seen_dp)
- goto bad_float;
- seen_dp = 1;
-
- *n++ = *p++;
- w--;
- break;
-
case ' ':
- if (g.blank_status == BLANK_ZERO)
- *n++ = '0';
- p++;
+ ndigits++;
+ *p++;
w--;
break;
}
}
-/* No exponent has been seen, so we use the current scale factor */
-
+ /* No exponent has been seen, so we use the current scale factor */
exponent = -g.scale_factor;
goto done;
-bad_float:
+ bad_float:
generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
- if (buffer != scratch)
- free_mem (buffer);
return;
-/* At this point the start of an exponent has been found */
+ /* The value read is zero */
+ zero:
+ switch (length)
+ {
+ case 4:
+ *((GFC_REAL_4 *) dest) = 0;
+ break;
+
+ case 8:
+ *((GFC_REAL_8 *) dest) = 0;
+ break;
+
+#ifdef HAVE_GFC_REAL_10
+ case 10:
+ *((GFC_REAL_10 *) dest) = 0;
+ break;
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+ case 16:
+ *((GFC_REAL_16 *) dest) = 0;
+ break;
+#endif
-exp1:
+ default:
+ internal_error ("Unsupported real kind during IO");
+ }
+ return;
+
+ /* At this point the start of an exponent has been found */
+ exp1:
while (w > 0 && *p == ' ')
{
w--;
if (w == 0)
goto bad_float;
-/* At this point a digit string is required. We calculate the value
- * of the exponent in order to take account of the scale factor and
- * the d parameter before explict conversion takes place. */
-
-exp2:
+ /* At this point a digit string is required. We calculate the value
+ of the exponent in order to take account of the scale factor and
+ the d parameter before explict conversion takes place. */
+ exp2:
if (!isdigit (*p))
goto bad_float;
p++;
w--;
- while (w > 0 && isdigit (*p))
+ if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
{
- exponent = 10 * exponent + *p - '0';
- if (exponent > 999999)
- goto bad_float;
-
- p++;
- w--;
- }
-
- /* Only allow trailing blanks */
+ while (w > 0 && isdigit (*p))
+ {
+ exponent = 10 * exponent + *p - '0';
+ p++;
+ w--;
+ }
+
+ /* Only allow trailing blanks */
- while (w > 0)
+ while (w > 0)
+ {
+ if (*p != ' ')
+ goto bad_float;
+ p++;
+ w--;
+ }
+ }
+ else /* BZ or BN status is enabled */
{
- if (*p != ' ')
- goto bad_float;
- p++;
- w--;
+ while (w > 0)
+ {
+ if (*p == ' ')
+ {
+ if (g.blank_status == BLANK_ZERO) *p = '0';
+ if (g.blank_status == BLANK_NULL)
+ {
+ p++;
+ w--;
+ continue;
+ }
+ }
+ else if (!isdigit (*p))
+ goto bad_float;
+
+ exponent = 10 * exponent + *p - '0';
+ p++;
+ w--;
+ }
}
exponent = exponent * exponent_sign;
-done:
+ done:
+ /* Use the precision specified in the format if no decimal point has been
+ seen. */
if (!seen_dp)
exponent -= f->u.real.d;
- /* The number is syntactically correct and ready for conversion.
- * The only thing that can go wrong at this point is overflow or
- * underflow. */
+ if (exponent > 0)
+ {
+ edigits = 2;
+ i = exponent;
+ }
+ else
+ {
+ edigits = 3;
+ i = -exponent;
+ }
+
+ while (i >= 10)
+ {
+ i /= 10;
+ edigits++;
+ }
+
+ i = ndigits + edigits + 1;
+ if (val_sign < 0)
+ i++;
+
+ if (i < SCRATCH_SIZE)
+ buffer = scratch;
+ else
+ buffer = get_mem (i);
+
+ /* Reformat the string into a temporary buffer. As we're using atof it's
+ easiest to just leave the decimal point in place. */
+ p = buffer;
+ if (val_sign < 0)
+ *(p++) = '-';
+ for (; ndigits > 0; ndigits--)
+ {
+ if (*digits == ' ')
+ {
+ if (g.blank_status == BLANK_ZERO) *digits = '0';
+ if (g.blank_status == BLANK_NULL)
+ {
+ digits++;
+ continue;
+ }
+ }
+ *p = *digits;
+ p++;
+ digits++;
+ }
+ *(p++) = 'e';
+ sprintf (p, "%d", exponent);
- convert_precision_real (dest, val_sign, buffer, length, exponent);
+ /* Do the actual conversion. */
+ convert_real (dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
int n;
n = f->u.n;
- read_block (&n);
+
+ if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
+ && current_unit->bytes_left < n)
+ n = current_unit->bytes_left;
+
+ if (n > 0)
+ read_block (&n);
}
OSDN Git Service
