1 /* Copyright (C
) 2007-2024 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 /* Build a real number according to its format which is FMT_G free.
*/
114 build_float_string (st_parameter_dt
*dtp
, const fnode
*f
, char
*buffer
,
115 size_t size
, int nprinted
, int precision
, int sign_bit
,
116 bool zero_flag
, int npad
, int default_width
, char
*result
,
124 /* Number of digits before the decimal point.
*/
126 /* Number of zeros after the decimal point.
*/
128 /* Number of digits after the decimal point.
*/
132 int ndigits
, edigits
;
136 if (f
->u.real.w
== DEFAULT_WIDTH
)
137 /* This codepath can only be reached with
-fdec
-format
-defaults.
*/
147 p
= dtp
->u.p.scale_factor
;
152 /* We should always know the field width and precision.
*/
154 internal_error (&dtp
->common
, "Unspecified precision");
156 sign
= calculate_sign (dtp
, sign_bit
);
158 /* Calculate total number of digits.
*/
160 ndigits
= nprinted
- 2;
162 ndigits
= precision
+ 1;
164 /* Read the exponent back in.
*/
166 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
170 /* Make sure zero comes out as
0.0e0.
*/
174 /* Normalize the fractional component.
*/
177 buffer
[2] = buffer
[1];
183 /* Figure out where to place the decimal point.
*/
187 nbefore
= ndigits
- precision
;
188 if ((w
> 0) && (nbefore
> (int
) size
))
191 star_fill (result
, w
);
195 /* Make sure the decimal point is a
'.'; depending on the
196 locale
, this might not be the case otherwise.
*/
197 digits
[nbefore
] = '.';
202 memmove (digits
+ nbefore
, digits
+ nbefore
+ 1, p
);
203 digits
[nbefore
+ p
] = '.';
210 if (nbefore
+ p
>= 0)
213 memmove (digits
+ nbefore
+ p
+ 1, digits
+ nbefore
+ p
, -p
);
215 digits
[nbefore
] = '.';
220 nzero
= -(nbefore
+ p
);
221 memmove (digits
+ 1, digits
, nbefore
);
223 if (nafter
== 0 && d
> 0)
225 /* This is needed to get the correct rounding.
*/
226 memmove (digits
+ 1, digits
, ndigits
- 1);
233 /* Reset digits to
0 in order to get correct rounding
235 for (i
= 0; i
< ndigits
; i
++)
237 digits
[ndigits
- 1] = '1';
251 while (digits
[0] == '0' && nbefore
> 0)
259 /* If we need to do rounding ourselves
, get rid of the dot by
260 moving the fractional part.
*/
261 if (dtp
->u.p.current_unit
->round_status
!= ROUND_UNSPECIFIED
262 && dtp
->u.p.current_unit
->round_status
!= ROUND_PROCDEFINED
)
263 memmove (digits
+ nbefore
, digits
+ nbefore
+ 1, ndigits
- nbefore
);
268 i
= dtp
->u.p.scale_factor
;
271 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Precision not "
272 "greater than zero in format specifier 'E' or 'D'");
275 if (p
<= -d || p
>= d
+ 2)
277 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Scale factor "
278 "out of range in format specifier 'E' or 'D'");
294 nafter
= (d
- p
) + 1;
310 /* The exponent must be a multiple of three
, with
1-3 digits before
311 the decimal point.
*/
320 nbefore
= 3 - nbefore
;
339 /* Should never happen.
*/
340 internal_error (&dtp
->common
, "Unexpected format token");
346 /* Round the value. The value being rounded is an unsigned magnitude.
*/
347 switch (dtp
->u.p.current_unit
->round_status
)
349 /* For processor defined and unspecified rounding we use
350 snprintf to print the exact number of digits needed
, and thus
351 let snprintf handle the rounding. On system claiming support
352 for IEEE
754, this ought to be round to nearest
, ties to
353 even
, corresponding to the Fortran ROUND
='NEAREST'.
*/
354 case ROUND_PROCDEFINED
:
355 case ROUND_UNSPECIFIED
:
356 case ROUND_ZERO
: /* Do nothing and truncation occurs.
*/
367 /* Round compatible unless there is a tie. A tie is a
5 with
368 all trailing zero
's. */
369 i = nafter + nbefore;
370 if (digits[i] == '5')
372 for(i++ ; i < ndigits; i++)
374 if (digits[i] != '0')
377 /* It is a tie so round to even. */
378 switch (digits[nafter + nbefore - 1])
385 /* If odd, round away from zero to even. */
388 /* If even, skip rounding, truncate to even. */
393 /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
394 case ROUND_COMPATIBLE:
402 /* Do not reset nbefore for FMT_F and FMT_EN. */
403 if (ft != FMT_F && ft !=FMT_EN && w > 0 && d == 0 && p == 0)
405 /* Scan for trailing zeros to see if we really need to round it. */
406 for(i = nbefore + nafter; i < ndigits; i++)
408 if (digits[i] != '0')
415 if (nbefore + nafter == 0)
416 /* Handle the case Fw.0 and value < 1.0 */
419 if (digits[0] >= rchar)
421 /* We rounded to zero but shouldn't have
*/
428 else
if (nbefore
+ nafter
< ndigits
)
430 i
= ndigits
= nbefore
+ nafter
;
431 if (digits
[i
] >= rchar
)
433 /* Propagate the carry.
*/
434 for (i
--; i
>= 0; i
--)
436 if (digits
[i
] != '9')
446 /* The carry overflowed. Fortunately we have some spare
447 space at the start of the buffer. We may discard some
448 digits
, but this is ok because we already know they are
462 else
if (ft
== FMT_EN
)
479 /* Calculate the format of the exponent field. The number of exponent digits
480 required is needed to determine padding of the float string before the
481 expenent is written down.
*/
482 edigits
= 0; // Assume there is no exponent character set.
491 if (f
->pushed
== FMT_NONE
)
493 if (f
->u.real.e
== 0 && e
== 0)
498 else
if (f
->u.real.e
> 0)
499 edigits
= f
->u.real.e
+ 2;
503 if (!(dtp
->u.p.g0_no_blanks
&& e
== 0))
506 for (i
= abs (e
); i
>= 10; i
/= 10)
511 /* Width not specified. Must be no more than
3 digits.
*/
512 if (e
> 999 || e
< -999)
517 if (e
> 99 || e
< -99)
521 else
if (f
->u.real.e
== 0)
523 /* Zero width specified
, no leading zeros in exponent
*/
524 if (e
> 999 || e
< -999)
526 else
if (e
> 99 || e
< -99)
528 else
if (e
> 9 || e
< -9)
535 /* Exponent width specified
, check it is wide enough.
*/
536 if (edigits
> f
->u.real.e
)
539 edigits
= f
->u.real.e
+ 2;
544 /* Scan the digits string and count the number of zeros. If we make it
545 all the way through the loop
, we know the value is zero after the
546 rounding completed above.
*/
548 for (i
= 0; i
< ndigits
+ hasdot
; i
++)
550 if (digits
[i
] == '.')
552 else
if (digits
[i
] != '0')
556 /* To format properly
, we need to know if the rounded result is zero and if
557 so
, we set the zero_flag which may have been already set for
559 if (i
== ndigits
+ hasdot
)
562 /* The output is zero
, so set the sign according to the sign bit unless
563 -fno
-sign
-zero was specified.
*/
564 if (compile_options.sign_zero
== 1)
565 sign
= calculate_sign (dtp
, sign_bit
);
567 sign
= calculate_sign (dtp
, 0);
570 /* Pick a field size if none was specified
, taking into account small
571 values that may have been rounded to zero.
*/
575 w
= d
+ (sign
!= S_NONE ?
2 : 1) + (d
== 0 ?
1 : 0);
578 w
= nbefore
+ nzero
+ nafter
+ (sign
!= S_NONE ?
2 : 1);
583 /* Work out how much padding is needed.
*/
584 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
588 /* See if we have space for a zero before the decimal point.
*/
589 if (nbefore
== 0 && nblanks
> 0)
597 if (dtp
->u.p.g0_no_blanks
)
603 /* Create the final float string.
*/
607 /* Check the value fits in the specified field width.
*/
608 if (nblanks
< 0 || edigits
== -1 || w
== 1 ||
(w
== 2 && sign
!= S_NONE
))
610 star_fill (put
, *len
);
614 /* Pad to full field width.
*/
615 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
617 memset (put
, ' ', nblanks
);
621 /* Set the initial
sign (if any
).
*/
624 else
if (sign
== S_MINUS
)
627 /* Set an optional leading zero.
*/
631 /* Set the part before the decimal point
, padding with zeros.
*/
634 if (nbefore
> ndigits
)
637 memcpy (put
, digits
, i
);
645 memcpy (put
, digits
, i
);
653 /* Set the decimal point.
*/
654 *(put
++) = dtp
->u.p.current_unit
->decimal_status
== DECIMAL_POINT ?
'.' : ',';
656 && (dtp
->u.p.current_unit
->round_status
== ROUND_UNSPECIFIED
657 || dtp
->u.p.current_unit
->round_status
== ROUND_PROCDEFINED
))
660 /* Set leading zeros after the decimal point.
*/
663 for (i
= 0; i
< nzero
; i
++)
667 /* Set digits after the decimal point
, padding with zeros.
*/
668 if (ndigits
>= 0 && nafter
> 0)
670 if (nafter
> ndigits
)
676 memcpy (put
, digits
, i
);
685 /* Set the exponent.
*/
694 if (f
->pushed
== FMT_NONE
)
696 if ((f
->u.real.e
== 0) && (e
== 0))
700 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
701 memcpy (put
, buffer
, edigits
);
709 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
710 memcpy (put
, buffer
, edigits
);
717 if (!(dtp
->u.p.g0_no_blanks
&& e
== 0))
724 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
725 memcpy (put
, buffer
, edigits
);
731 if (dtp
->u.p.no_leading_blank
)
733 memset (put
, ' ' , nblanks
);
734 dtp
->u.p.no_leading_blank
= 0;
738 if (npad
> 0 && !dtp
->u.p.g0_no_blanks
)
740 memset (put
, ' ' , npad
);
744 /* NULL terminate the string.
*/
751 /* Write
"Infinite" or
"Nan" as appropriate for the given format.
*/
754 build_infnan_string (st_parameter_dt
*dtp
, const fnode
*f
, int isnan_flag
,
755 int sign_bit
, char
*p
, size_t
*len
)
762 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
764 sign
= calculate_sign (dtp
, sign_bit
);
765 mark
= (sign
== S_PLUS || sign
== S_MINUS
) ?
8 : 7;
770 /* If the field width is zero
, the processor must select a width
771 not zero.
4 is chosen to allow output of
'-Inf' or
'+Inf' */
773 if ((nb
== 0) || dtp
->u.p.g0_no_blanks
)
778 nb
= (sign
== S_PLUS || sign
== S_MINUS
) ?
4 : 3;
795 /* If the sign is negative and the width is
3, there is
796 insufficient room to output
'-Inf', so output asterisks
*/
802 /* The negative sign is mandatory
*/
806 /* The positive sign is optional
, but we output it for
811 /* We have room
, so output
'Infinity' */
812 memcpy(p
+ nb
- 8, "Infinity", 8);
814 /* For the case of width equals
8, there is not enough room
815 for the sign and
'Infinity' so we go with
'Inf' */
816 memcpy(p
+ nb
- 3, "Inf", 3);
818 if (sign
== S_PLUS || sign
== S_MINUS
)
820 if (nb
< 9 && nb
> 3)
821 p
[nb
- 4] = fin
; /* Put the sign in front of Inf
*/
823 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity
*/
827 memcpy(p
+ nb
- 3, "NaN", 3);
832 /* Returns the value of
10**d.
*/
834 #define
CALCULATE_EXP(x
) \
835 static GFC_REAL_ ## x \
836 calculate_exp_ ##
x (int d
)\
839 GFC_REAL_ ## x r
= 1.0;\
840 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)\
842 r
= (d
>= 0) ? r
: 1.0 / r
;\
850 #ifdef HAVE_GFC_REAL_10
854 #ifdef HAVE_GFC_REAL_16
858 #ifdef HAVE_GFC_REAL_17
864 /* Define macros to build code for format_float.
*/
866 /* Note
: Before output_float is called
, snprintf is used to print to buffer the
867 number in the format
+D.DDDDe
+ddd.
869 # The result will always contain a decimal point
, even if no
872 - The converted value is to be left adjusted on the field boundary
874 + A
sign (+ or
-) always be placed before a number
876 * prec is used as the precision
878 e format
: [-]d.ddde±dd where there is one digit before the
879 decimal
-point character and the number of digits after it is
880 equal to the precision. The exponent always contains at least two
881 digits
; if the value is zero
, the exponent is
00.
*/
884 #define
TOKENPASTE(x
, y
) TOKENPASTE2(x
, y
)
885 #define
TOKENPASTE2(x
, y
) x ## y
887 #define
DTOA(suff
,prec
,val
) TOKENPASTE(DTOA2
,suff
)(prec
,val
)
889 #define
DTOA2(prec
,val
) \
890 snprintf (buffer
, size
, "%+-#.*e", (prec
), (val
))
892 #define
DTOA2L(prec
,val
) \
893 snprintf (buffer
, size
, "%+-#.*Le", (prec
), (val
))
895 #if
defined(GFC_REAL_16_USE_IEC_60559
) ||
defined(GFC_REAL_17_USE_IEC_60559
)
896 /* strfromf128 unfortunately doesn
't allow +, - and # modifiers
897 nor .* (only allows .number). For +, work around it by adding
898 leading + manually for !signbit values. For - I don't see why
899 we need it
, when we don
't specify field minimum width.
900 For #, add . if it is missing. Assume size is at least 2. */
902 gfor_strfromf128 (char *buffer, size_t size, int kind, int prec, _Float128 val)
905 char fmt[sizeof (int) * 3 + 5];
906 snprintf (fmt, sizeof fmt, "%%.%d%c", prec, kind);
907 if (!__builtin_signbit (val))
912 ret = strfromf128 (buffer + n, size - n, fmt, val) + n;
913 if ((size_t) ret < size - 1)
915 size_t s = strcspn (buffer, ".e");
916 if (buffer[s] != '.
')
918 if (buffer[s] == '\
0')
919 buffer[s + 1] = '\
0';
921 memmove (buffer + s + 1, buffer + s, ret + 1 - s);
930 #if defined(HAVE_GFC_REAL_17)
931 # if defined(POWER_IEEE128)
932 # define DTOA2Q(prec,val) \
933 __snprintfieee128 (buffer, size, "%+-#.*Le", (prec), (val))
934 # elif defined(GFC_REAL_17_USE_IEC_60559)
935 # define DTOA2Q(prec,val) \
936 gfor_strfromf128 (buffer, size, 'e
', (prec), (val))
938 # define DTOA2Q(prec,val) \
939 quadmath_snprintf (buffer, size, "%+-#.*Qe", (prec), (val))
941 #elif defined(GFC_REAL_16_IS_FLOAT128)
942 # if defined(GFC_REAL_16_USE_IEC_60559)
943 # define DTOA2Q(prec,val) \
944 gfor_strfromf128 (buffer, size, 'e
', (prec), (val))
946 # define DTOA2Q(prec,val) \
947 quadmath_snprintf (buffer, size, "%+-#.*Qe", (prec), (val))
951 #define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val)
953 /* For F format, we print to the buffer with f format. */
954 #define FDTOA2(prec,val) \
955 snprintf (buffer, size, "%+-#.*f", (prec), (val))
957 #define FDTOA2L(prec,val) \
958 snprintf (buffer, size, "%+-#.*Lf", (prec), (val))
961 #if defined(HAVE_GFC_REAL_17)
962 # if defined(POWER_IEEE128)
963 # define FDTOA2Q(prec,val) \
964 __snprintfieee128 (buffer, size, "%+-#.*Lf", (prec), (val))
965 # elif defined(GFC_REAL_17_USE_IEC_60559)
966 # define FDTOA2Q(prec,val) \
967 gfor_strfromf128 (buffer, size, 'f
', (prec), (val))
969 # define FDTOA2Q(prec,val) \
970 quadmath_snprintf (buffer, size, "%+-#.*Qf", (prec), (val))
972 #elif defined(GFC_REAL_16_IS_FLOAT128)
973 # if defined(GFC_REAL_16_USE_IEC_60559)
974 # define FDTOA2Q(prec,val) \
975 gfor_strfromf128 (buffer, size, 'f
', (prec), (val))
977 # define FDTOA2Q(prec,val) \
978 quadmath_snprintf (buffer, size, "%+-#.*Qf", (prec), (val))
983 /* EN format is tricky since the number of significant digits depends
984 on the magnitude. Solve it by first printing a temporary value and
985 figure out the number of significant digits from the printed
986 exponent. Values y, 0.95*10.0**e <= y <10.0**e, are rounded to
987 10.0**e even when the final result will not be rounded to 10.0**e.
988 For these values the exponent returned by atoi has to be decremented
989 by one. The values y in the ranges
990 (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
991 (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
992 (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
993 are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)),
994 100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0
995 represents d zeroes, by the lines 279 to 297. */
996 #define EN_PREC(x,y)\
998 volatile GFC_REAL_ ## x tmp, one = 1.0;\
999 tmp = * (GFC_REAL_ ## x *)source;\
1000 if (isfinite (tmp))\
1002 nprinted = DTOA(y,0,tmp);\
1003 int e = atoi (&buffer[4]);\
1004 if (buffer[1] == '1')\
1006 tmp = (calculate_exp_ ## x (-e)) * tmp;\
1007 tmp = one - (tmp < 0 ? -tmp : tmp);\
1013 nbefore = 3 + nbefore;\
1020 determine_en_precision (st_parameter_dt *dtp, const fnode *f,
1021 const char *source, int len)
1025 const size_t size = 10;
1026 int nbefore; /* digits before decimal point - 1. */
1038 #ifdef HAVE_GFC_REAL_10
1043 #ifdef HAVE_GFC_REAL_16
1045 # ifdef GFC_REAL_16_IS_FLOAT128
1052 #ifdef HAVE_GFC_REAL_17
1058 internal_error (NULL, "bad real kind");
1064 int prec = f->u.real.d + nbefore;
1065 if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
1066 && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
1067 prec += 2 * len + 4;
1072 /* Generate corresponding I/O format. and output.
1073 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
1074 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
1076 Data Magnitude Equivalent Conversion
1077 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
1078 m = 0 F(w-n).(d-1), n' '
1079 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
1080 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
1081 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
1082 ................ ..........
1083 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
1084 m >= 10**d-0.5 Ew.d[Ee]
1086 notes: for Gw.d , n' ' means 4 blanks
1087 for Gw.dEe, n' ' means e+2 blanks
1088 for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2
1089 the asm volatile is required for 32-bit x86 platforms. */
1090 #define FORMAT_FLOAT(x,y)\
1094 m = * (GFC_REAL_ ## x *)source;\
1095 sign_bit = signbit (m);\
1098 build_infnan_string (dtp, f, isnan (m), sign_bit, result, res_len);\
1101 m = sign_bit ? -m : m;\
1102 zero_flag = (m == 0.0);\
1104 int e = f->u.real.e;\
1105 int d = f->u.real.d;\
1106 int w = f->u.real.w;\
1107 if (f->format == FMT_G)\
1109 GFC_REAL_ ## x exp_d, r = 0.5, r_sc;\
1110 int low, high, mid;\
1111 int ubound, lbound;\
1112 int save_scale_factor;\
1113 volatile GFC_REAL_ ## x temp;\
1114 save_scale_factor = dtp->u.p.scale_factor;\
1115 if (w == DEFAULT_WIDTH)\
1120 /* The switch between FMT_E and FMT_F is based on the absolute value. \
1121 Set r=0 for rounding toward zero and r = 1 otherwise. \
1122 If (exp_d - m) == 1 there is no rounding needed. */\
1123 switch (dtp->u.p.current_unit->round_status)\
1129 r = sign_bit ? 0.0 : 1.0;\
1132 r = sign_bit ? 1.0 : 0.0;\
1137 exp_d = calculate_exp_ ## x (d);\
1138 r_sc = (1 - r / exp_d);\
1140 if ((m > 0.0 && ((m < temp) || (r < 1 && r >= (exp_d - m))\
1141 || (r == 1 && 1 > (exp_d - m))))\
1142 || ((m == 0.0) && !(compile_options.allow_std\
1143 & (GFC_STD_F2003 | GFC_STD_F2008)))\
1146 newf.format = FMT_E;\
1148 newf.u.real.d = d - comp_d;\
1151 precision = determine_precision (dtp, &newf, x);\
1152 nprinted = DTOA(y,precision,m);\
1161 while (low <= high)\
1163 mid = (low + high) / 2;\
1164 temp = (calculate_exp_ ## x (mid - 1) * r_sc);\
1168 if (ubound == lbound + 1)\
1175 if (ubound == lbound + 1)\
1188 npad = e <= 0 ? 4 : e + 2;\
1189 npad = npad >= w ? w - 1 : npad;\
1190 npad = dtp->u.p.g0_no_blanks ? 0 : npad;\
1191 newf.format = FMT_F;\
1192 newf.u.real.w = w - npad;\
1193 newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
1194 dtp->u.p.scale_factor = 0;\
1195 precision = determine_precision (dtp, &newf, x);\
1196 nprinted = FDTOA(y,precision,m);\
1198 newf.pushed = FMT_G;\
1199 build_float_string (dtp, &newf, buffer, size, nprinted, precision,\
1200 sign_bit, zero_flag, npad, default_width,\
1202 dtp->u.p.scale_factor = save_scale_factor;\
1206 newf.format = f->format;\
1210 newf.pushed = FMT_NONE;\
1211 if (f->format == FMT_F)\
1212 nprinted = FDTOA(y,precision,m);\
1214 nprinted = DTOA(y,precision,m);\
1215 build_float_string (dtp, &newf, buffer, size, nprinted, precision,\
1216 sign_bit, zero_flag, npad, default_width,\
1221 /* Output a real number according to its format. */
1225 get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source,
1226 int kind, int comp_d, char *buffer, int precision,
1227 size_t size, char *result, size_t *res_len)
1229 int sign_bit, nprinted;
1231 int default_width = 0;
1233 if (f->u.real.w == DEFAULT_WIDTH)
1234 /* This codepath can only be reached with -fdec-format-defaults. The default
1235 * values are based on those used in the Oracle Fortran compiler.
1238 default_width = default_width_for_float (kind);
1239 precision = default_precision_for_float (kind);
1252 #ifdef HAVE_GFC_REAL_10
1257 #ifdef HAVE_GFC_REAL_16
1259 # ifdef GFC_REAL_16_IS_FLOAT128
1266 #ifdef HAVE_GFC_REAL_17
1272 internal_error (NULL, "bad real kind");