746e63273f
2010-07-19 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libfortran/44953 * io/unix.c (mem_alloc_w4): Return gfc_char4_t instead of char type pointer. (mem_write4): Remove cast to gfc_char4_t. * io/transfer.c (write_block): Use a gfc_char4_t pointer. (memset4): New helper function. (next_record_w): Use new helper function rather than sset for internal units. Don't attempt to pad with spaces if it is not needed. * io/unix.h: Update prototype for mem_alloc_w4. * io/write.c (memset4): Use gfc_char4_t pointer and chracter type. Don't use multiply by 4 to compute offset. (memcpy4): Likewise. (write_default_char4): Use a gfc_char4_t pointer and update memset4 and memcpy calls. (write_a): Likewise. (write_l): Likewise. (write_boz): Likewise. (write_decimal): Likewise. (write_x): Likewise. (write_char): Add support for character(kind=4) internal units that was previously missed. (write_integer): Use a gfc_char4_t pointer and update memset4 and memcpy calls. (write_character): Likewise. (write_separator): Add support for character(kind=4) internal units that was previously missed. * write_float.def (output_float): Use a gfc_char4_t pointer and update memset4 and memcpy calls. (write_infnan): Likewise. (output_float_FMT_G_): Likewise. From-SVN: r162304
1067 lines
23 KiB
Modula-2
1067 lines
23 KiB
Modula-2
/* Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
|
|
Contributed by Andy Vaught
|
|
Write float code factoring to this file by Jerry DeLisle
|
|
F2003 I/O support contributed by Jerry DeLisle
|
|
|
|
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
|
|
the Free Software Foundation; either version 3, or (at your option)
|
|
any later version.
|
|
|
|
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
|
|
GNU General Public License for more details.
|
|
|
|
Under Section 7 of GPL version 3, you are granted additional
|
|
permissions described in the GCC Runtime Library Exception, version
|
|
3.1, as published by the Free Software Foundation.
|
|
|
|
You should have received a copy of the GNU General Public License and
|
|
a copy of the GCC Runtime Library Exception along with this program;
|
|
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
#include "config.h"
|
|
|
|
typedef enum
|
|
{ S_NONE, S_MINUS, S_PLUS }
|
|
sign_t;
|
|
|
|
/* Given a flag that indicates if a value is negative or not, return a
|
|
sign_t that gives the sign that we need to produce. */
|
|
|
|
static sign_t
|
|
calculate_sign (st_parameter_dt *dtp, int negative_flag)
|
|
{
|
|
sign_t s = S_NONE;
|
|
|
|
if (negative_flag)
|
|
s = S_MINUS;
|
|
else
|
|
switch (dtp->u.p.sign_status)
|
|
{
|
|
case SIGN_SP: /* Show sign. */
|
|
s = S_PLUS;
|
|
break;
|
|
case SIGN_SS: /* Suppress sign. */
|
|
s = S_NONE;
|
|
break;
|
|
case SIGN_S: /* Processor defined. */
|
|
case SIGN_UNSPECIFIED:
|
|
s = options.optional_plus ? S_PLUS : S_NONE;
|
|
break;
|
|
}
|
|
|
|
return s;
|
|
}
|
|
|
|
|
|
/* Output a real number according to its format which is FMT_G free. */
|
|
|
|
static void
|
|
output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
|
|
int sign_bit, bool zero_flag, int ndigits, int edigits)
|
|
{
|
|
char *out;
|
|
char *digits;
|
|
int e;
|
|
char expchar, rchar;
|
|
format_token ft;
|
|
int w;
|
|
int d;
|
|
/* Number of digits before the decimal point. */
|
|
int nbefore;
|
|
/* Number of zeros after the decimal point. */
|
|
int nzero;
|
|
/* Number of digits after the decimal point. */
|
|
int nafter;
|
|
/* Number of zeros after the decimal point, whatever the precision. */
|
|
int nzero_real;
|
|
int leadzero;
|
|
int nblanks;
|
|
int i;
|
|
sign_t sign;
|
|
|
|
ft = f->format;
|
|
w = f->u.real.w;
|
|
d = f->u.real.d;
|
|
|
|
rchar = '5';
|
|
nzero_real = -1;
|
|
|
|
/* We should always know the field width and precision. */
|
|
if (d < 0)
|
|
internal_error (&dtp->common, "Unspecified precision");
|
|
|
|
sign = calculate_sign (dtp, sign_bit);
|
|
|
|
/* The following code checks the given string has punctuation in the correct
|
|
places. Uncomment if needed for debugging.
|
|
if (d != 0 && ((buffer[2] != '.' && buffer[2] != ',')
|
|
|| buffer[ndigits + 2] != 'e'))
|
|
internal_error (&dtp->common, "printf is broken"); */
|
|
|
|
/* Read the exponent back in. */
|
|
e = atoi (&buffer[ndigits + 3]) + 1;
|
|
|
|
/* Make sure zero comes out as 0.0e0. */
|
|
if (zero_flag)
|
|
{
|
|
e = 0;
|
|
if (compile_options.sign_zero == 1)
|
|
sign = calculate_sign (dtp, sign_bit);
|
|
else
|
|
sign = calculate_sign (dtp, 0);
|
|
|
|
/* Handle special cases. */
|
|
if (w == 0)
|
|
w = d + 2;
|
|
|
|
/* For this one we choose to not output a decimal point.
|
|
F95 10.5.1.2.1 */
|
|
if (w == 1 && ft == FMT_F)
|
|
{
|
|
out = write_block (dtp, w);
|
|
if (out == NULL)
|
|
return;
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *out4 = (gfc_char4_t *) out;
|
|
*out4 = '0';
|
|
return;
|
|
}
|
|
|
|
*out = '0';
|
|
return;
|
|
}
|
|
|
|
}
|
|
|
|
/* Normalize the fractional component. */
|
|
buffer[2] = buffer[1];
|
|
digits = &buffer[2];
|
|
|
|
/* Figure out where to place the decimal point. */
|
|
switch (ft)
|
|
{
|
|
case FMT_F:
|
|
if (d == 0 && e <= 0 && dtp->u.p.scale_factor == 0)
|
|
{
|
|
memmove (digits + 1, digits, ndigits - 1);
|
|
digits[0] = '0';
|
|
e++;
|
|
}
|
|
|
|
nbefore = e + dtp->u.p.scale_factor;
|
|
if (nbefore < 0)
|
|
{
|
|
nzero = -nbefore;
|
|
nzero_real = nzero;
|
|
if (nzero > d)
|
|
nzero = d;
|
|
nafter = d - nzero;
|
|
nbefore = 0;
|
|
}
|
|
else
|
|
{
|
|
nzero = 0;
|
|
nafter = d;
|
|
}
|
|
expchar = 0;
|
|
break;
|
|
|
|
case FMT_E:
|
|
case FMT_D:
|
|
i = dtp->u.p.scale_factor;
|
|
if (d <= 0 && i == 0)
|
|
{
|
|
generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
|
|
"greater than zero in format specifier 'E' or 'D'");
|
|
return;
|
|
}
|
|
if (i <= -d || i >= d + 2)
|
|
{
|
|
generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
|
|
"out of range in format specifier 'E' or 'D'");
|
|
return;
|
|
}
|
|
|
|
if (!zero_flag)
|
|
e -= i;
|
|
if (i < 0)
|
|
{
|
|
nbefore = 0;
|
|
nzero = -i;
|
|
nafter = d + i;
|
|
}
|
|
else if (i > 0)
|
|
{
|
|
nbefore = i;
|
|
nzero = 0;
|
|
nafter = (d - i) + 1;
|
|
}
|
|
else /* i == 0 */
|
|
{
|
|
nbefore = 0;
|
|
nzero = 0;
|
|
nafter = d;
|
|
}
|
|
|
|
if (ft == FMT_E)
|
|
expchar = 'E';
|
|
else
|
|
expchar = 'D';
|
|
break;
|
|
|
|
case FMT_EN:
|
|
/* The exponent must be a multiple of three, with 1-3 digits before
|
|
the decimal point. */
|
|
if (!zero_flag)
|
|
e--;
|
|
if (e >= 0)
|
|
nbefore = e % 3;
|
|
else
|
|
{
|
|
nbefore = (-e) % 3;
|
|
if (nbefore != 0)
|
|
nbefore = 3 - nbefore;
|
|
}
|
|
e -= nbefore;
|
|
nbefore++;
|
|
nzero = 0;
|
|
nafter = d;
|
|
expchar = 'E';
|
|
break;
|
|
|
|
case FMT_ES:
|
|
if (!zero_flag)
|
|
e--;
|
|
nbefore = 1;
|
|
nzero = 0;
|
|
nafter = d;
|
|
expchar = 'E';
|
|
break;
|
|
|
|
default:
|
|
/* Should never happen. */
|
|
internal_error (&dtp->common, "Unexpected format token");
|
|
}
|
|
|
|
/* Round the value. The value being rounded is an unsigned magnitude.
|
|
The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
|
|
switch (dtp->u.p.current_unit->round_status)
|
|
{
|
|
case ROUND_ZERO: /* Do nothing and truncation occurs. */
|
|
goto skip;
|
|
case ROUND_UP:
|
|
if (sign_bit)
|
|
goto skip;
|
|
rchar = '0';
|
|
break;
|
|
case ROUND_DOWN:
|
|
if (!sign_bit)
|
|
goto skip;
|
|
rchar = '0';
|
|
break;
|
|
case ROUND_NEAREST:
|
|
/* Round compatible unless there is a tie. A tie is a 5 with
|
|
all trailing zero's. */
|
|
i = nafter + nbefore;
|
|
if (digits[i] == '5')
|
|
{
|
|
for(i++ ; i < ndigits; i++)
|
|
{
|
|
if (digits[i] != '0')
|
|
goto do_rnd;
|
|
}
|
|
/* It is a tie so round to even. */
|
|
switch (digits[nafter + nbefore - 1])
|
|
{
|
|
case '1':
|
|
case '3':
|
|
case '5':
|
|
case '7':
|
|
case '9':
|
|
/* If odd, round away from zero to even. */
|
|
break;
|
|
default:
|
|
/* If even, skip rounding, truncate to even. */
|
|
goto skip;
|
|
}
|
|
}
|
|
/* Fall through. */
|
|
case ROUND_PROCDEFINED:
|
|
case ROUND_UNSPECIFIED:
|
|
case ROUND_COMPATIBLE:
|
|
rchar = '5';
|
|
/* Just fall through and do the actual rounding. */
|
|
}
|
|
|
|
do_rnd:
|
|
|
|
if (nbefore + nafter == 0)
|
|
{
|
|
ndigits = 0;
|
|
if (nzero_real == d && digits[0] >= rchar)
|
|
{
|
|
/* We rounded to zero but shouldn't have */
|
|
nzero--;
|
|
nafter = 1;
|
|
digits[0] = '1';
|
|
ndigits = 1;
|
|
}
|
|
}
|
|
else if (nbefore + nafter < ndigits)
|
|
{
|
|
ndigits = nbefore + nafter;
|
|
i = ndigits;
|
|
if (digits[i] >= rchar)
|
|
{
|
|
/* Propagate the carry. */
|
|
for (i--; i >= 0; i--)
|
|
{
|
|
if (digits[i] != '9')
|
|
{
|
|
digits[i]++;
|
|
break;
|
|
}
|
|
digits[i] = '0';
|
|
}
|
|
|
|
if (i < 0)
|
|
{
|
|
/* The carry overflowed. Fortunately we have some spare
|
|
space at the start of the buffer. We may discard some
|
|
digits, but this is ok because we already know they are
|
|
zero. */
|
|
digits--;
|
|
digits[0] = '1';
|
|
if (ft == FMT_F)
|
|
{
|
|
if (nzero > 0)
|
|
{
|
|
nzero--;
|
|
nafter++;
|
|
}
|
|
else
|
|
nbefore++;
|
|
}
|
|
else if (ft == FMT_EN)
|
|
{
|
|
nbefore++;
|
|
if (nbefore == 4)
|
|
{
|
|
nbefore = 1;
|
|
e += 3;
|
|
}
|
|
}
|
|
else
|
|
e++;
|
|
}
|
|
}
|
|
}
|
|
|
|
skip:
|
|
|
|
/* Calculate the format of the exponent field. */
|
|
if (expchar)
|
|
{
|
|
edigits = 1;
|
|
for (i = abs (e); i >= 10; i /= 10)
|
|
edigits++;
|
|
|
|
if (f->u.real.e < 0)
|
|
{
|
|
/* Width not specified. Must be no more than 3 digits. */
|
|
if (e > 999 || e < -999)
|
|
edigits = -1;
|
|
else
|
|
{
|
|
edigits = 4;
|
|
if (e > 99 || e < -99)
|
|
expchar = ' ';
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* Exponent width specified, check it is wide enough. */
|
|
if (edigits > f->u.real.e)
|
|
edigits = -1;
|
|
else
|
|
edigits = f->u.real.e + 2;
|
|
}
|
|
}
|
|
else
|
|
edigits = 0;
|
|
|
|
/* Zero values always output as positive, even if the value was negative
|
|
before rounding. */
|
|
for (i = 0; i < ndigits; i++)
|
|
{
|
|
if (digits[i] != '0')
|
|
break;
|
|
}
|
|
if (i == ndigits)
|
|
{
|
|
/* The output is zero, so set the sign according to the sign bit unless
|
|
-fno-sign-zero was specified. */
|
|
if (compile_options.sign_zero == 1)
|
|
sign = calculate_sign (dtp, sign_bit);
|
|
else
|
|
sign = calculate_sign (dtp, 0);
|
|
}
|
|
|
|
/* Pick a field size if none was specified. */
|
|
if (w <= 0)
|
|
w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
|
|
|
|
/* Work out how much padding is needed. */
|
|
nblanks = w - (nbefore + nzero + nafter + edigits + 1);
|
|
if (sign != S_NONE)
|
|
nblanks--;
|
|
|
|
if (dtp->u.p.g0_no_blanks)
|
|
{
|
|
w -= nblanks;
|
|
nblanks = 0;
|
|
}
|
|
|
|
/* Create the ouput buffer. */
|
|
out = write_block (dtp, w);
|
|
if (out == NULL)
|
|
return;
|
|
|
|
/* Check the value fits in the specified field width. */
|
|
if (nblanks < 0 || edigits == -1)
|
|
{
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *out4 = (gfc_char4_t *) out;
|
|
memset4 (out4, '*', w);
|
|
return;
|
|
}
|
|
star_fill (out, w);
|
|
return;
|
|
}
|
|
|
|
/* See if we have space for a zero before the decimal point. */
|
|
if (nbefore == 0 && nblanks > 0)
|
|
{
|
|
leadzero = 1;
|
|
nblanks--;
|
|
}
|
|
else
|
|
leadzero = 0;
|
|
|
|
/* For internal character(kind=4) units, we duplicate the code used for
|
|
regular output slightly modified. This needs to be maintained
|
|
consistent with the regular code that follows this block. */
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *out4 = (gfc_char4_t *) out;
|
|
/* Pad to full field width. */
|
|
|
|
if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
|
|
{
|
|
memset4 (out4, ' ', nblanks);
|
|
out4 += nblanks;
|
|
}
|
|
|
|
/* Output the initial sign (if any). */
|
|
if (sign == S_PLUS)
|
|
*(out4++) = '+';
|
|
else if (sign == S_MINUS)
|
|
*(out4++) = '-';
|
|
|
|
/* Output an optional leading zero. */
|
|
if (leadzero)
|
|
*(out4++) = '0';
|
|
|
|
/* Output the part before the decimal point, padding with zeros. */
|
|
if (nbefore > 0)
|
|
{
|
|
if (nbefore > ndigits)
|
|
{
|
|
i = ndigits;
|
|
memcpy4 (out4, digits, i);
|
|
ndigits = 0;
|
|
while (i < nbefore)
|
|
out4[i++] = '0';
|
|
}
|
|
else
|
|
{
|
|
i = nbefore;
|
|
memcpy4 (out4, digits, i);
|
|
ndigits -= i;
|
|
}
|
|
|
|
digits += i;
|
|
out4 += nbefore;
|
|
}
|
|
|
|
/* Output the decimal point. */
|
|
*(out4++) = dtp->u.p.current_unit->decimal_status
|
|
== DECIMAL_POINT ? '.' : ',';
|
|
|
|
/* Output leading zeros after the decimal point. */
|
|
if (nzero > 0)
|
|
{
|
|
for (i = 0; i < nzero; i++)
|
|
*(out4++) = '0';
|
|
}
|
|
|
|
/* Output digits after the decimal point, padding with zeros. */
|
|
if (nafter > 0)
|
|
{
|
|
if (nafter > ndigits)
|
|
i = ndigits;
|
|
else
|
|
i = nafter;
|
|
|
|
memcpy4 (out4, digits, i);
|
|
while (i < nafter)
|
|
out4[i++] = '0';
|
|
|
|
digits += i;
|
|
ndigits -= i;
|
|
out4 += nafter;
|
|
}
|
|
|
|
/* Output the exponent. */
|
|
if (expchar)
|
|
{
|
|
if (expchar != ' ')
|
|
{
|
|
*(out4++) = expchar;
|
|
edigits--;
|
|
}
|
|
#if HAVE_SNPRINTF
|
|
snprintf (buffer, size, "%+0*d", edigits, e);
|
|
#else
|
|
sprintf (buffer, "%+0*d", edigits, e);
|
|
#endif
|
|
memcpy4 (out4, buffer, edigits);
|
|
}
|
|
|
|
if (dtp->u.p.no_leading_blank)
|
|
{
|
|
out4 += edigits;
|
|
memset4 (out4, ' ' , nblanks);
|
|
dtp->u.p.no_leading_blank = 0;
|
|
}
|
|
return;
|
|
} /* End of character(kind=4) internal unit code. */
|
|
|
|
/* Pad to full field width. */
|
|
|
|
if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
|
|
{
|
|
memset (out, ' ', nblanks);
|
|
out += nblanks;
|
|
}
|
|
|
|
/* Output the initial sign (if any). */
|
|
if (sign == S_PLUS)
|
|
*(out++) = '+';
|
|
else if (sign == S_MINUS)
|
|
*(out++) = '-';
|
|
|
|
/* Output an optional leading zero. */
|
|
if (leadzero)
|
|
*(out++) = '0';
|
|
|
|
/* Output the part before the decimal point, padding with zeros. */
|
|
if (nbefore > 0)
|
|
{
|
|
if (nbefore > ndigits)
|
|
{
|
|
i = ndigits;
|
|
memcpy (out, digits, i);
|
|
ndigits = 0;
|
|
while (i < nbefore)
|
|
out[i++] = '0';
|
|
}
|
|
else
|
|
{
|
|
i = nbefore;
|
|
memcpy (out, digits, i);
|
|
ndigits -= i;
|
|
}
|
|
|
|
digits += i;
|
|
out += nbefore;
|
|
}
|
|
|
|
/* Output the decimal point. */
|
|
*(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
|
|
|
|
/* Output leading zeros after the decimal point. */
|
|
if (nzero > 0)
|
|
{
|
|
for (i = 0; i < nzero; i++)
|
|
*(out++) = '0';
|
|
}
|
|
|
|
/* Output digits after the decimal point, padding with zeros. */
|
|
if (nafter > 0)
|
|
{
|
|
if (nafter > ndigits)
|
|
i = ndigits;
|
|
else
|
|
i = nafter;
|
|
|
|
memcpy (out, digits, i);
|
|
while (i < nafter)
|
|
out[i++] = '0';
|
|
|
|
digits += i;
|
|
ndigits -= i;
|
|
out += nafter;
|
|
}
|
|
|
|
/* Output the exponent. */
|
|
if (expchar)
|
|
{
|
|
if (expchar != ' ')
|
|
{
|
|
*(out++) = expchar;
|
|
edigits--;
|
|
}
|
|
#if HAVE_SNPRINTF
|
|
snprintf (buffer, size, "%+0*d", edigits, e);
|
|
#else
|
|
sprintf (buffer, "%+0*d", edigits, e);
|
|
#endif
|
|
memcpy (out, buffer, edigits);
|
|
}
|
|
|
|
if (dtp->u.p.no_leading_blank)
|
|
{
|
|
out += edigits;
|
|
memset( out , ' ' , nblanks );
|
|
dtp->u.p.no_leading_blank = 0;
|
|
}
|
|
|
|
#undef STR
|
|
#undef STR1
|
|
#undef MIN_FIELD_WIDTH
|
|
}
|
|
|
|
|
|
/* Write "Infinite" or "Nan" as appropriate for the given format. */
|
|
|
|
static void
|
|
write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
|
|
{
|
|
char * p, fin;
|
|
int nb = 0;
|
|
|
|
if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
|
|
{
|
|
nb = f->u.real.w;
|
|
|
|
/* If the field width is zero, the processor must select a width
|
|
not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
|
|
|
|
if (nb == 0) nb = 4;
|
|
p = write_block (dtp, nb);
|
|
if (p == NULL)
|
|
return;
|
|
if (nb < 3)
|
|
{
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
memset4 (p4, '*', nb);
|
|
}
|
|
else
|
|
memset (p, '*', nb);
|
|
return;
|
|
}
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
memset4 (p4, ' ', nb);
|
|
}
|
|
else
|
|
memset(p, ' ', nb);
|
|
|
|
if (!isnan_flag)
|
|
{
|
|
if (sign_bit)
|
|
{
|
|
/* If the sign is negative and the width is 3, there is
|
|
insufficient room to output '-Inf', so output asterisks */
|
|
if (nb == 3)
|
|
{
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
memset4 (p4, '*', nb);
|
|
}
|
|
else
|
|
memset (p, '*', nb);
|
|
return;
|
|
}
|
|
/* The negative sign is mandatory */
|
|
fin = '-';
|
|
}
|
|
else
|
|
/* The positive sign is optional, but we output it for
|
|
consistency */
|
|
fin = '+';
|
|
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
if (nb > 8)
|
|
/* We have room, so output 'Infinity' */
|
|
memcpy4 (p4 + nb - 8, "Infinity", 8);
|
|
else
|
|
/* For the case of width equals 8, there is not enough room
|
|
for the sign and 'Infinity' so we go with 'Inf' */
|
|
memcpy4 (p4 + nb - 3, "Inf", 3);
|
|
|
|
if (nb < 9 && nb > 3)
|
|
/* Put the sign in front of Inf */
|
|
p4[nb - 4] = (gfc_char4_t) fin;
|
|
else if (nb > 8)
|
|
/* Put the sign in front of Infinity */
|
|
p4[nb - 9] = (gfc_char4_t) fin;
|
|
return;
|
|
}
|
|
|
|
if (nb > 8)
|
|
/* We have room, so output 'Infinity' */
|
|
memcpy(p + nb - 8, "Infinity", 8);
|
|
else
|
|
/* For the case of width equals 8, there is not enough room
|
|
for the sign and 'Infinity' so we go with 'Inf' */
|
|
memcpy(p + nb - 3, "Inf", 3);
|
|
|
|
if (nb < 9 && nb > 3)
|
|
p[nb - 4] = fin; /* Put the sign in front of Inf */
|
|
else if (nb > 8)
|
|
p[nb - 9] = fin; /* Put the sign in front of Infinity */
|
|
}
|
|
else
|
|
{
|
|
if (unlikely (is_char4_unit (dtp)))
|
|
{
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
memcpy4 (p4 + nb - 3, "NaN", 3);
|
|
}
|
|
else
|
|
memcpy(p + nb - 3, "NaN", 3);
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
|
|
|
|
/* Returns the value of 10**d. */
|
|
|
|
#define CALCULATE_EXP(x) \
|
|
inline static GFC_REAL_ ## x \
|
|
calculate_exp_ ## x (int d)\
|
|
{\
|
|
int i;\
|
|
GFC_REAL_ ## x r = 1.0;\
|
|
for (i = 0; i< (d >= 0 ? d : -d); i++)\
|
|
r *= 10;\
|
|
r = (d >= 0) ? r : 1.0 / r;\
|
|
return r;\
|
|
}
|
|
|
|
CALCULATE_EXP(4)
|
|
|
|
CALCULATE_EXP(8)
|
|
|
|
#ifdef HAVE_GFC_REAL_10
|
|
CALCULATE_EXP(10)
|
|
#endif
|
|
|
|
#ifdef HAVE_GFC_REAL_16
|
|
CALCULATE_EXP(16)
|
|
#endif
|
|
#undef CALCULATE_EXP
|
|
|
|
/* Generate corresponding I/O format for FMT_G and output.
|
|
The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
|
|
LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
|
|
|
|
Data Magnitude Equivalent Conversion
|
|
0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
|
|
m = 0 F(w-n).(d-1), n' '
|
|
0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
|
|
1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
|
|
10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
|
|
................ ..........
|
|
10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
|
|
m >= 10**d-0.5 Ew.d[Ee]
|
|
|
|
notes: for Gw.d , n' ' means 4 blanks
|
|
for Gw.dEe, n' ' means e+2 blanks */
|
|
|
|
#define OUTPUT_FLOAT_FMT_G(x) \
|
|
static void \
|
|
output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
|
|
GFC_REAL_ ## x m, char *buffer, size_t size, \
|
|
int sign_bit, bool zero_flag, int ndigits, int edigits) \
|
|
{ \
|
|
int e = f->u.real.e;\
|
|
int d = f->u.real.d;\
|
|
int w = f->u.real.w;\
|
|
fnode *newf;\
|
|
GFC_REAL_ ## x rexp_d;\
|
|
int low, high, mid;\
|
|
int ubound, lbound;\
|
|
char *p;\
|
|
int save_scale_factor, nb = 0;\
|
|
\
|
|
save_scale_factor = dtp->u.p.scale_factor;\
|
|
newf = (fnode *) get_mem (sizeof (fnode));\
|
|
\
|
|
rexp_d = calculate_exp_ ## x (-d);\
|
|
if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\
|
|
((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
|
|
{ \
|
|
newf->format = FMT_E;\
|
|
newf->u.real.w = w;\
|
|
newf->u.real.d = d;\
|
|
newf->u.real.e = e;\
|
|
nb = 0;\
|
|
goto finish;\
|
|
}\
|
|
\
|
|
mid = 0;\
|
|
low = 0;\
|
|
high = d + 1;\
|
|
lbound = 0;\
|
|
ubound = d + 1;\
|
|
\
|
|
while (low <= high)\
|
|
{ \
|
|
GFC_REAL_ ## x temp;\
|
|
mid = (low + high) / 2;\
|
|
\
|
|
temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
|
|
\
|
|
if (m < temp)\
|
|
{ \
|
|
ubound = mid;\
|
|
if (ubound == lbound + 1)\
|
|
break;\
|
|
high = mid - 1;\
|
|
}\
|
|
else if (m > temp)\
|
|
{ \
|
|
lbound = mid;\
|
|
if (ubound == lbound + 1)\
|
|
{ \
|
|
mid ++;\
|
|
break;\
|
|
}\
|
|
low = mid + 1;\
|
|
}\
|
|
else\
|
|
{\
|
|
mid++;\
|
|
break;\
|
|
}\
|
|
}\
|
|
\
|
|
if (e < 0)\
|
|
nb = 4;\
|
|
else\
|
|
nb = e + 2;\
|
|
\
|
|
newf->format = FMT_F;\
|
|
newf->u.real.w = f->u.real.w - nb;\
|
|
\
|
|
if (m == 0.0)\
|
|
newf->u.real.d = d - 1;\
|
|
else\
|
|
newf->u.real.d = - (mid - d - 1);\
|
|
\
|
|
dtp->u.p.scale_factor = 0;\
|
|
\
|
|
finish:\
|
|
output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
|
|
edigits);\
|
|
dtp->u.p.scale_factor = save_scale_factor;\
|
|
\
|
|
free (newf);\
|
|
\
|
|
if (nb > 0 && !dtp->u.p.g0_no_blanks)\
|
|
{\
|
|
p = write_block (dtp, nb);\
|
|
if (p == NULL)\
|
|
return;\
|
|
if (unlikely (is_char4_unit (dtp)))\
|
|
{\
|
|
gfc_char4_t *p4 = (gfc_char4_t *) p;\
|
|
memset4 (p4, ' ', nb);\
|
|
}\
|
|
else\
|
|
memset (p, ' ', nb);\
|
|
}\
|
|
}\
|
|
|
|
OUTPUT_FLOAT_FMT_G(4)
|
|
|
|
OUTPUT_FLOAT_FMT_G(8)
|
|
|
|
#ifdef HAVE_GFC_REAL_10
|
|
OUTPUT_FLOAT_FMT_G(10)
|
|
#endif
|
|
|
|
#ifdef HAVE_GFC_REAL_16
|
|
OUTPUT_FLOAT_FMT_G(16)
|
|
#endif
|
|
|
|
#undef OUTPUT_FLOAT_FMT_G
|
|
|
|
|
|
/* Define a macro to build code for write_float. */
|
|
|
|
/* Note: Before output_float is called, sprintf is used to print to buffer the
|
|
number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
|
|
(MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
|
|
before the decimal point.
|
|
|
|
# The result will always contain a decimal point, even if no
|
|
digits follow it
|
|
|
|
- The converted value is to be left adjusted on the field boundary
|
|
|
|
+ A sign (+ or -) always be placed before a number
|
|
|
|
MIN_FIELD_WIDTH minimum field width
|
|
|
|
* (ndigits-1) is used as the precision
|
|
|
|
e format: [-]d.ddde±dd where there is one digit before the
|
|
decimal-point character and the number of digits after it is
|
|
equal to the precision. The exponent always contains at least two
|
|
digits; if the value is zero, the exponent is 00. */
|
|
|
|
#ifdef HAVE_SNPRINTF
|
|
|
|
#define DTOA \
|
|
snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
|
|
"e", ndigits - 1, tmp);
|
|
|
|
#define DTOAL \
|
|
snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
|
|
"Le", ndigits - 1, tmp);
|
|
|
|
#else
|
|
|
|
#define DTOA \
|
|
sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
|
|
"e", ndigits - 1, tmp);
|
|
|
|
#define DTOAL \
|
|
sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
|
|
"Le", ndigits - 1, tmp);
|
|
|
|
#endif
|
|
|
|
#define WRITE_FLOAT(x,y)\
|
|
{\
|
|
GFC_REAL_ ## x tmp;\
|
|
tmp = * (GFC_REAL_ ## x *)source;\
|
|
sign_bit = __builtin_signbit (tmp);\
|
|
if (!isfinite (tmp))\
|
|
{ \
|
|
write_infnan (dtp, f, isnan (tmp), sign_bit);\
|
|
return;\
|
|
}\
|
|
tmp = sign_bit ? -tmp : tmp;\
|
|
zero_flag = (tmp == 0.0);\
|
|
\
|
|
DTOA ## y\
|
|
\
|
|
if (f->format != FMT_G)\
|
|
output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
|
|
edigits);\
|
|
else \
|
|
output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
|
|
zero_flag, ndigits, edigits);\
|
|
}\
|
|
|
|
/* Output a real number according to its format. */
|
|
|
|
static void
|
|
write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
{
|
|
|
|
#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
|
|
# define MIN_FIELD_WIDTH 46
|
|
#else
|
|
# define MIN_FIELD_WIDTH 31
|
|
#endif
|
|
#define STR(x) STR1(x)
|
|
#define STR1(x) #x
|
|
|
|
/* This must be large enough to accurately hold any value. */
|
|
char buffer[MIN_FIELD_WIDTH+1];
|
|
int sign_bit, ndigits, edigits;
|
|
bool zero_flag;
|
|
size_t size;
|
|
|
|
size = MIN_FIELD_WIDTH+1;
|
|
|
|
/* printf pads blanks for us on the exponent so we just need it big enough
|
|
to handle the largest number of exponent digits expected. */
|
|
edigits=4;
|
|
|
|
if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
|
|
|| ((f->format == FMT_D || f->format == FMT_E)
|
|
&& dtp->u.p.scale_factor != 0))
|
|
{
|
|
/* Always convert at full precision to avoid double rounding. */
|
|
ndigits = MIN_FIELD_WIDTH - 4 - edigits;
|
|
}
|
|
else
|
|
{
|
|
/* The number of digits is known, so let printf do the rounding. */
|
|
if (f->format == FMT_ES)
|
|
ndigits = f->u.real.d + 1;
|
|
else
|
|
ndigits = f->u.real.d;
|
|
if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
|
|
ndigits = MIN_FIELD_WIDTH - 4 - edigits;
|
|
}
|
|
|
|
switch (len)
|
|
{
|
|
case 4:
|
|
WRITE_FLOAT(4,)
|
|
break;
|
|
|
|
case 8:
|
|
WRITE_FLOAT(8,)
|
|
break;
|
|
|
|
#ifdef HAVE_GFC_REAL_10
|
|
case 10:
|
|
WRITE_FLOAT(10,L)
|
|
break;
|
|
#endif
|
|
#ifdef HAVE_GFC_REAL_16
|
|
case 16:
|
|
WRITE_FLOAT(16,L)
|
|
break;
|
|
#endif
|
|
default:
|
|
internal_error (NULL, "bad real kind");
|
|
}
|
|
}
|