-/* 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. */
/* Handle special cases. */
if (w == 0)
- w = 2;
+ w = d + 2;
/* For this one we choose to not output a decimal point.
F95 10.5.1.2.1 */
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)
{
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)\
{ \
{\
GFC_REAL_ ## x tmp;\
tmp = * (GFC_REAL_ ## x *)source;\
- sign_bit = signbit (tmp);\
+ sign_bit = __builtin_signbit (tmp);\
if (!isfinite (tmp))\
{ \
write_infnan (dtp, f, isnan (tmp), sign_bit);\
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\
OSDN Git Service
