diff options
Diffstat (limited to 'gcc-4.8.1/libgfortran/io/write_float.def')
-rw-r--r-- | gcc-4.8.1/libgfortran/io/write_float.def | 1268 |
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"); - } -} |