1 /* Copyright (C
) 2007-2022 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.
*/
480 if (expchar
&& !(dtp
->u.p.g0_no_blanks
&& e
== 0))
483 for (i
= abs (e
); i
>= 10; i
/= 10)
488 /* Width not specified. Must be no more than
3 digits.
*/
489 if (e
> 999 || e
< -999)
494 if (e
> 99 || e
< -99)
498 else
if (f
->u.real.e
== 0)
500 /* Zero width specified
, no leading zeros in exponent
*/
501 if (e
> 999 || e
< -999)
503 else
if (e
> 99 || e
< -99)
505 else
if (e
> 9 || e
< -9)
512 /* Exponent width specified
, check it is wide enough.
*/
513 if (edigits
> f
->u.real.e
)
516 edigits
= f
->u.real.e
+ 2;
522 /* Scan the digits string and count the number of zeros. If we make it
523 all the way through the loop
, we know the value is zero after the
524 rounding completed above.
*/
526 for (i
= 0; i
< ndigits
+ hasdot
; i
++)
528 if (digits
[i
] == '.')
530 else
if (digits
[i
] != '0')
534 /* To format properly
, we need to know if the rounded result is zero and if
535 so
, we set the zero_flag which may have been already set for
537 if (i
== ndigits
+ hasdot
)
540 /* The output is zero
, so set the sign according to the sign bit unless
541 -fno
-sign
-zero was specified.
*/
542 if (compile_options.sign_zero
== 1)
543 sign
= calculate_sign (dtp
, sign_bit
);
545 sign
= calculate_sign (dtp
, 0);
548 /* Pick a field size if none was specified
, taking into account small
549 values that may have been rounded to zero.
*/
553 w
= d
+ (sign
!= S_NONE ?
2 : 1) + (d
== 0 ?
1 : 0);
556 w
= nbefore
+ nzero
+ nafter
+ (sign
!= S_NONE ?
2 : 1);
561 /* Work out how much padding is needed.
*/
562 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
566 /* See if we have space for a zero before the decimal point.
*/
567 if (nbefore
== 0 && nblanks
> 0)
575 if (dtp
->u.p.g0_no_blanks
)
581 /* Create the final float string.
*/
585 /* Check the value fits in the specified field width.
*/
586 if (nblanks
< 0 || edigits
== -1 || w
== 1 ||
(w
== 2 && sign
!= S_NONE
))
588 star_fill (put
, *len
);
592 /* Pad to full field width.
*/
593 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
595 memset (put
, ' ', nblanks
);
599 /* Set the initial
sign (if any
).
*/
602 else
if (sign
== S_MINUS
)
605 /* Set an optional leading zero.
*/
609 /* Set the part before the decimal point
, padding with zeros.
*/
612 if (nbefore
> ndigits
)
615 memcpy (put
, digits
, i
);
623 memcpy (put
, digits
, i
);
631 /* Set the decimal point.
*/
632 *(put
++) = dtp
->u.p.current_unit
->decimal_status
== DECIMAL_POINT ?
'.' : ',';
634 && (dtp
->u.p.current_unit
->round_status
== ROUND_UNSPECIFIED
635 || dtp
->u.p.current_unit
->round_status
== ROUND_PROCDEFINED
))
638 /* Set leading zeros after the decimal point.
*/
641 for (i
= 0; i
< nzero
; i
++)
645 /* Set digits after the decimal point
, padding with zeros.
*/
646 if (ndigits
>= 0 && nafter
> 0)
648 if (nafter
> ndigits
)
654 memcpy (put
, digits
, i
);
663 /* Set the exponent.
*/
664 if (expchar
&& !(dtp
->u.p.g0_no_blanks
&& e
== 0))
671 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
672 memcpy (put
, buffer
, edigits
);
676 if (dtp
->u.p.no_leading_blank
)
678 memset (put
, ' ' , nblanks
);
679 dtp
->u.p.no_leading_blank
= 0;
683 if (npad
> 0 && !dtp
->u.p.g0_no_blanks
)
685 memset (put
, ' ' , npad
);
689 /* NULL terminate the string.
*/
696 /* Write
"Infinite" or
"Nan" as appropriate for the given format.
*/
699 build_infnan_string (st_parameter_dt
*dtp
, const fnode
*f
, int isnan_flag
,
700 int sign_bit
, char
*p
, size_t
*len
)
707 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
709 sign
= calculate_sign (dtp
, sign_bit
);
710 mark
= (sign
== S_PLUS || sign
== S_MINUS
) ?
8 : 7;
715 /* If the field width is zero
, the processor must select a width
716 not zero.
4 is chosen to allow output of
'-Inf' or
'+Inf' */
718 if ((nb
== 0) || dtp
->u.p.g0_no_blanks
)
723 nb
= (sign
== S_PLUS || sign
== S_MINUS
) ?
4 : 3;
740 /* If the sign is negative and the width is
3, there is
741 insufficient room to output
'-Inf', so output asterisks
*/
747 /* The negative sign is mandatory
*/
751 /* The positive sign is optional
, but we output it for
756 /* We have room
, so output
'Infinity' */
757 memcpy(p
+ nb
- 8, "Infinity", 8);
759 /* For the case of width equals
8, there is not enough room
760 for the sign and
'Infinity' so we go with
'Inf' */
761 memcpy(p
+ nb
- 3, "Inf", 3);
763 if (sign
== S_PLUS || sign
== S_MINUS
)
765 if (nb
< 9 && nb
> 3)
766 p
[nb
- 4] = fin
; /* Put the sign in front of Inf
*/
768 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity
*/
772 memcpy(p
+ nb
- 3, "NaN", 3);
777 /* Returns the value of
10**d.
*/
779 #define
CALCULATE_EXP(x
) \
780 static GFC_REAL_ ## x \
781 calculate_exp_ ##
x (int d
)\
784 GFC_REAL_ ## x r
= 1.0;\
785 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)\
787 r
= (d
>= 0) ? r
: 1.0 / r
;\
795 #ifdef HAVE_GFC_REAL_10
799 #ifdef HAVE_GFC_REAL_16
803 #ifdef HAVE_GFC_REAL_17
809 /* Define macros to build code for format_float.
*/
811 /* Note
: Before output_float is called
, snprintf is used to print to buffer the
812 number in the format
+D.DDDDe
+ddd.
814 # The result will always contain a decimal point
, even if no
817 - The converted value is to be left adjusted on the field boundary
819 + A
sign (+ or
-) always be placed before a number
821 * prec is used as the precision
823 e format
: [-]d.ddde±dd where there is one digit before the
824 decimal
-point character and the number of digits after it is
825 equal to the precision. The exponent always contains at least two
826 digits
; if the value is zero
, the exponent is
00.
*/
829 #define
TOKENPASTE(x
, y
) TOKENPASTE2(x
, y
)
830 #define
TOKENPASTE2(x
, y
) x ## y
832 #define
DTOA(suff
,prec
,val
) TOKENPASTE(DTOA2
,suff
)(prec
,val
)
834 #define
DTOA2(prec
,val
) \
835 snprintf (buffer
, size
, "%+-#.*e", (prec
), (val
))
837 #define
DTOA2L(prec
,val
) \
838 snprintf (buffer
, size
, "%+-#.*Le", (prec
), (val
))
840 #if
defined(GFC_REAL_16_USE_IEC_60559
) ||
defined(GFC_REAL_17_USE_IEC_60559
)
841 /* strfromf128 unfortunately doesn
't allow +, - and # modifiers
842 nor .* (only allows .number). For +, work around it by adding
843 leading + manually for !signbit values. For - I don't see why
844 we need it
, when we don
't specify field minimum width.
845 For #, add . if it is missing. Assume size is at least 2. */
847 gfor_strfromf128 (char *buffer, size_t size, int kind, int prec, _Float128 val)
850 char fmt[sizeof (int) * 3 + 5];
851 snprintf (fmt, sizeof fmt, "%%.%d%c", prec, kind);
852 if (!__builtin_signbit (val))
857 ret = strfromf128 (buffer + n, size - n, fmt, val) + n;
858 if ((size_t) ret < size - 1)
860 size_t s = strcspn (buffer, ".e");
861 if (buffer[s] != '.
')
863 if (buffer[s] == '\
0')
864 buffer[s + 1] = '\
0';
866 memmove (buffer + s + 1, buffer + s, ret + 1 - s);
875 #if defined(HAVE_GFC_REAL_17)
876 # if defined(POWER_IEEE128)
877 # define DTOA2Q(prec,val) \
878 __snprintfieee128 (buffer, size, "%+-#.*Le", (prec), (val))
879 # elif defined(GFC_REAL_17_USE_IEC_60559)
880 # define DTOA2Q(prec,val) \
881 gfor_strfromf128 (buffer, size, 'e
', (prec), (val))
883 # define DTOA2Q(prec,val) \
884 quadmath_snprintf (buffer, size, "%+-#.*Qe", (prec), (val))
886 #elif defined(GFC_REAL_16_IS_FLOAT128)
887 # if defined(GFC_REAL_16_USE_IEC_60559)
888 # define DTOA2Q(prec,val) \
889 gfor_strfromf128 (buffer, size, 'e
', (prec), (val))
891 # define DTOA2Q(prec,val) \
892 quadmath_snprintf (buffer, size, "%+-#.*Qe", (prec), (val))
896 #define FDTOA(suff,prec,val) TOKENPASTE(FDTOA2,suff)(prec,val)
898 /* For F format, we print to the buffer with f format. */
899 #define FDTOA2(prec,val) \
900 snprintf (buffer, size, "%+-#.*f", (prec), (val))
902 #define FDTOA2L(prec,val) \
903 snprintf (buffer, size, "%+-#.*Lf", (prec), (val))
906 #if defined(HAVE_GFC_REAL_17)
907 # if defined(POWER_IEEE128)
908 # define FDTOA2Q(prec,val) \
909 __snprintfieee128 (buffer, size, "%+-#.*Lf", (prec), (val))
910 # elif defined(GFC_REAL_17_USE_IEC_60559)
911 # define FDTOA2Q(prec,val) \
912 gfor_strfromf128 (buffer, size, 'f
', (prec), (val))
914 # define FDTOA2Q(prec,val) \
915 quadmath_snprintf (buffer, size, "%+-#.*Qf", (prec), (val))
917 #elif defined(GFC_REAL_16_IS_FLOAT128)
918 # if defined(GFC_REAL_16_USE_IEC_60559)
919 # define FDTOA2Q(prec,val) \
920 gfor_strfromf128 (buffer, size, 'f
', (prec), (val))
922 # define FDTOA2Q(prec,val) \
923 quadmath_snprintf (buffer, size, "%+-#.*Qf", (prec), (val))
928 /* EN format is tricky since the number of significant digits depends
929 on the magnitude. Solve it by first printing a temporary value and
930 figure out the number of significant digits from the printed
931 exponent. Values y, 0.95*10.0**e <= y <10.0**e, are rounded to
932 10.0**e even when the final result will not be rounded to 10.0**e.
933 For these values the exponent returned by atoi has to be decremented
934 by one. The values y in the ranges
935 (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
936 (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
937 (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
938 are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)),
939 100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0
940 represents d zeroes, by the lines 279 to 297. */
941 #define EN_PREC(x,y)\
943 volatile GFC_REAL_ ## x tmp, one = 1.0;\
944 tmp = * (GFC_REAL_ ## x *)source;\
947 nprinted = DTOA(y,0,tmp);\
948 int e = atoi (&buffer[4]);\
949 if (buffer[1] == '1')\
951 tmp = (calculate_exp_ ## x (-e)) * tmp;\
952 tmp = one - (tmp < 0 ? -tmp : tmp);\
958 nbefore = 3 + nbefore;\
965 determine_en_precision (st_parameter_dt *dtp, const fnode *f,
966 const char *source, int len)
970 const size_t size = 10;
971 int nbefore; /* digits before decimal point - 1. */
983 #ifdef HAVE_GFC_REAL_10
988 #ifdef HAVE_GFC_REAL_16
990 # ifdef GFC_REAL_16_IS_FLOAT128
997 #ifdef HAVE_GFC_REAL_17
1003 internal_error (NULL, "bad real kind");
1009 int prec = f->u.real.d + nbefore;
1010 if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED
1011 && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED)
1012 prec += 2 * len + 4;
1017 /* Generate corresponding I/O format. and output.
1018 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
1019 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
1021 Data Magnitude Equivalent Conversion
1022 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
1023 m = 0 F(w-n).(d-1), n' '
1024 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
1025 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
1026 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
1027 ................ ..........
1028 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
1029 m >= 10**d-0.5 Ew.d[Ee]
1031 notes: for Gw.d , n' ' means 4 blanks
1032 for Gw.dEe, n' ' means e+2 blanks
1033 for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2
1034 the asm volatile is required for 32-bit x86 platforms. */
1035 #define FORMAT_FLOAT(x,y)\
1039 m = * (GFC_REAL_ ## x *)source;\
1040 sign_bit = signbit (m);\
1043 build_infnan_string (dtp, f, isnan (m), sign_bit, result, res_len);\
1046 m = sign_bit ? -m : m;\
1047 zero_flag = (m == 0.0);\
1048 if (f->format == FMT_G)\
1050 int e = f->u.real.e;\
1051 int d = f->u.real.d;\
1052 int w = f->u.real.w;\
1054 GFC_REAL_ ## x exp_d, r = 0.5, r_sc;\
1055 int low, high, mid;\
1056 int ubound, lbound;\
1057 int save_scale_factor;\
1058 volatile GFC_REAL_ ## x temp;\
1059 save_scale_factor = dtp->u.p.scale_factor;\
1060 if (w == DEFAULT_WIDTH)\
1065 /* The switch between FMT_E and FMT_F is based on the absolute value. \
1066 Set r=0 for rounding toward zero and r = 1 otherwise. \
1067 If (exp_d - m) == 1 there is no rounding needed. */\
1068 switch (dtp->u.p.current_unit->round_status)\
1074 r = sign_bit ? 0.0 : 1.0;\
1077 r = sign_bit ? 1.0 : 0.0;\
1082 exp_d = calculate_exp_ ## x (d);\
1083 r_sc = (1 - r / exp_d);\
1085 if ((m > 0.0 && ((m < temp) || (r < 1 && r >= (exp_d - m))\
1086 || (r == 1 && 1 > (exp_d - m))))\
1087 || ((m == 0.0) && !(compile_options.allow_std\
1088 & (GFC_STD_F2003 | GFC_STD_F2008)))\
1091 newf.format = FMT_E;\
1093 newf.u.real.d = d - comp_d;\
1096 precision = determine_precision (dtp, &newf, x);\
1097 nprinted = DTOA(y,precision,m);\
1106 while (low <= high)\
1108 mid = (low + high) / 2;\
1109 temp = (calculate_exp_ ## x (mid - 1) * r_sc);\
1113 if (ubound == lbound + 1)\
1120 if (ubound == lbound + 1)\
1133 npad = e <= 0 ? 4 : e + 2;\
1134 npad = npad >= w ? w - 1 : npad;\
1135 npad = dtp->u.p.g0_no_blanks ? 0 : npad;\
1136 newf.format = FMT_F;\
1137 newf.u.real.w = w - npad;\
1138 newf.u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
1139 dtp->u.p.scale_factor = 0;\
1140 precision = determine_precision (dtp, &newf, x);\
1141 nprinted = FDTOA(y,precision,m);\
1143 build_float_string (dtp, &newf, buffer, size, nprinted, precision,\
1144 sign_bit, zero_flag, npad, default_width,\
1146 dtp->u.p.scale_factor = save_scale_factor;\
1150 if (f->format == FMT_F)\
1151 nprinted = FDTOA(y,precision,m);\
1153 nprinted = DTOA(y,precision,m);\
1154 build_float_string (dtp, f, buffer, size, nprinted, precision,\
1155 sign_bit, zero_flag, npad, default_width,\
1160 /* Output a real number according to its format. */
1164 get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source,
1165 int kind, int comp_d, char *buffer, int precision,
1166 size_t size, char *result, size_t *res_len)
1168 int sign_bit, nprinted;
1170 int default_width = 0;
1172 if (f->u.real.w == DEFAULT_WIDTH)
1173 /* This codepath can only be reached with -fdec-format-defaults. The default
1174 * values are based on those used in the Oracle Fortran compiler.
1177 default_width = default_width_for_float (kind);
1178 precision = default_precision_for_float (kind);
1191 #ifdef HAVE_GFC_REAL_10
1196 #ifdef HAVE_GFC_REAL_16
1198 # ifdef GFC_REAL_16_IS_FLOAT128
1205 #ifdef HAVE_GFC_REAL_17
1211 internal_error (NULL, "bad real kind");