1 /* Copyright (C
) 2007-2016 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
] = '.';
192 if (nbefore
+ p
>= 0)
195 memmove (digits
+ nbefore
+ p
+ 1, digits
+ nbefore
+ p
, -p
);
197 digits
[nbefore
] = '.';
202 nzero
= -(nbefore
+ p
);
203 memmove (digits
+ 1, digits
, nbefore
);
205 if (nafter
== 0 && d
> 0)
207 /* This is needed to get the correct rounding.
*/
208 memmove (digits
+ 1, digits
, ndigits
- 1);
215 /* Reset digits to
0 in order to get correct rounding
217 for (i
= 0; i
< ndigits
; i
++)
219 digits
[ndigits
- 1] = '1';
233 while (digits
[0] == '0' && nbefore
> 0)
241 /* If we need to do rounding ourselves
, get rid of the dot by
242 moving the fractional part.
*/
243 if (dtp
->u.p.current_unit
->round_status
!= ROUND_UNSPECIFIED
244 && dtp
->u.p.current_unit
->round_status
!= ROUND_PROCDEFINED
)
245 memmove (digits
+ nbefore
, digits
+ nbefore
+ 1, ndigits
- nbefore
);
250 i
= dtp
->u.p.scale_factor
;
251 if (d
<= 0 && p
== 0)
253 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Precision not "
254 "greater than zero in format specifier 'E' or 'D'");
257 if (p
<= -d || p
>= d
+ 2)
259 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Scale factor "
260 "out of range in format specifier 'E' or 'D'");
276 nafter
= (d
- p
) + 1;
292 /* The exponent must be a multiple of three
, with
1-3 digits before
293 the decimal point.
*/
302 nbefore
= 3 - nbefore
;
321 /* Should never happen.
*/
322 internal_error (&dtp
->common
, "Unexpected format token");
328 /* Round the value. The value being rounded is an unsigned magnitude.
*/
329 switch (dtp
->u.p.current_unit
->round_status
)
331 /* For processor defined and unspecified rounding we use
332 snprintf to print the exact number of digits needed
, and thus
333 let snprintf handle the rounding. On system claiming support
334 for IEEE
754, this ought to be round to nearest
, ties to
335 even
, corresponding to the Fortran ROUND
='NEAREST'.
*/
336 case ROUND_PROCDEFINED
:
337 case ROUND_UNSPECIFIED
:
338 case ROUND_ZERO
: /* Do nothing and truncation occurs.
*/
349 /* Round compatible unless there is a tie. A tie is a
5 with
350 all trailing zero
's. */
351 i = nafter + nbefore;
352 if (digits[i] == '5')
354 for(i++ ; i < ndigits; i++)
356 if (digits[i] != '0')
359 /* It is a tie so round to even. */
360 switch (digits[nafter + nbefore - 1])
367 /* If odd, round away from zero to even. */
370 /* If even, skip rounding, truncate to even. */
375 /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
376 case ROUND_COMPATIBLE:
384 if (ft != FMT_F && w > 0 && d == 0 && p == 0)
386 /* Scan for trailing zeros to see if we really need to round it. */
387 for(i = nbefore + nafter; i < ndigits; i++)
389 if (digits[i] != '0')
396 if (nbefore + nafter == 0)
397 /* Handle the case Fw.0 and value < 1.0 */
400 if (digits[0] >= rchar)
402 /* We rounded to zero but shouldn't have
*/
409 else
if (nbefore
+ nafter
< ndigits
)
411 i
= ndigits
= nbefore
+ nafter
;
412 if (digits
[i
] >= rchar
)
414 /* Propagate the carry.
*/
415 for (i
--; i
>= 0; i
--)
417 if (digits
[i
] != '9')
427 /* The carry overflowed. Fortunately we have some spare
428 space at the start of the buffer. We may discard some
429 digits
, but this is ok because we already know they are
443 else
if (ft
== FMT_EN
)
460 /* Calculate the format of the exponent field.
*/
461 if (expchar
&& !(dtp
->u.p.g0_no_blanks
&& e
== 0))
464 for (i
= abs (e
); i
>= 10; i
/= 10)
469 /* Width not specified. Must be no more than
3 digits.
*/
470 if (e
> 999 || e
< -999)
475 if (e
> 99 || e
< -99)
481 /* Exponent width specified
, check it is wide enough.
*/
482 if (edigits
> f
->u.real.e
)
485 edigits
= f
->u.real.e
+ 2;
491 /* Scan the digits string and count the number of zeros. If we make it
492 all the way through the loop
, we know the value is zero after the
493 rounding completed above.
*/
495 for (i
= 0; i
< ndigits
+ hasdot
; i
++)
497 if (digits
[i
] == '.')
499 else
if (digits
[i
] != '0')
503 /* To format properly
, we need to know if the rounded result is zero and if
504 so
, we set the zero_flag which may have been already set for
506 if (i
== ndigits
+ hasdot
)
509 /* The output is zero
, so set the sign according to the sign bit unless
510 -fno
-sign
-zero was specified.
*/
511 if (compile_options.sign_zero
== 1)
512 sign
= calculate_sign (dtp
, sign_bit
);
514 sign
= calculate_sign (dtp
, 0);
517 /* Pick a field size if none was specified
, taking into account small
518 values that may have been rounded to zero.
*/
522 w
= d
+ (sign
!= S_NONE ?
2 : 1) + (d
== 0 ?
1 : 0);
525 w
= nbefore
+ nzero
+ nafter
+ (sign
!= S_NONE ?
2 : 1);
530 /* Work out how much padding is needed.
*/
531 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
535 /* See if we have space for a zero before the decimal point.
*/
536 if (nbefore
== 0 && nblanks
> 0)
544 if (dtp
->u.p.g0_no_blanks
)
550 /* Create the ouput buffer.
*/
551 out
= write_block (dtp
, w
);
555 /* Check the value fits in the specified field width.
*/
556 if (nblanks
< 0 || edigits
== -1 || w
== 1 ||
(w
== 2 && sign
!= S_NONE
))
558 if (unlikely (is_char4_unit (dtp
)))
560 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
561 memset4 (out4
, '*', w
);
568 /* For internal
character(kind
=4) units
, we duplicate the code used for
569 regular output slightly modified. This needs to be maintained
570 consistent with the regular code that follows this block.
*/
571 if (unlikely (is_char4_unit (dtp
)))
573 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
574 /* Pad to full field width.
*/
576 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
578 memset4 (out4
, ' ', nblanks
);
582 /* Output the initial
sign (if any
).
*/
585 else
if (sign
== S_MINUS
)
588 /* Output an optional leading zero.
*/
592 /* Output the part before the decimal point
, padding with zeros.
*/
595 if (nbefore
> ndigits
)
598 memcpy4 (out4
, digits
, i
);
606 memcpy4 (out4
, digits
, i
);
614 /* Output the decimal point.
*/
615 *(out4
++) = dtp
->u.p.current_unit
->decimal_status
616 == DECIMAL_POINT ?
'.' : ',';
618 && (dtp
->u.p.current_unit
->round_status
== ROUND_UNSPECIFIED
619 || dtp
->u.p.current_unit
->round_status
== ROUND_PROCDEFINED
))
622 /* Output leading zeros after the decimal point.
*/
625 for (i
= 0; i
< nzero
; i
++)
629 /* Output digits after the decimal point
, padding with zeros.
*/
632 if (nafter
> ndigits
)
637 memcpy4 (out4
, digits
, i
);
646 /* Output the exponent.
*/
647 if (expchar
&& !(dtp
->u.p.g0_no_blanks
&& e
== 0))
654 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
655 memcpy4 (out4
, buffer
, edigits
);
658 if (dtp
->u.p.no_leading_blank
)
661 memset4 (out4
, ' ' , nblanks
);
662 dtp
->u.p.no_leading_blank
= 0;
665 } /* End of
character(kind
=4) internal unit code.
*/
667 /* Pad to full field width.
*/
669 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
671 memset (out
, ' ', nblanks
);
675 /* Output the initial
sign (if any
).
*/
678 else
if (sign
== S_MINUS
)
681 /* Output an optional leading zero.
*/
685 /* Output the part before the decimal point
, padding with zeros.
*/
688 if (nbefore
> ndigits
)
691 memcpy (out
, digits
, i
);
699 memcpy (out
, digits
, i
);
707 /* Output the decimal point.
*/
708 *(out
++) = dtp
->u.p.current_unit
->decimal_status
== DECIMAL_POINT ?
'.' : ',';
710 && (dtp
->u.p.current_unit
->round_status
== ROUND_UNSPECIFIED
711 || dtp
->u.p.current_unit
->round_status
== ROUND_PROCDEFINED
))
714 /* Output leading zeros after the decimal point.
*/
717 for (i
= 0; i
< nzero
; i
++)
721 /* Output digits after the decimal point
, padding with zeros.
*/
724 if (nafter
> ndigits
)
729 memcpy (out
, digits
, i
);
738 /* Output the exponent.
*/
739 if (expchar
&& !(dtp
->u.p.g0_no_blanks
&& e
== 0))
746 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
747 memcpy (out
, buffer
, edigits
);
750 if (dtp
->u.p.no_leading_blank
)
753 memset( out
, ' ' , nblanks
);
754 dtp
->u.p.no_leading_blank
= 0;
761 /* Write
"Infinite" or
"Nan" as appropriate for the given format.
*/
764 write_infnan (st_parameter_dt
*dtp
, const fnode
*f
, int isnan_flag
, int sign_bit
)
771 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
773 sign
= calculate_sign (dtp
, sign_bit
);
774 mark
= (sign
== S_PLUS || sign
== S_MINUS
) ?
8 : 7;
778 /* If the field width is zero
, the processor must select a width
779 not zero.
4 is chosen to allow output of
'-Inf' or
'+Inf' */
781 if ((nb
== 0) || dtp
->u.p.g0_no_blanks
)
786 nb
= (sign
== S_PLUS || sign
== S_MINUS
) ?
4 : 3;
788 p
= write_block (dtp
, nb
);
793 if (unlikely (is_char4_unit (dtp
)))
795 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
796 memset4 (p4
, '*', nb
);
803 if (unlikely (is_char4_unit (dtp
)))
805 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
806 memset4 (p4
, ' ', nb
);
815 /* If the sign is negative and the width is
3, there is
816 insufficient room to output
'-Inf', so output asterisks
*/
819 if (unlikely (is_char4_unit (dtp
)))
821 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
822 memset4 (p4
, '*', nb
);
828 /* The negative sign is mandatory
*/
832 /* The positive sign is optional
, but we output it for
836 if (unlikely (is_char4_unit (dtp
)))
838 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
841 /* We have room
, so output
'Infinity' */
842 memcpy4 (p4
+ nb
- 8, "Infinity", 8);
844 /* For the case of width equals mark
, there is not enough room
845 for the sign and
'Infinity' so we go with
'Inf' */
846 memcpy4 (p4
+ nb
- 3, "Inf", 3);
848 if (sign
== S_PLUS || sign
== S_MINUS
)
850 if (nb
< 9 && nb
> 3)
851 /* Put the sign in front of Inf
*/
852 p4
[nb
- 4] = (gfc_char4_t
) fin
;
854 /* Put the sign in front of Infinity
*/
855 p4
[nb
- 9] = (gfc_char4_t
) fin
;
861 /* We have room
, so output
'Infinity' */
862 memcpy(p
+ nb
- 8, "Infinity", 8);
864 /* For the case of width equals
8, there is not enough room
865 for the sign and
'Infinity' so we go with
'Inf' */
866 memcpy(p
+ nb
- 3, "Inf", 3);
868 if (sign
== S_PLUS || sign
== S_MINUS
)
870 if (nb
< 9 && nb
> 3)
871 p
[nb
- 4] = fin
; /* Put the sign in front of Inf
*/
873 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity
*/
878 if (unlikely (is_char4_unit (dtp
)))
880 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
881 memcpy4 (p4
+ nb
- 3, "NaN", 3);
884 memcpy(p
+ nb
- 3, "NaN", 3);
891 /* Returns the value of
10**d.
*/
893 #define
CALCULATE_EXP(x
) \
894 static GFC_REAL_ ## x \
895 calculate_exp_ ##
x (int d
)\
898 GFC_REAL_ ## x r
= 1.0;\
899 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)\
901 r
= (d
>= 0) ? r
: 1.0 / r
;\
909 #ifdef HAVE_GFC_REAL_10
913 #ifdef HAVE_GFC_REAL_16
919 /* Define a macro to build code for write_float.
*/
921 /* Note
: Before output_float is called
, snprintf is used to print to buffer the
922 number in the format
+D.DDDDe
+ddd.
924 # The result will always contain a decimal point
, even if no
927 - The converted value is to be left adjusted on the field boundary
929 + A
sign (+ or
-) always be placed before a number
931 * prec is used as the precision
933 e format
: [-]d.ddde±dd where there is one digit before the
934 decimal
-point character and the number of digits after it is
935 equal to the precision. The exponent always contains at least two
936 digits
; if the value is zero
, the exponent is
00.
*/
939 #define
TOKENPASTE(x
, y
) TOKENPASTE2(x
, y
)
940 #define
TOKENPASTE2(x
, y
) x ## y
942 #define
DTOA(suff
,prec
,val
) TOKENPASTE(DTOA2
,suff
)(prec
,val
)
944 #define
DTOA2(prec
,val
) \
945 snprintf (buffer
, size
, "%+-#.*e", (prec
), (val
))
947 #define
DTOA2L(prec
,val
) \
948 snprintf (buffer
, size
, "%+-#.*Le", (prec
), (val
))
951 #if
defined(GFC_REAL_16_IS_FLOAT128
)
952 #define
DTOA2Q(prec
,val
) \
953 quadmath_snprintf (buffer
, size
, "%+-#.*Qe", (prec
), (val
))
956 #define
FDTOA(suff
,prec
,val
) TOKENPASTE(FDTOA2
,suff
)(prec
,val
)
958 /* For F format
, we print to the buffer with f format.
*/
959 #define
FDTOA2(prec
,val
) \
960 snprintf (buffer
, size
, "%+-#.*f", (prec
), (val
))
962 #define
FDTOA2L(prec
,val
) \
963 snprintf (buffer
, size
, "%+-#.*Lf", (prec
), (val
))
966 #if
defined(GFC_REAL_16_IS_FLOAT128
)
967 #define
FDTOA2Q(prec
,val
) \
968 quadmath_snprintf (buffer
, size
, "%+-#.*Qf", \
974 /* Generate corresponding I
/O format for FMT_G and output.
975 The rules to translate FMT_G to FMT_E or FMT_F from
DEC fortran
976 LRM (table
11-2, Chapter
11, "I/O Formatting", P11
-25) is
:
978 Data Magnitude Equivalent Conversion
979 0< m
< 0.1-0.5*10**(-d
-1) Ew.d
[Ee
]
980 m
= 0 F(w
-n
).
(d
-1), n
' '
981 0.1-0.5*10**(-d
-1)<= m
< 1-0.5*10**(-d
) F(w
-n
).d
, n
' '
982 1-0.5*10**(-d
)<= m
< 10-0.5*10**(-d
+1) F(w
-n
).
(d
-1), n
' '
983 10-0.5*10**(-d
+1)<= m
< 100-0.5*10**(-d
+2) F(w
-n
).
(d
-2), n
' '
984 ................ ..........
985 10**(d
-1)-0.5*10**(-1)<= m
<10**d
-0.5 F(w
-n
).0,n(' ')
986 m
>= 10**d
-0.5 Ew.d
[Ee
]
988 notes
: for Gw.d
, n
' ' means
4 blanks
989 for Gw.dEe
, n
' ' means e
+2 blanks
990 for rounding modes adjustment
, r
, See Fortran F2008
10.7.5.2.2
991 the asm volatile is required for
32-bit x86 platforms.
*/
993 #define
OUTPUT_FLOAT_FMT_G(x
,y
) \
995 output_float_FMT_G_ ##
x (st_parameter_dt
*dtp
, const fnode
*f
, \
996 GFC_REAL_ ## x m
, char
*buffer
, size_t size
, \
997 int sign_bit
, bool zero_flag
, int comp_d
) \
999 int e
= f
->u.real.e
;\
1000 int d
= f
->u.real.d
;\
1001 int w
= f
->u.real.w
;\
1003 GFC_REAL_ ## x exp_d
, r
= 0.5, r_sc
;\
1004 int low
, high
, mid
;\
1005 int ubound
, lbound
;\
1006 char
*p
, pad
= ' ';\
1007 int save_scale_factor
, nb
= 0;\
1009 int nprinted
, precision
;\
1010 volatile GFC_REAL_ ## x temp
;\
1012 save_scale_factor
= dtp
->u.p.scale_factor
;\
1014 switch (dtp
->u.p.current_unit
->round_status
)\
1017 r
= sign_bit ?
1.0 : 0.0;\
1029 exp_d
= calculate_exp_ ##
x (d
);\
1030 r_sc
= (1 - r
/ exp_d
);\
1032 if ((m
> 0.0 && ((m
< temp
) ||
(r
>= (exp_d
- m
))))\
1033 ||
((m
== 0.0) && !(compile_options.allow_std\
1034 & (GFC_STD_F2003 | GFC_STD_F2008
)))\
1037 newf.format
= FMT_E
;\
1039 newf.u.real.d
= d
- comp_d
;\
1042 precision
= determine_precision (dtp
, &newf
, x
);\
1043 nprinted
= DTOA(y
,precision
,m
); \
1053 while (low
<= high
)\
1055 mid
= (low
+ high
) / 2;\
1057 temp
= (calculate_exp_ ##
x (mid
- 1) * r_sc
);\
1062 if (ubound
== lbound
+ 1)\
1069 if (ubound
== lbound
+ 1)\
1083 nb
= e
<= 0 ?
4 : e
+ 2;\
1084 nb
= nb
>= w ? w
- 1 : nb
;\
1085 newf.format
= FMT_F
;\
1086 newf.u.real.w
= w
- nb
;\
1087 newf.u.real.d
= m
== 0.0 ? d
- 1 : -(mid
- d
- 1) ;\
1088 dtp
->u.p.scale_factor
= 0;\
1089 precision
= determine_precision (dtp
, &newf
, x
); \
1090 nprinted
= FDTOA(y
,precision
,m
); \
1093 result
= output_float (dtp
, &newf
, buffer
, size
, nprinted
, precision
,\
1094 sign_bit
, zero_flag
);\
1095 dtp
->u.p.scale_factor
= save_scale_factor
;\
1098 if (nb
> 0 && !dtp
->u.p.g0_no_blanks
)\
1100 p
= write_block (dtp
, nb
);\
1105 if (unlikely (is_char4_unit (dtp
)))\
1107 gfc_char4_t
*p4
= (gfc_char4_t *) p
;\
1108 memset4 (p4
, pad
, nb
);\
1111 memset (p
, pad
, nb
);\
1115 OUTPUT_FLOAT_FMT_G(4,)
1117 OUTPUT_FLOAT_FMT_G(8,)
1119 #ifdef HAVE_GFC_REAL_10
1120 OUTPUT_FLOAT_FMT_G(10,L
)
1123 #ifdef HAVE_GFC_REAL_16
1124 # ifdef GFC_REAL_16_IS_FLOAT128
1125 OUTPUT_FLOAT_FMT_G(16,Q
)
1127 OUTPUT_FLOAT_FMT_G(16,L
)
1131 #undef OUTPUT_FLOAT_FMT_G
1134 /* EN format is tricky since the number of significant digits depends
1135 on the magnitude. Solve it by first printing a temporary value and
1136 figure out the number of significant digits from the printed
1137 exponent. Values y
, 0.95*10.0**e
<= y
<10.0**e
, are rounded to
1138 10.0**e even when the final result will not be rounded to
10.0**e.
1139 For these values the exponent returned by atoi has to be decremented
1140 by one. The values y in the ranges
1141 (1000.0-0.5*10.0**(-d
))*10.0**(3*n
) <= y
< 10.0*(3*(n
+1))
1142 (100.0-0.5*10.0**(-d
))*10.0**(3*n
) <= y
< 10.0*(3*n
+2)
1143 (10.0-0.5*10.0**(-d
))*10.0**(3*n
) <= y
< 10.0*(3*n
+1)
1144 are correctly rounded respectively to
1.0..
.0*10.0*(3*(n
+1)),
1145 100.0..
.0*10.0*(3*n
), and
10.0..
.0*10.0*(3*n
), where
0..
.0
1146 represents d zeroes
, by the lines
279 to
297.
*/
1148 #define
EN_PREC(x
,y
)\
1150 volatile GFC_REAL_ ## x tmp
, one
= 1.0;\
1151 tmp
= * (GFC_REAL_ ## x *)source
;\
1152 if (isfinite (tmp
))\
1154 nprinted
= DTOA(y
,0,tmp
);\
1155 int e
= atoi (&buffer
[4]);\
1156 if (buffer
[1] == '1')\
1158 tmp
= (calculate_exp_ ##
x (-e
)) * tmp
;\
1159 tmp
= one
- (tmp
< 0 ?
-tmp
: tmp
); \
1165 nbefore
= 3 + nbefore
;\
1172 determine_en_precision (st_parameter_dt
*dtp
, const fnode
*f
,
1173 const char
*source
, int len
)
1177 const size_t size
= 10;
1178 int nbefore
; /* digits before decimal point
- 1.
*/
1190 #ifdef HAVE_GFC_REAL_10
1195 #ifdef HAVE_GFC_REAL_16
1197 # ifdef GFC_REAL_16_IS_FLOAT128
1205 internal_error (NULL
, "bad real kind");
1211 int prec
= f
->u.real.d
+ nbefore
;
1212 if (dtp
->u.p.current_unit
->round_status
!= ROUND_UNSPECIFIED
1213 && dtp
->u.p.current_unit
->round_status
!= ROUND_PROCDEFINED
)
1214 prec
+= 2 * len
+ 4;
1219 #define
WRITE_FLOAT(x
,y
)\
1221 GFC_REAL_ ## x tmp
;\
1222 tmp
= * (GFC_REAL_ ## x *)source
;\
1223 sign_bit
= signbit (tmp
);\
1224 if (!isfinite (tmp
))\
1226 write_infnan (dtp
, f
, isnan (tmp
), sign_bit
);\
1229 tmp
= sign_bit ?
-tmp
: tmp
;\
1230 zero_flag
= (tmp
== 0.0);\
1231 if (f
->format
== FMT_G
)\
1232 output_float_FMT_G_ ##
x (dtp
, f
, tmp
, buffer
, size
, sign_bit
, \
1233 zero_flag
, comp_d
);\
1236 if (f
->format
== FMT_F
)\
1237 nprinted
= FDTOA(y
,precision
,tmp
); \
1239 nprinted
= DTOA(y
,precision
,tmp
); \
1240 output_float (dtp
, f
, buffer
, size
, nprinted
, precision
,\
1241 sign_bit
, zero_flag
);\
1245 /* Output a real number according to its format.
*/
1248 write_float (st_parameter_dt
*dtp
, const fnode
*f
, const char
*source
, \
1249 int len
, int comp_d
)
1251 int sign_bit
, nprinted
;
1252 int precision
; /* Precision for snprintf call.
*/
1255 if (f
->format
!= FMT_EN
)
1256 precision
= determine_precision (dtp
, f
, len
);
1258 precision
= determine_en_precision (dtp
, f
, source
, len
);
1260 /* 4932 is the maximum exponent of long double and quad precision
, 3
1261 extra characters for the sign
, the decimal point
, and the
1262 trailing null
, and finally some extra digits depending on the
1263 requested precision.
*/
1264 const size_t size
= 4932 + 3 + precision
;
1265 #define BUF_STACK_SZ
5000
1266 char buf_stack
[BUF_STACK_SZ
];
1268 if (size
> BUF_STACK_SZ
)
1269 buffer
= xmalloc (size
);
1283 #ifdef HAVE_GFC_REAL_10
1288 #ifdef HAVE_GFC_REAL_16
1290 # ifdef GFC_REAL_16_IS_FLOAT128
1298 internal_error (NULL
, "bad real kind");
1300 if (size
> BUF_STACK_SZ
)