-/* Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+/* 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 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
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, 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
GNU General Public License for more details.
-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, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+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"
char *out;
char *digits;
int e;
- char expchar;
+ char expchar, rchar;
format_token ft;
int w;
int d;
w = f->u.real.w;
d = f->u.real.d;
+ rchar = '5';
nzero_real = -1;
/* We should always know the field width and precision. */
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;
}
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)
{
internal_error (&dtp->common, "Unexpected format token");
}
- /* Round the value. */
+ /* 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] >= '5')
- {
- /* We rounded to zero but shouldn't have */
- nzero--;
- nafter = 1;
- digits[0] = '1';
- ndigits = 1;
- }
+ 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] >= '5')
+ if (digits[i] >= rchar)
{
/* Propagate the carry. */
for (i--; i >= 0; i--)
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. */
+ /* 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)
}
}
+ skip:
+
/* Calculate the format of the exponent field. */
if (expchar)
{
/* 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;
}
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)
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)
+ 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)))
{
- memset (p, '*',nb);
- return;
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, '*', nb);
}
+ else
+ memset (p, '*', nb);
+ return;
+ }
- 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)
- {
- 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;
+ 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' */
- memcpy(p + nb - 8, "Infinity", 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' */
- memcpy(p + nb - 3, "Inf", 3);
+ /* 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)
- p[nb - 4] = fin; /* Put the sign in front of Inf */
+ /* Put the sign in front of Inf */
+ p4[nb - 4] = (gfc_char4_t) fin;
else if (nb > 8)
- p[nb - 9] = fin; /* Put the sign in front of Infinity */
+ /* 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;
}
+ return;
}
+}
/* Returns the value of 10**d. */
int d = f->u.real.d;\
int w = f->u.real.w;\
fnode *newf;\
- GFC_REAL_ ## x exp_d;\
+ GFC_REAL_ ## x rexp_d;\
int low, high, mid;\
int ubound, lbound;\
char *p;\
save_scale_factor = dtp->u.p.scale_factor;\
newf = (fnode *) get_mem (sizeof (fnode));\
\
- exp_d = calculate_exp_ ## x (d);\
- if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
+ 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;\
GFC_REAL_ ## x temp;\
mid = (low + high) / 2;\
\
- temp = (calculate_exp_ ## x (mid) - \
- 5 * calculate_exp_ ## x (mid - d - 1)) / 10;\
+ temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
\
if (m < temp)\
{ \
edigits);\
dtp->u.p.scale_factor = save_scale_factor;\
\
- free_mem(newf);\
+ free (newf);\
\
if (nb > 0 && !dtp->u.p.g0_no_blanks)\
- { \
+ {\
p = write_block (dtp, nb);\
if (p == NULL)\
return;\
- memset (p, ' ', nb);\
+ if (unlikely (is_char4_unit (dtp)))\
+ {\
+ gfc_char4_t *p4 = (gfc_char4_t *) p;\
+ memset4 (p4, ' ', nb);\
+ }\
+ else\
+ memset (p, ' ', nb);\
}\
}\
#endif
+#if defined(GFC_REAL_16_IS_FLOAT128)
+#define DTOAQ \
+__qmath_(quadmath_flt128tostr) (buffer, size, ndigits - 1, tmp);
+#endif
+
#define WRITE_FLOAT(x,y)\
{\
GFC_REAL_ ## x tmp;\
return;\
}\
tmp = sign_bit ? -tmp : tmp;\
- if (f->u.real.d == 0 && f->format == FMT_F\
- && dtp->u.p.scale_factor == 0)\
- {\
- if (tmp < 0.5)\
- tmp = 0.0;\
- else if (tmp < 1.0)\
- tmp = 1.0;\
- }\
zero_flag = (tmp == 0.0);\
\
DTOA ## y\
write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
-#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
+#if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
# define MIN_FIELD_WIDTH 46
#else
# define MIN_FIELD_WIDTH 31
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
+# ifdef GFC_REAL_16_IS_FLOAT128
+ WRITE_FLOAT(16,Q)
+# else
WRITE_FLOAT(16,L)
+# endif
break;
#endif
default: