summaryrefslogtreecommitdiff
path: root/libgfortran/io/write_float.def
diff options
context:
space:
mode:
Diffstat (limited to 'libgfortran/io/write_float.def')
-rw-r--r--libgfortran/io/write_float.def1087
1 files changed, 1087 insertions, 0 deletions
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
new file mode 100644
index 000000000..b72cf9f56
--- /dev/null
+++ b/libgfortran/io/write_float.def
@@ -0,0 +1,1087 @@
+/* Copyright (C) 2007, 2008, 2009, 2010, 2011 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 try
+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;
+
+ /* 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 FAILURE;
+ }
+ if (i <= -d || i >= 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 -= 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;
+
+ /* 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. */
+ for (i = 0; i < ndigits; i++)
+ {
+ 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)
+ {
+ 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 ? '.' : ',';
+
+ /* 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 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 ? '.' : ',';
+
+ /* 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
+ 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)
+ {
+ 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) \
+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, pad = ' ';\
+ int save_scale_factor, nb = 0;\
+ try result;\
+\
+ 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 > 4)\
+ e = 4;\
+ if (e < 0)\
+ nb = 4;\
+ else\
+ nb = e + 2;\
+\
+ nb = nb >= w ? 0 : nb;\
+ 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:\
+ result = 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 (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)
+#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
+
+#if defined(GFC_REAL_16_IS_FLOAT128)
+#define DTOAQ \
+__qmath_(quadmath_snprintf) (buffer, sizeof buffer, \
+ "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+ "Qe", ndigits - 1, tmp);
+#endif
+
+#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);\
+\
+ 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 48
+#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:
+# 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");
+ }
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-17 05:06:53 +0000