1 /* Copyright (C) 2007-2014 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Write float code factoring to this file by Jerry DeLisle
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
30 { S_NONE, S_MINUS, S_PLUS }
33 /* Given a flag that indicates if a value is negative or not, return a
34 sign_t that gives the sign that we need to produce. */
37 calculate_sign (st_parameter_dt *dtp, int negative_flag)
44 switch (dtp->u.p.sign_status)
46 case SIGN_SP: /* Show sign. */
49 case SIGN_SS: /* Suppress sign. */
52 case SIGN_S: /* Processor defined. */
53 case SIGN_UNSPECIFIED:
54 s = options.optional_plus ? S_PLUS : S_NONE;
62 /* Determine the precision except for EN format. For G format,
63 determines an upper bound to be used for sizing the buffer. */
66 determine_precision (st_parameter_dt * dtp, const fnode * f, int len)
68 int precision = f->u.real.d;
74 precision += dtp->u.p.scale_factor;
77 /* Scale factor has no effect on output. */
81 /* See F2008 10.7.2.3.3.6 */
82 if (dtp->u.p.scale_factor <= 0)
83 precision += dtp->u.p.scale_factor - 1;
89 /* If the scale factor has a large negative value, we must do our
90 own rounding? Use ROUND='NEAREST', which should be what snprintf
93 (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
94 || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
95 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
97 /* Add extra guard digits up to at least full precision when we do
99 if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
100 && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
102 precision += 2 * len + 4;
111 /* Output a real number according to its format which is FMT_G free. */
114 output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
115 int nprinted, int precision, int sign_bit, bool zero_flag)
122 /* Number of digits before the decimal point. */
124 /* Number of zeros after the decimal point. */
126 /* Number of digits after the decimal point. */
130 int ndigits, edigits;
136 p = dtp->u.p.scale_factor;
140 /* We should always know the field width and precision. */
142 internal_error (&dtp->common, "Unspecified precision");
144 sign = calculate_sign (dtp, sign_bit);
146 /* Calculate total number of digits. */
148 ndigits = nprinted - 2;
150 ndigits = precision + 1;
152 /* Read the exponent back in. */
154 e = atoi (&buffer[ndigits + 3]) + 1;
158 /* Make sure zero comes out as 0.0e0. */
162 /* Normalize the fractional component. */
165 buffer[2] = buffer[1];
171 /* Figure out where to place the decimal point. */
175 nbefore = ndigits - precision;
176 /* Make sure the decimal point is a '.'; depending on the
177 locale, this might not be the case otherwise. */
178 digits[nbefore] = '.';
184 memmove (digits + nbefore, digits + nbefore + 1, p);
185 digits[nbefore + p] = '.';
195 if (nbefore + p >= 0)
198 memmove (digits + nbefore + p + 1, digits + nbefore + p, -p);
200 digits[nbefore] = '.';
205 nzero = -(nbefore + p);
206 memmove (digits + 1, digits, nbefore);
208 nafter = d + nbefore;
221 while (digits[0] == '0' && nbefore > 0)
229 /* If we need to do rounding ourselves, get rid of the dot by
230 moving the fractional part. */
231 if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
232 && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
233 memmove (digits + nbefore, digits + nbefore + 1, ndigits - nbefore);
238 i = dtp->u.p.scale_factor;
239 if (d <= 0 && p == 0)
241 generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
242 "greater than zero in format specifier 'E' or 'D'");
245 if (p <= -d || p >= d + 2)
247 generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
248 "out of range in format specifier 'E' or 'D'");
264 nafter = (d - p) + 1;
280 /* The exponent must be a multiple of three, with 1-3 digits before
281 the decimal point. */
290 nbefore = 3 - nbefore;
309 /* Should never happen. */
310 internal_error (&dtp->common, "Unexpected format token");
316 /* Round the value. The value being rounded is an unsigned magnitude. */
317 switch (dtp->u.p.current_unit->round_status)
319 /* For processor defined and unspecified rounding we use
320 snprintf to print the exact number of digits needed, and thus
321 let snprintf handle the rounding. On system claiming support
322 for IEEE 754, this ought to be round to nearest, ties to
323 even, corresponding to the Fortran ROUND='NEAREST'. */
324 case ROUND_PROCDEFINED:
325 case ROUND_UNSPECIFIED:
326 case ROUND_ZERO: /* Do nothing and truncation occurs. */
337 /* Round compatible unless there is a tie. A tie is a 5 with
338 all trailing zero's. */
339 i = nafter + nbefore;
340 if (digits[i] == '5')
342 for(i++ ; i < ndigits; i++)
344 if (digits[i] != '0')
347 /* It is a tie so round to even. */
348 switch (digits[nafter + nbefore - 1])
355 /* If odd, round away from zero to even. */
358 /* If even, skip rounding, truncate to even. */
363 /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
364 case ROUND_COMPATIBLE:
372 if (ft != FMT_F && w > 0 && d == 0 && p == 0)
374 /* Scan for trailing zeros to see if we really need to round it. */
375 for(i = nbefore + nafter; i < ndigits; i++)
377 if (digits[i] != '0')
384 if (nbefore + nafter == 0)
385 /* Handle the case Fw.0 and value < 1.0 */
388 if (digits[0] >= rchar)
390 /* We rounded to zero but shouldn't have */
397 else if (nbefore + nafter < ndigits)
399 i = ndigits = nbefore + nafter;
400 if (digits[i] >= rchar)
402 /* Propagate the carry. */
403 for (i--; i >= 0; i--)
405 if (digits[i] != '9')
415 /* The carry overflowed. Fortunately we have some spare
416 space at the start of the buffer. We may discard some
417 digits, but this is ok because we already know they are
431 else if (ft == FMT_EN)
448 /* Calculate the format of the exponent field. */
452 for (i = abs (e); i >= 10; i /= 10)
457 /* Width not specified. Must be no more than 3 digits. */
458 if (e > 999 || e < -999)
463 if (e > 99 || e < -99)
469 /* Exponent width specified, check it is wide enough. */
470 if (edigits > f->u.real.e)
473 edigits = f->u.real.e + 2;
479 /* Scan the digits string and count the number of zeros. If we make it
480 all the way through the loop, we know the value is zero after the
481 rounding completed above. */
483 for (i = 0; i < ndigits + hasdot; i++)
485 if (digits[i] == '.')
487 else if (digits[i] != '0')
491 /* To format properly, we need to know if the rounded result is zero and if
492 so, we set the zero_flag which may have been already set for
494 if (i == ndigits + hasdot)
497 /* The output is zero, so set the sign according to the sign bit unless
498 -fno-sign-zero was specified. */
499 if (compile_options.sign_zero == 1)
500 sign = calculate_sign (dtp, sign_bit);
502 sign = calculate_sign (dtp, 0);
505 /* Pick a field size if none was specified, taking into account small
506 values that may have been rounded to zero. */
510 w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
513 w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
518 /* Work out how much padding is needed. */
519 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
523 if (dtp->u.p.g0_no_blanks)
529 /* Create the ouput buffer. */
530 out = write_block (dtp, w);
534 /* Check the value fits in the specified field width. */
535 if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
537 if (unlikely (is_char4_unit (dtp)))
539 gfc_char4_t *out4 = (gfc_char4_t *) out;
540 memset4 (out4, '*', w);
547 /* See if we have space for a zero before the decimal point. */
548 if (nbefore == 0 && nblanks > 0)
556 /* For internal character(kind=4) units, we duplicate the code used for
557 regular output slightly modified. This needs to be maintained
558 consistent with the regular code that follows this block. */
559 if (unlikely (is_char4_unit (dtp)))
561 gfc_char4_t *out4 = (gfc_char4_t *) out;
562 /* Pad to full field width. */
564 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
566 memset4 (out4, ' ', nblanks);
570 /* Output the initial sign (if any). */
573 else if (sign == S_MINUS)
576 /* Output an optional leading zero. */
580 /* Output the part before the decimal point, padding with zeros. */
583 if (nbefore > ndigits)
586 memcpy4 (out4, digits, i);
594 memcpy4 (out4, digits, i);
602 /* Output the decimal point. */
603 *(out4++) = dtp->u.p.current_unit->decimal_status
604 == DECIMAL_POINT ? '.' : ',';
606 && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
607 || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
610 /* Output leading zeros after the decimal point. */
613 for (i = 0; i < nzero; i++)
617 /* Output digits after the decimal point, padding with zeros. */
620 if (nafter > ndigits)
625 memcpy4 (out4, digits, i);
634 /* Output the exponent. */
642 snprintf (buffer, size, "%+0*d", edigits, e);
643 memcpy4 (out4, buffer, edigits);
646 if (dtp->u.p.no_leading_blank)
649 memset4 (out4, ' ' , nblanks);
650 dtp->u.p.no_leading_blank = 0;
653 } /* End of character(kind=4) internal unit code. */
655 /* Pad to full field width. */
657 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
659 memset (out, ' ', nblanks);
663 /* Output the initial sign (if any). */
666 else if (sign == S_MINUS)
669 /* Output an optional leading zero. */
673 /* Output the part before the decimal point, padding with zeros. */
676 if (nbefore > ndigits)
679 memcpy (out, digits, i);
687 memcpy (out, digits, i);
695 /* Output the decimal point. */
696 *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
698 && (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED
699 || dtp->u.p.current_unit->round_status == ROUND_PROCDEFINED))
702 /* Output leading zeros after the decimal point. */
705 for (i = 0; i < nzero; i++)
709 /* Output digits after the decimal point, padding with zeros. */
712 if (nafter > ndigits)
717 memcpy (out, digits, i);
726 /* Output the exponent. */
734 snprintf (buffer, size, "%+0*d", edigits, e);
735 memcpy (out, buffer, edigits);
738 if (dtp->u.p.no_leading_blank)
741 memset( out , ' ' , nblanks );
742 dtp->u.p.no_leading_blank = 0;
749 /* Write "Infinite" or "Nan" as appropriate for the given format. */
752 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
759 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
761 sign = calculate_sign (dtp, sign_bit);
762 mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
766 /* If the field width is zero, the processor must select a width
767 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
769 if ((nb == 0) || dtp->u.p.g0_no_blanks)
774 nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
776 p = write_block (dtp, nb);
781 if (unlikely (is_char4_unit (dtp)))
783 gfc_char4_t *p4 = (gfc_char4_t *) p;
784 memset4 (p4, '*', nb);
791 if (unlikely (is_char4_unit (dtp)))
793 gfc_char4_t *p4 = (gfc_char4_t *) p;
794 memset4 (p4, ' ', nb);
803 /* If the sign is negative and the width is 3, there is
804 insufficient room to output '-Inf', so output asterisks */
807 if (unlikely (is_char4_unit (dtp)))
809 gfc_char4_t *p4 = (gfc_char4_t *) p;
810 memset4 (p4, '*', nb);
816 /* The negative sign is mandatory */
820 /* The positive sign is optional, but we output it for
824 if (unlikely (is_char4_unit (dtp)))
826 gfc_char4_t *p4 = (gfc_char4_t *) p;
829 /* We have room, so output 'Infinity' */
830 memcpy4 (p4 + nb - 8, "Infinity", 8);
832 /* For the case of width equals mark, there is not enough room
833 for the sign and 'Infinity' so we go with 'Inf' */
834 memcpy4 (p4 + nb - 3, "Inf", 3);
836 if (sign == S_PLUS || sign == S_MINUS)
838 if (nb < 9 && nb > 3)
839 /* Put the sign in front of Inf */
840 p4[nb - 4] = (gfc_char4_t) fin;
842 /* Put the sign in front of Infinity */
843 p4[nb - 9] = (gfc_char4_t) fin;
849 /* We have room, so output 'Infinity' */
850 memcpy(p + nb - 8, "Infinity", 8);
852 /* For the case of width equals 8, there is not enough room
853 for the sign and 'Infinity' so we go with 'Inf' */
854 memcpy(p + nb - 3, "Inf", 3);
856 if (sign == S_PLUS || sign == S_MINUS)
858 if (nb < 9 && nb > 3)
859 p[nb - 4] = fin; /* Put the sign in front of Inf */
861 p[nb - 9] = fin; /* Put the sign in front of Infinity */
866 if (unlikely (is_char4_unit (dtp)))
868 gfc_char4_t *p4 = (gfc_char4_t *) p;
869 memcpy4 (p4 + nb - 3, "NaN", 3);
872 memcpy(p + nb - 3, "NaN", 3);
879 /* Returns the value of 10**d. */
881 #define CALCULATE_EXP(x) \
882 static GFC_REAL_ ## x \
883 calculate_exp_ ## x (int d)\
886 GFC_REAL_ ## x r = 1.0;\
887 for (i = 0; i< (d >= 0 ? d : -d); i++)\
889 r = (d >= 0) ? r : 1.0 / r;\
897 #ifdef HAVE_GFC_REAL_10
901 #ifdef HAVE_GFC_REAL_16
907 /* Define a macro to build code for write_float. */
909 /* Note: Before output_float is called, snprintf is used to print to buffer the
910 number in the format +D.DDDDe+ddd.
912 # The result will always contain a decimal point, even if no
915 - The converted value is to be left adjusted on the field boundary
917 + A sign (+ or -) always be placed before a number
919 * prec is used as the precision
921 e format: [-]d.ddde±dd where there is one digit before the
922 decimal-point character and the number of digits after it is
923 equal to the precision. The exponent always contains at least two
924 digits; if the value is zero, the exponent is 00. */
927 #define TOKENPASTE(x, y) TOKENPASTE2(x, y)
928 #define TOKENPASTE2(x, y) x ## y
930 #define DTOA(suff,prec,val) TOKENPASTE(DTOA2,suff)(prec,val)
932 #define DTOA2(prec,val) \
933 snprintf (buffer, size, "%+-#.*e", (prec), (val))
935 #define DTOA2L(prec,val) \
936 snprintf (buffer, size, "%+-#.*Le", (prec), (val))
939 #if defined(GFC_REAL_16_IS_FLOAT128)
940 #define DTOA2Q(prec,val) \
941 __qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qe", (prec), (val))
944 #define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val)
946 /* For F format, we print to the buffer with f format. */
947 #define FDTOA2(prec,val) \
948 snprintf (buffer, size, "%+-#.*f", (prec), (val))
950 #define FDTOA2L(prec,val) \
951 snprintf (buffer, size, "%+-#.*Lf", (prec), (val))
954 #if defined(GFC_REAL_16_IS_FLOAT128)
955 #define FDTOA2Q(prec,val) \
956 __qmath_(quadmath_snprintf) (buffer, size, "%+-#.*Qf", \
961 #if defined(GFC_REAL_16_IS_FLOAT128)
962 #define ISFINITE2Q(val) finiteq(val)
964 #define ISFINITE2(val) isfinite(val)
965 #define ISFINITE2L(val) isfinite(val)
967 #define ISFINITE(suff,val) TOKENPASTE(ISFINITE2,suff)(val)
970 #if defined(GFC_REAL_16_IS_FLOAT128)
971 #define SIGNBIT2Q(val) signbitq(val)
973 #define SIGNBIT2(val) signbit(val)
974 #define SIGNBIT2L(val) signbit(val)
976 #define SIGNBIT(suff,val) TOKENPASTE(SIGNBIT2,suff)(val)
979 #if defined(GFC_REAL_16_IS_FLOAT128)
980 #define ISNAN2Q(val) isnanq(val)
982 #define ISNAN2(val) isnan(val)
983 #define ISNAN2L(val) isnan(val)
985 #define ISNAN(suff,val) TOKENPASTE(ISNAN2,suff)(val)
989 /* Generate corresponding I/O format for FMT_G and output.
990 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
991 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
993 Data Magnitude Equivalent Conversion
994 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
995 m = 0 F(w-n).(d-1), n' '
996 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
997 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
998 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
999 ................ ..........
1000 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
1001 m >= 10**d-0.5 Ew.d[Ee]
1003 notes: for Gw.d , n' ' means 4 blanks
1004 for Gw.dEe, n' ' means e+2 blanks
1005 for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2
1006 the asm volatile is required for 32-bit x86 platforms. */
1008 #define OUTPUT_FLOAT_FMT_G(x,y) \
1010 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
1011 GFC_REAL_ ## x m, char *buffer, size_t size, \
1012 int sign_bit, bool zero_flag, int comp_d) \
1014 int e = f->u.real.e;\
1015 int d = f->u.real.d;\
1016 int w = f->u.real.w;\
1018 GFC_REAL_ ## x exp_d, r = 0.5, r_sc;\
1019 int low, high, mid;\
1020 int ubound, lbound;\
1021 char *p, pad = ' ';\
1022 int save_scale_factor, nb = 0;\
1024 int nprinted, precision;\
1025 volatile GFC_REAL_ ## x temp;\
1027 save_scale_factor = dtp->u.p.scale_factor;\
1029 switch (dtp->u.p.current_unit->round_status)\
1032 r = sign_bit ? 1.0 : 0.0;\
1044 exp_d = calculate_exp_ ## x (d);\
1045 r_sc = (1 - r / exp_d);\
1047 if ((m > 0.0 && ((m < temp) || (r >= (exp_d - m))))\
1048 || ((m == 0.0) && !(compile_options.allow_std\
1049 & (GFC_STD_F2003 | GFC_STD_F2008)))\
1052 newf.format = FMT_E;\
1054 newf.u.real.d = d - comp_d;\
1057 precision = determine_precision (dtp, &newf, x);\
1058 nprinted = DTOA(y,precision,m); \
1068 while (low <= high)\
1070 mid = (low + high) / 2;\
1072 temp = (calculate_exp_ ## x (mid - 1) * r_sc);\
1077 if (ubound == lbound + 1)\
1084 if (ubound == lbound + 1)\
1098 nb = e <= 0 ? 4 : e + 2;\
1099 nb = nb >= w ? w - 1 : nb;\
1100 newf.format = FMT_F;\
1101 newf.u.real.w = w - nb;\
1102 newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
1103 dtp->u.p.scale_factor = 0;\
1104 precision = determine_precision (dtp, &newf, x); \
1105 nprinted = FDTOA(y,precision,m); \
1108 result = output_float (dtp, &newf, buffer, size, nprinted, precision,\
1109 sign_bit, zero_flag);\
1110 dtp->u.p.scale_factor = save_scale_factor;\
1113 if (nb > 0 && !dtp->u.p.g0_no_blanks)\
1115 p = write_block (dtp, nb);\
1120 if (unlikely (is_char4_unit (dtp)))\
1122 gfc_char4_t *p4 = (gfc_char4_t *) p;\
1123 memset4 (p4, pad, nb);\
1126 memset (p, pad, nb);\
1130 OUTPUT_FLOAT_FMT_G(4,)
1132 OUTPUT_FLOAT_FMT_G(8,)
1134 #ifdef HAVE_GFC_REAL_10
1135 OUTPUT_FLOAT_FMT_G(10,L)
1138 #ifdef HAVE_GFC_REAL_16
1139 # ifdef GFC_REAL_16_IS_FLOAT128
1140 OUTPUT_FLOAT_FMT_G(16,Q)
1142 OUTPUT_FLOAT_FMT_G(16,L)
1146 #undef OUTPUT_FLOAT_FMT_G
1149 /* EN format is tricky since the number of significant digits depends
1150 on the magnitude. Solve it by first printing a temporary value and
1151 figure out the number of significant digits from the printed
1152 exponent. Values y, 0.95*10.0**e <= y <10.0**e, are rounded to
1153 10.0**e even when the final result will not be rounded to 10.0**e.
1154 For these values the exponent returned by atoi has to be decremented
1155 by one. The values y in the ranges
1156 (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
1157 (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
1158 (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
1159 are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)),
1160 100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0
1161 represents d zeroes, by the lines 279 to 297. */
1163 #define EN_PREC(x,y)\
1165 volatile GFC_REAL_ ## x tmp, one = 1.0;\
1166 tmp = * (GFC_REAL_ ## x *)source;\
1167 if (ISFINITE (y,tmp))\
1169 nprinted = DTOA(y,0,tmp);\
1170 int e = atoi (&buffer[4]);\
1171 if (buffer[1] == '1')\
1173 tmp = (calculate_exp_ ## x (-e)) * tmp;\
1174 tmp = one - (tmp < 0 ? -tmp : tmp); \
1180 nbefore = 3 + nbefore;\
1187 determine_en_precision (st_parameter_dt *dtp, const fnode *f,
1188 const char *source, int len)
1192 const size_t size = 10;
1193 int nbefore; /* digits before decimal point - 1. */
1205 #ifdef HAVE_GFC_REAL_10
1210 #ifdef HAVE_GFC_REAL_16
1212 # ifdef GFC_REAL_16_IS_FLOAT128
1220 internal_error (NULL, "bad real kind");
1226 int prec = f->u.real.d + nbefore;
1227 if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
1228 && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
1229 prec += 2 * len + 4;
1234 #define WRITE_FLOAT(x,y)\
1236 GFC_REAL_ ## x tmp;\
1237 tmp = * (GFC_REAL_ ## x *)source;\
1238 sign_bit = SIGNBIT (y,tmp);\
1239 if (!ISFINITE (y,tmp))\
1241 write_infnan (dtp, f, ISNAN (y,tmp), sign_bit);\
1244 tmp = sign_bit ? -tmp : tmp;\
1245 zero_flag = (tmp == 0.0);\
1246 if (f->format == FMT_G)\
1247 output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
1248 zero_flag, comp_d);\
1251 if (f->format == FMT_F)\
1252 nprinted = FDTOA(y,precision,tmp); \
1254 nprinted = DTOA(y,precision,tmp); \
1255 output_float (dtp, f, buffer, size, nprinted, precision,\
1256 sign_bit, zero_flag);\
1260 /* Output a real number according to its format. */
1263 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \
1264 int len, int comp_d)
1266 int sign_bit, nprinted;
1267 int precision; /* Precision for snprintf call. */
1270 if (f->format != FMT_EN)
1271 precision = determine_precision (dtp, f, len);
1273 precision = determine_en_precision (dtp, f, source, len);
1275 /* 4932 is the maximum exponent of long double and quad precision, 3
1276 extra characters for the sign, the decimal point, and the
1277 trailing null, and finally some extra digits depending on the
1278 requested precision. */
1279 const size_t size = 4932 + 3 + precision;
1280 #define BUF_STACK_SZ 5000
1281 char buf_stack[BUF_STACK_SZ];
1283 if (size > BUF_STACK_SZ)
1284 buffer = xmalloc (size);
1298 #ifdef HAVE_GFC_REAL_10
1303 #ifdef HAVE_GFC_REAL_16
1305 # ifdef GFC_REAL_16_IS_FLOAT128
1313 internal_error (NULL, "bad real kind");
1315 if (size > BUF_STACK_SZ)