aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/libgfortran/io/write_float.def
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.1/libgfortran/io/write_float.def')
-rw-r--r--gcc-4.8.1/libgfortran/io/write_float.def1268
1 files changed, 0 insertions, 1268 deletions
diff --git a/gcc-4.8.1/libgfortran/io/write_float.def b/gcc-4.8.1/libgfortran/io/write_float.def
deleted file mode 100644
index 5b76fd596..000000000
--- a/gcc-4.8.1/libgfortran/io/write_float.def
+++ /dev/null
@@ -1,1268 +0,0 @@
-/* Copyright (C) 2007-2013 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;
-}
-
-
-/* Determine the precision except for EN format. For G format,
- determines an upper bound to be used for sizing the buffer. */
-
-static int
-determine_precision (st_parameter_dt * dtp, const fnode * f, int len)
-{
- int precision = f->u.real.d;
-
- switch (f->format)
- {
- case FMT_F:
- case FMT_G:
- precision += dtp->u.p.scale_factor;
- break;
- case FMT_ES:
- /* Scale factor has no effect on output. */
- break;
- case FMT_E:
- case FMT_D:
- /* See F2008 10.7.2.3.3.6 */
- if (dtp->u.p.scale_factor <= 0)
- precision += dtp->u.p.scale_factor - 1;
- break;
- default:
- return -1;
- }
-
- /* If the scale factor has a large negative value, we must do our
- own rounding? Use ROUND='NEAREST', which should be what snprintf
- is using as well. */
- if (precision < 0 &&
- (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
- || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
- dtp->u.p.current_unit->round_status = ROUND_NEAREST;
-
- /* Add extra guard digits up to at least full precision when we do
- our own rounding. */
- if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
- && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
- {
- precision += 2 * len + 4;
- if (precision < 0)
- precision = 0;
- }
-
- return precision;
-}
-
-
-/* Output a real number according to its format which is FMT_G free. */
-
-static try
-output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
- int nprinted, int precision, int sign_bit, bool zero_flag)
-{
- char *out;
- char *digits;
- int e, w, d, p, i;
- char expchar, rchar;
- format_token ft;
- /* 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 ndigits, edigits;
- sign_t sign;
-
- ft = f->format;
- w = f->u.real.w;
- d = f->u.real.d;
- p = dtp->u.p.scale_factor;
-
- 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);
-
- /* Calculate total number of digits. */
- if (ft == FMT_F)
- ndigits = nprinted - 2;
- else
- ndigits = precision + 1;
-
- /* Read the exponent back in. */
- if (ft != FMT_F)
- e = atoi (&buffer[ndigits + 3]) + 1;
- else
- e = 0;
-
- /* Make sure zero comes out as 0.0e0. */
- if (zero_flag)
- e = 0;
-
- /* Normalize the fractional component. */
- if (ft != FMT_F)
- {
- buffer[2] = buffer[1];
- digits = &buffer[2];
- }
- else
- digits = &buffer[1];
-
- /* Figure out where to place the decimal point. */
- switch (ft)
- {
- case FMT_F:
- nbefore = ndigits - precision;
- /* Make sure the decimal point is a '.'; depending on the
- locale, this might not be the case otherwise. */
- digits[nbefore] = '.';
- if (p != 0)
- {
- if (p > 0)
- {
-
- memmove (digits + nbefore, digits + nbefore + 1, p);
- digits[nbefore + p] = '.';
- nbefore += p;
- nafter = d - p;
- if (nafter < 0)
- nafter = 0;
- nafter = d;
- nzero = nzero_real = 0;
- }
- else /* p < 0 */
- {
- if (nbefore + p >= 0)
- {
- nzero = 0;
- memmove (digits + nbefore + p + 1, digits + nbefore + p, -p);
- nbefore += p;
- digits[nbefore] = '.';
- nafter = d;
- }
- else
- {
- nzero = -(nbefore + p);
- memmove (digits + 1, digits, nbefore);
- digits++;
- nafter = d + nbefore;
- nbefore = 0;
- }
- nzero_real = nzero;
- if (nzero > d)
- nzero = d;
- }
- }
- else
- {
- nzero = nzero_real = 0;
- nafter = d;
- }
-
- while (digits[0] == '0' && nbefore > 0)
- {
- digits++;
- nbefore--;
- ndigits--;
- }
-
- expchar = 0;
- /* If we need to do rounding ourselves, get rid of the dot by
- moving the fractional part. */
- if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
- && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
- memmove (digits + nbefore, digits + nbefore + 1, ndigits - nbefore);
- break;
-
- case FMT_E:
- case FMT_D:
- i = dtp->u.p.scale_factor;
- if (d <= 0 && p == 0)
- {
- generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
- "greater than zero in format specifier 'E' or 'D'");
- return FAILURE;
- }
- if (p <= -d || p >= d + 2)
- {
- generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
- "out of range in format specifier 'E' or 'D'");
- return FAILURE;
- }
-
- if (!zero_flag)
- e -= p;
- if (p < 0)
- {
- nbefore = 0;
- nzero = -p;
- nafter = d + p;
- }
- else if (p > 0)
- {
- nbefore = p;
- nzero = 0;
- nafter = (d - p) + 1;
- }
- else /* p == 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");
- }
-
- if (zero_flag)
- goto skip;
-
- /* Round the value. The value being rounded is an unsigned magnitude. */
- switch (dtp->u.p.current_unit->round_status)
- {
- /* For processor defined and unspecified rounding we use
- snprintf to print the exact number of digits needed, and thus
- let snprintf handle the rounding. On system claiming support
- for IEEE 754, this ought to be round to nearest, ties to
- even, corresponding to the Fortran ROUND='NEAREST'. */
- case ROUND_PROCDEFINED:
- case ROUND_UNSPECIFIED:
- case ROUND_ZERO: /* Do nothing and truncation occurs. */
- goto skip;
- case ROUND_UP:
- if (sign_bit)
- goto skip;
- goto updown;
- case ROUND_DOWN:
- if (!sign_bit)
- goto skip;
- goto updown;
- 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. */
- /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
- case ROUND_COMPATIBLE:
- rchar = '5';
- goto do_rnd;
- }
-
- updown:
-
- rchar = '0';
- if (w > 0 && d == 0 && p == 0)
- nbefore = 1;
- /* Scan for trailing zeros to see if we really need to round it. */
- for(i = nbefore + nafter; i < ndigits; i++)
- {
- if (digits[i] != '0')
- goto do_rnd;
- }
- goto skip;
-
- 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)
- {
- i = ndigits = nbefore + nafter;
- 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;
-
- /* Scan the digits string and count the number of zeros. If we make it
- all the way through the loop, we know the value is zero after the
- rounding completed above. */
- int hasdot = 0;
- for (i = 0; i < ndigits + hasdot; i++)
- {
- if (digits[i] == '.')
- hasdot = 1;
- else if (digits[i] != '0')
- break;
- }
-
- /* To format properly, we need to know if the rounded result is zero and if
- so, we set the zero_flag which may have been already set for
- actual zero. */
- if (i == ndigits + hasdot)
- {
- zero_flag = true;
- /* 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, taking into account small
- values that may have been rounded to zero. */
- if (w <= 0)
- {
- if (zero_flag)
- w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
- else
- {
- w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
- w = w == 1 ? 2 : w;
- }
- }
-
- /* 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 FAILURE;
-
- /* Check the value fits in the specified field width. */
- if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
- {
- if (unlikely (is_char4_unit (dtp)))
- {
- gfc_char4_t *out4 = (gfc_char4_t *) out;
- memset4 (out4, '*', w);
- return FAILURE;
- }
- star_fill (out, w);
- return FAILURE;
- }
-
- /* 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 ? '.' : ',';
- if (ft == FMT_F
- && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
- || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
- digits++;
-
- /* 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--;
- }
- snprintf (buffer, size, "%+0*d", edigits, e);
- memcpy4 (out4, buffer, edigits);
- }
-
- if (dtp->u.p.no_leading_blank)
- {
- out4 += edigits;
- memset4 (out4, ' ' , nblanks);
- dtp->u.p.no_leading_blank = 0;
- }
- return SUCCESS;
- } /* 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 ? '.' : ',';
- if (ft == FMT_F
- && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
- || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
- digits++;
-
- /* 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--;
- }
- snprintf (buffer, size, "%+0*d", edigits, e);
- memcpy (out, buffer, edigits);
- }
-
- if (dtp->u.p.no_leading_blank)
- {
- out += edigits;
- memset( out , ' ' , nblanks );
- dtp->u.p.no_leading_blank = 0;
- }
-
- return SUCCESS;
-}
-
-
-/* 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;
- sign_t sign;
- int mark;
-
- if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
- {
- sign = calculate_sign (dtp, sign_bit);
- mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
-
- 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) || dtp->u.p.g0_no_blanks)
- {
- if (isnan_flag)
- nb = 3;
- else
- nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
- }
- 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 > mark)
- /* We have room, so output 'Infinity' */
- memcpy4 (p4 + nb - 8, "Infinity", 8);
- else
- /* For the case of width equals mark, there is not enough room
- for the sign and 'Infinity' so we go with 'Inf' */
- memcpy4 (p4 + nb - 3, "Inf", 3);
-
- if (sign == S_PLUS || sign == S_MINUS)
- {
- 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 > mark)
- /* 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 (sign == S_PLUS || sign == S_MINUS)
- {
- 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) \
-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
-
-
-/* Define a macro to build code for write_float. */
-
- /* Note: Before output_float is called, snprintf is used to print to buffer the
- number in the format +D.DDDDe+ddd.
-
- # 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
-
- * prec 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. */
-
-
-#define TOKENPASTE(x, y) TOKENPASTE2(x, y)
-#define TOKENPASTE2(x, y) x ## y
-
-#define DTOA(suff,prec,val) TOKENPASTE(DTOA2,suff)(prec,val)
-
-#define DTOA2(prec,val) \
-snprintf (buffer, size, "%+-#.*e", (prec), (val))
-
-#define DTOA2L(prec,val) \
-snprintf (buffer, size, "%+-#.*Le", (prec), (val))
-
-
-#if defined(GFC_REAL_16_IS_FLOAT128)
-#define DTOA2Q(prec,val) \
-__qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qe", (prec), (val))
-#endif
-
-#define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val)
-
-/* For F format, we print to the buffer with f format. */
-#define FDTOA2(prec,val) \
-snprintf (buffer, size, "%+-#.*f", (prec), (val))
-
-#define FDTOA2L(prec,val) \
-snprintf (buffer, size, "%+-#.*Lf", (prec), (val))
-
-
-#if defined(GFC_REAL_16_IS_FLOAT128)
-#define FDTOA2Q(prec,val) \
-__qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qf", \
- (prec), (val))
-#endif
-
-
-/* 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
- for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2
- the asm volatile is required for 32-bit x86 platforms. */
-
-#define OUTPUT_FLOAT_FMT_G(x,y) \
-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 comp_d) \
-{ \
- 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, r = 0.5;\
- int low, high, mid;\
- int ubound, lbound;\
- char *p, pad = ' ';\
- int save_scale_factor, nb = 0;\
- try result;\
- int nprinted, precision;\
-\
- save_scale_factor = dtp->u.p.scale_factor;\
-\
- switch (dtp->u.p.current_unit->round_status)\
- {\
- case ROUND_ZERO:\
- r = sign_bit ? 1.0 : 0.0;\
- break;\
- case ROUND_UP:\
- r = 1.0;\
- break;\
- case ROUND_DOWN:\
- r = 0.0;\
- break;\
- default:\
- break;\
- }\
-\
- rexp_d = calculate_exp_ ## x (-d);\
- if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\
- || ((m == 0.0) && !(compile_options.allow_std\
- & (GFC_STD_F2003 | GFC_STD_F2008))))\
- { \
- newf.format = FMT_E;\
- newf.u.real.w = w;\
- newf.u.real.d = d - comp_d;\
- newf.u.real.e = e;\
- nb = 0;\
- precision = determine_precision (dtp, &newf, x);\
- nprinted = DTOA(y,precision,m); \
- goto finish;\
- }\
-\
- mid = 0;\
- low = 0;\
- high = d + 1;\
- lbound = 0;\
- ubound = d + 1;\
-\
- while (low <= high)\
- { \
- volatile GFC_REAL_ ## x temp;\
- mid = (low + high) / 2;\
-\
- temp = (calculate_exp_ ## x (mid - 1) * (1 - r * 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;\
- }\
- }\
-\
- nb = e <= 0 ? 4 : e + 2;\
- nb = nb >= w ? w - 1 : nb;\
- newf.format = FMT_F;\
- newf.u.real.w = w - nb;\
- newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
- dtp->u.p.scale_factor = 0;\
- precision = determine_precision (dtp, &newf, x); \
- nprinted = FDTOA(y,precision,m); \
-\
- finish:\
- result = output_float (dtp, &newf, buffer, size, nprinted, precision,\
- sign_bit, zero_flag);\
- dtp->u.p.scale_factor = save_scale_factor;\
-\
-\
- if (nb > 0 && !dtp->u.p.g0_no_blanks)\
- {\
- p = write_block (dtp, nb);\
- if (p == NULL)\
- return;\
- if (result == FAILURE)\
- pad = '*';\
- if (unlikely (is_char4_unit (dtp)))\
- {\
- gfc_char4_t *p4 = (gfc_char4_t *) p;\
- memset4 (p4, pad, nb);\
- }\
- else \
- memset (p, pad, nb);\
- }\
-}\
-
-OUTPUT_FLOAT_FMT_G(4,)
-
-OUTPUT_FLOAT_FMT_G(8,)
-
-#ifdef HAVE_GFC_REAL_10
-OUTPUT_FLOAT_FMT_G(10,L)
-#endif
-
-#ifdef HAVE_GFC_REAL_16
-# ifdef GFC_REAL_16_IS_FLOAT128
-OUTPUT_FLOAT_FMT_G(16,Q)
-#else
-OUTPUT_FLOAT_FMT_G(16,L)
-#endif
-#endif
-
-#undef OUTPUT_FLOAT_FMT_G
-
-
-/* EN format is tricky since the number of significant digits depends
- on the magnitude. Solve it by first printing a temporary value and
- figure out the number of significant digits from the printed
- exponent. */
-
-#define EN_PREC(x,y)\
-{\
- GFC_REAL_ ## x tmp; \
- tmp = * (GFC_REAL_ ## x *)source; \
- if (isfinite (tmp)) \
- nprinted = DTOA(y,0,tmp); \
- else\
- nprinted = -1;\
-}\
-
-static int
-determine_en_precision (st_parameter_dt *dtp, const fnode *f,
- const char *source, int len)
-{
- int nprinted;
- char buffer[10];
- const size_t size = 10;
-
- switch (len)
- {
- case 4:
- EN_PREC(4,)
- break;
-
- case 8:
- EN_PREC(8,)
- break;
-
-#ifdef HAVE_GFC_REAL_10
- case 10:
- EN_PREC(10,L)
- break;
-#endif
-#ifdef HAVE_GFC_REAL_16
- case 16:
-# ifdef GFC_REAL_16_IS_FLOAT128
- EN_PREC(16,Q)
-# else
- EN_PREC(16,L)
-# endif
- break;
-#endif
- default:
- internal_error (NULL, "bad real kind");
- }
-
- if (nprinted == -1)
- return -1;
-
- int e = atoi (&buffer[5]);
- int nbefore; /* digits before decimal point - 1. */
- if (e >= 0)
- nbefore = e % 3;
- else
- {
- nbefore = (-e) % 3;
- if (nbefore != 0)
- nbefore = 3 - nbefore;
- }
- int prec = f->u.real.d + nbefore;
- if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
- && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
- prec += 2 * len + 4;
- return prec;
-}
-
-
-#define WRITE_FLOAT(x,y)\
-{\
- GFC_REAL_ ## x tmp;\
- tmp = * (GFC_REAL_ ## x *)source;\
- sign_bit = signbit (tmp);\
- if (!isfinite (tmp))\
- { \
- write_infnan (dtp, f, isnan (tmp), sign_bit);\
- return;\
- }\
- tmp = sign_bit ? -tmp : tmp;\
- zero_flag = (tmp == 0.0);\
- if (f->format == FMT_G)\
- output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
- zero_flag, comp_d);\
- else\
- {\
- if (f->format == FMT_F)\
- nprinted = FDTOA(y,precision,tmp); \
- else\
- nprinted = DTOA(y,precision,tmp); \
- output_float (dtp, f, buffer, size, nprinted, precision,\
- sign_bit, zero_flag);\
- }\
-}\
-
-/* Output a real number according to its format. */
-
-static void
-write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \
- int len, int comp_d)
-{
- int sign_bit, nprinted;
- int precision; /* Precision for snprintf call. */
- bool zero_flag;
-
- if (f->format != FMT_EN)
- precision = determine_precision (dtp, f, len);
- else
- precision = determine_en_precision (dtp, f, source, len);
-
- /* 4932 is the maximum exponent of long double and quad precision, 3
- extra characters for the sign, the decimal point, and the
- trailing null, and finally some extra digits depending on the
- requested precision. */
- const size_t size = 4932 + 3 + precision;
- char buffer[size];
-
- 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:
-# ifdef GFC_REAL_16_IS_FLOAT128
- WRITE_FLOAT(16,Q)
-# else
- WRITE_FLOAT(16,L)
-# endif
- break;
-#endif
- default:
- internal_error (NULL, "bad real kind");
- }
-}