1 /* Copyright (C
) 2007-2013 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.
*/
128 /* Number of zeros after the decimal point
, whatever the precision.
*/
132 int ndigits
, edigits
;
138 p
= dtp
->u.p.scale_factor
;
143 /* We should always know the field width and precision.
*/
145 internal_error (&dtp
->common
, "Unspecified precision");
147 sign
= calculate_sign (dtp
, sign_bit
);
149 /* Calculate total number of digits.
*/
151 ndigits
= nprinted
- 2;
153 ndigits
= precision
+ 1;
155 /* Read the exponent back in.
*/
157 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
161 /* Make sure zero comes out as
0.0e0.
*/
165 /* Normalize the fractional component.
*/
168 buffer
[2] = buffer
[1];
174 /* Figure out where to place the decimal point.
*/
178 nbefore
= ndigits
- precision
;
179 /* Make sure the decimal point is a
'.'; depending on the
180 locale
, this might not be the case otherwise.
*/
181 digits
[nbefore
] = '.';
187 memmove (digits
+ nbefore
, digits
+ nbefore
+ 1, p
);
188 digits
[nbefore
+ p
] = '.';
194 nzero
= nzero_real
= 0;
198 if (nbefore
+ p
>= 0)
201 memmove (digits
+ nbefore
+ p
+ 1, digits
+ nbefore
+ p
, -p
);
203 digits
[nbefore
] = '.';
208 nzero
= -(nbefore
+ p
);
209 memmove (digits
+ 1, digits
, nbefore
);
211 nafter
= d
+ nbefore
;
221 nzero
= nzero_real
= 0;
225 while (digits
[0] == '0' && nbefore
> 0)
233 /* If we need to do rounding ourselves
, get rid of the dot by
234 moving the fractional part.
*/
235 if (dtp
->u.p.current_unit
->round_status
!= ROUND_UNSPECIFIED
236 && dtp
->u.p.current_unit
->round_status
!= ROUND_PROCDEFINED
)
237 memmove (digits
+ nbefore
, digits
+ nbefore
+ 1, ndigits
- nbefore
);
242 i
= dtp
->u.p.scale_factor
;
243 if (d
<= 0 && p
== 0)
245 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Precision not "
246 "greater than zero in format specifier 'E' or 'D'");
249 if (p
<= -d || p
>= d
+ 2)
251 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Scale factor "
252 "out of range in format specifier 'E' or 'D'");
268 nafter
= (d
- p
) + 1;
284 /* The exponent must be a multiple of three
, with
1-3 digits before
285 the decimal point.
*/
294 nbefore
= 3 - nbefore
;
313 /* Should never happen.
*/
314 internal_error (&dtp
->common
, "Unexpected format token");
320 /* Round the value. The value being rounded is an unsigned magnitude.
*/
321 switch (dtp
->u.p.current_unit
->round_status
)
323 /* For processor defined and unspecified rounding we use
324 snprintf to print the exact number of digits needed
, and thus
325 let snprintf handle the rounding. On system claiming support
326 for IEEE
754, this ought to be round to nearest
, ties to
327 even
, corresponding to the Fortran ROUND
='NEAREST'.
*/
328 case ROUND_PROCDEFINED
:
329 case ROUND_UNSPECIFIED
:
330 case ROUND_ZERO
: /* Do nothing and truncation occurs.
*/
341 /* Round compatible unless there is a tie. A tie is a
5 with
342 all trailing zero
's. */
343 i = nafter + nbefore;
344 if (digits[i] == '5')
346 for(i++ ; i < ndigits; i++)
348 if (digits[i] != '0')
351 /* It is a tie so round to even. */
352 switch (digits[nafter + nbefore - 1])
359 /* If odd, round away from zero to even. */
362 /* If even, skip rounding, truncate to even. */
367 /* The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
368 case ROUND_COMPATIBLE:
376 if (w > 0 && d == 0 && p == 0)
378 /* Scan for trailing zeros to see if we really need to round it. */
379 for(i = nbefore + nafter; i < ndigits; i++)
381 if (digits[i] != '0')
388 if (nbefore + nafter == 0)
391 if (nzero_real == d && digits[0] >= rchar)
393 /* We rounded to zero but shouldn't have
*/
400 else
if (nbefore
+ nafter
< ndigits
)
402 i
= ndigits
= nbefore
+ nafter
;
403 if (digits
[i
] >= rchar
)
405 /* Propagate the carry.
*/
406 for (i
--; i
>= 0; i
--)
408 if (digits
[i
] != '9')
418 /* The carry overflowed. Fortunately we have some spare
419 space at the start of the buffer. We may discard some
420 digits
, but this is ok because we already know they are
434 else
if (ft
== FMT_EN
)
451 /* Calculate the format of the exponent field.
*/
455 for (i
= abs (e
); i
>= 10; i
/= 10)
460 /* Width not specified. Must be no more than
3 digits.
*/
461 if (e
> 999 || e
< -999)
466 if (e
> 99 || e
< -99)
472 /* Exponent width specified
, check it is wide enough.
*/
473 if (edigits
> f
->u.real.e
)
476 edigits
= f
->u.real.e
+ 2;
482 /* Scan the digits string and count the number of zeros. If we make it
483 all the way through the loop
, we know the value is zero after the
484 rounding completed above.
*/
486 for (i
= 0; i
< ndigits
+ hasdot
; i
++)
488 if (digits
[i
] == '.')
490 else
if (digits
[i
] != '0')
494 /* To format properly
, we need to know if the rounded result is zero and if
495 so
, we set the zero_flag which may have been already set for
497 if (i
== ndigits
+ hasdot
)
500 /* The output is zero
, so set the sign according to the sign bit unless
501 -fno
-sign
-zero was specified.
*/
502 if (compile_options.sign_zero
== 1)
503 sign
= calculate_sign (dtp
, sign_bit
);
505 sign
= calculate_sign (dtp
, 0);
508 /* Pick a field size if none was specified
, taking into account small
509 values that may have been rounded to zero.
*/
513 w
= d
+ (sign
!= S_NONE ?
2 : 1) + (d
== 0 ?
1 : 0);
516 w
= nbefore
+ nzero
+ nafter
+ (sign
!= S_NONE ?
2 : 1);
521 /* Work out how much padding is needed.
*/
522 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
526 if (dtp
->u.p.g0_no_blanks
)
532 /* Create the ouput buffer.
*/
533 out
= write_block (dtp
, w
);
537 /* Check the value fits in the specified field width.
*/
538 if (nblanks
< 0 || edigits
== -1 || w
== 1 ||
(w
== 2 && sign
!= S_NONE
))
540 if (unlikely (is_char4_unit (dtp
)))
542 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
543 memset4 (out4
, '*', w
);
550 /* See if we have space for a zero before the decimal point.
*/
551 if (nbefore
== 0 && nblanks
> 0)
559 /* For internal
character(kind
=4) units
, we duplicate the code used for
560 regular output slightly modified. This needs to be maintained
561 consistent with the regular code that follows this block.
*/
562 if (unlikely (is_char4_unit (dtp
)))
564 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
565 /* Pad to full field width.
*/
567 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
569 memset4 (out4
, ' ', nblanks
);
573 /* Output the initial
sign (if any
).
*/
576 else
if (sign
== S_MINUS
)
579 /* Output an optional leading zero.
*/
583 /* Output the part before the decimal point
, padding with zeros.
*/
586 if (nbefore
> ndigits
)
589 memcpy4 (out4
, digits
, i
);
597 memcpy4 (out4
, digits
, i
);
605 /* Output the decimal point.
*/
606 *(out4
++) = dtp
->u.p.current_unit
->decimal_status
607 == DECIMAL_POINT ?
'.' : ',';
609 && (dtp
->u.p.current_unit
->round_status
== ROUND_UNSPECIFIED
610 || dtp
->u.p.current_unit
->round_status
== ROUND_PROCDEFINED
))
613 /* Output leading zeros after the decimal point.
*/
616 for (i
= 0; i
< nzero
; i
++)
620 /* Output digits after the decimal point
, padding with zeros.
*/
623 if (nafter
> ndigits
)
628 memcpy4 (out4
, digits
, i
);
637 /* Output the exponent.
*/
645 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
646 memcpy4 (out4
, buffer
, edigits
);
649 if (dtp
->u.p.no_leading_blank
)
652 memset4 (out4
, ' ' , nblanks
);
653 dtp
->u.p.no_leading_blank
= 0;
656 } /* End of
character(kind
=4) internal unit code.
*/
658 /* Pad to full field width.
*/
660 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
662 memset (out
, ' ', nblanks
);
666 /* Output the initial
sign (if any
).
*/
669 else
if (sign
== S_MINUS
)
672 /* Output an optional leading zero.
*/
676 /* Output the part before the decimal point
, padding with zeros.
*/
679 if (nbefore
> ndigits
)
682 memcpy (out
, digits
, i
);
690 memcpy (out
, digits
, i
);
698 /* Output the decimal point.
*/
699 *(out
++) = dtp
->u.p.current_unit
->decimal_status
== DECIMAL_POINT ?
'.' : ',';
701 && (dtp
->u.p.current_unit
->round_status
== ROUND_UNSPECIFIED
702 || dtp
->u.p.current_unit
->round_status
== ROUND_PROCDEFINED
))
705 /* Output leading zeros after the decimal point.
*/
708 for (i
= 0; i
< nzero
; i
++)
712 /* Output digits after the decimal point
, padding with zeros.
*/
715 if (nafter
> ndigits
)
720 memcpy (out
, digits
, i
);
729 /* Output the exponent.
*/
737 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
738 memcpy (out
, buffer
, edigits
);
741 if (dtp
->u.p.no_leading_blank
)
744 memset( out
, ' ' , nblanks
);
745 dtp
->u.p.no_leading_blank
= 0;
752 /* Write
"Infinite" or
"Nan" as appropriate for the given format.
*/
755 write_infnan (st_parameter_dt
*dtp
, const fnode
*f
, int isnan_flag
, int sign_bit
)
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;
769 /* If the field width is zero
, the processor must select a width
770 not zero.
4 is chosen to allow output of
'-Inf' or
'+Inf' */
772 if ((nb
== 0) || dtp
->u.p.g0_no_blanks
)
777 nb
= (sign
== S_PLUS || sign
== S_MINUS
) ?
4 : 3;
779 p
= write_block (dtp
, nb
);
784 if (unlikely (is_char4_unit (dtp
)))
786 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
787 memset4 (p4
, '*', nb
);
794 if (unlikely (is_char4_unit (dtp
)))
796 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
797 memset4 (p4
, ' ', nb
);
806 /* If the sign is negative and the width is
3, there is
807 insufficient room to output
'-Inf', so output asterisks
*/
810 if (unlikely (is_char4_unit (dtp
)))
812 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
813 memset4 (p4
, '*', nb
);
819 /* The negative sign is mandatory
*/
823 /* The positive sign is optional
, but we output it for
827 if (unlikely (is_char4_unit (dtp
)))
829 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
832 /* We have room
, so output
'Infinity' */
833 memcpy4 (p4
+ nb
- 8, "Infinity", 8);
835 /* For the case of width equals mark
, there is not enough room
836 for the sign and
'Infinity' so we go with
'Inf' */
837 memcpy4 (p4
+ nb
- 3, "Inf", 3);
839 if (sign
== S_PLUS || sign
== S_MINUS
)
841 if (nb
< 9 && nb
> 3)
842 /* Put the sign in front of Inf
*/
843 p4
[nb
- 4] = (gfc_char4_t
) fin
;
845 /* Put the sign in front of Infinity
*/
846 p4
[nb
- 9] = (gfc_char4_t
) fin
;
852 /* We have room
, so output
'Infinity' */
853 memcpy(p
+ nb
- 8, "Infinity", 8);
855 /* For the case of width equals
8, there is not enough room
856 for the sign and
'Infinity' so we go with
'Inf' */
857 memcpy(p
+ nb
- 3, "Inf", 3);
859 if (sign
== S_PLUS || sign
== S_MINUS
)
861 if (nb
< 9 && nb
> 3)
862 p
[nb
- 4] = fin
; /* Put the sign in front of Inf
*/
864 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity
*/
869 if (unlikely (is_char4_unit (dtp
)))
871 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
872 memcpy4 (p4
+ nb
- 3, "NaN", 3);
875 memcpy(p
+ nb
- 3, "NaN", 3);
882 /* Returns the value of
10**d.
*/
884 #define
CALCULATE_EXP(x
) \
885 static GFC_REAL_ ## x \
886 calculate_exp_ ##
x (int d
)\
889 GFC_REAL_ ## x r
= 1.0;\
890 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)\
892 r
= (d
>= 0) ? r
: 1.0 / r
;\
900 #ifdef HAVE_GFC_REAL_10
904 #ifdef HAVE_GFC_REAL_16
910 /* Define a macro to build code for write_float.
*/
912 /* Note
: Before output_float is called
, snprintf is used to print to buffer the
913 number in the format
+D.DDDDe
+ddd.
915 # The result will always contain a decimal point
, even if no
918 - The converted value is to be left adjusted on the field boundary
920 + A
sign (+ or
-) always be placed before a number
922 * prec is used as the precision
924 e format
: [-]d.ddde±dd where there is one digit before the
925 decimal
-point character and the number of digits after it is
926 equal to the precision. The exponent always contains at least two
927 digits
; if the value is zero
, the exponent is
00.
*/
930 #define
TOKENPASTE(x
, y
) TOKENPASTE2(x
, y
)
931 #define
TOKENPASTE2(x
, y
) x ## y
933 #define
DTOA(suff
,prec
,val
) TOKENPASTE(DTOA2
,suff
)(prec
,val
)
935 #define
DTOA2(prec
,val
) \
936 snprintf (buffer
, size
, "%+-#.*e", (prec
), (val
))
938 #define
DTOA2L(prec
,val
) \
939 snprintf (buffer
, size
, "%+-#.*Le", (prec
), (val
))
942 #if
defined(GFC_REAL_16_IS_FLOAT128
)
943 #define
DTOA2Q(prec
,val
) \
944 __qmath_(quadmath_snprintf
) (buffer
, size
, "%+-#.*Qe", (prec
), (val
))
947 #define
FDTOA(suff
,prec
,val
) TOKENPASTE(FDTOA2
,suff
)(prec
,val
)
949 /* For F format
, we print to the buffer with f format.
*/
950 #define
FDTOA2(prec
,val
) \
951 snprintf (buffer
, size
, "%+-#.*f", (prec
), (val
))
953 #define
FDTOA2L(prec
,val
) \
954 snprintf (buffer
, size
, "%+-#.*Lf", (prec
), (val
))
957 #if
defined(GFC_REAL_16_IS_FLOAT128
)
958 #define
FDTOA2Q(prec
,val
) \
959 __qmath_(quadmath_snprintf
) (buffer
, size
, "%+-#.*Qf", \
964 #if
defined(GFC_REAL_16_IS_FLOAT128
)
965 #define
ISFINITE2Q(val
) finiteq(val
)
967 #define
ISFINITE2(val
) isfinite(val
)
968 #define
ISFINITE2L(val
) isfinite(val
)
970 #define
ISFINITE(suff
,val
) TOKENPASTE(ISFINITE2
,suff
)(val
)
973 #if
defined(GFC_REAL_16_IS_FLOAT128
)
974 #define
SIGNBIT2Q(val
) signbitq(val
)
976 #define
SIGNBIT2(val
) signbit(val
)
977 #define
SIGNBIT2L(val
) signbit(val
)
979 #define
SIGNBIT(suff
,val
) TOKENPASTE(SIGNBIT2
,suff
)(val
)
982 #if
defined(GFC_REAL_16_IS_FLOAT128
)
983 #define
ISNAN2Q(val
) isnanq(val
)
985 #define
ISNAN2(val
) isnan(val
)
986 #define
ISNAN2L(val
) isnan(val
)
988 #define
ISNAN(suff
,val
) TOKENPASTE(ISNAN2
,suff
)(val
)
992 /* Generate corresponding I
/O format for FMT_G and output.
993 The rules to translate FMT_G to FMT_E or FMT_F from
DEC fortran
994 LRM (table
11-2, Chapter
11, "I/O Formatting", P11
-25) is
:
996 Data Magnitude Equivalent Conversion
997 0< m
< 0.1-0.5*10**(-d
-1) Ew.d
[Ee
]
998 m
= 0 F(w
-n
).
(d
-1), n
' '
999 0.1-0.5*10**(-d
-1)<= m
< 1-0.5*10**(-d
) F(w
-n
).d
, n
' '
1000 1-0.5*10**(-d
)<= m
< 10-0.5*10**(-d
+1) F(w
-n
).
(d
-1), n
' '
1001 10-0.5*10**(-d
+1)<= m
< 100-0.5*10**(-d
+2) F(w
-n
).
(d
-2), n
' '
1002 ................ ..........
1003 10**(d
-1)-0.5*10**(-1)<= m
<10**d
-0.5 F(w
-n
).0,n(' ')
1004 m
>= 10**d
-0.5 Ew.d
[Ee
]
1006 notes
: for Gw.d
, n
' ' means
4 blanks
1007 for Gw.dEe
, n
' ' means e
+2 blanks
1008 for rounding modes adjustment
, r
, See Fortran F2008
10.7.5.2.2
1009 the asm volatile is required for
32-bit x86 platforms.
*/
1011 #define
OUTPUT_FLOAT_FMT_G(x
,y
) \
1013 output_float_FMT_G_ ##
x (st_parameter_dt
*dtp
, const fnode
*f
, \
1014 GFC_REAL_ ## x m
, char
*buffer
, size_t size
, \
1015 int sign_bit
, bool zero_flag
, int comp_d
) \
1017 int e
= f
->u.real.e
;\
1018 int d
= f
->u.real.d
;\
1019 int w
= f
->u.real.w
;\
1021 GFC_REAL_ ## x rexp_d
, r
= 0.5;\
1022 int low
, high
, mid
;\
1023 int ubound
, lbound
;\
1024 char
*p
, pad
= ' ';\
1025 int save_scale_factor
, nb
= 0;\
1027 int nprinted
, precision
;\
1029 save_scale_factor
= dtp
->u.p.scale_factor
;\
1031 switch (dtp
->u.p.current_unit
->round_status
)\
1034 r
= sign_bit ?
1.0 : 0.0;\
1046 rexp_d
= calculate_exp_ ##
x (-d
);\
1047 if ((m
> 0.0 && ((m
< 0.1 - 0.1 * r
* rexp_d
) ||
(rexp_d
* (m
+ r
) >= 1.0)))\
1048 ||
((m
== 0.0) && !(compile_options.allow_std\
1049 & (GFC_STD_F2003 | GFC_STD_F2008
))))\
1051 newf.format
= FMT_E
;\
1053 newf.u.real.d
= d
- comp_d
;\
1056 precision
= determine_precision (dtp
, &newf
, x
);\
1057 nprinted
= DTOA(y
,precision
,m
); \
1067 while (low
<= high
)\
1069 volatile GFC_REAL_ ## x temp
;\
1070 mid
= (low
+ high
) / 2;\
1072 temp
= (calculate_exp_ ##
x (mid
- 1) * (1 - r
* rexp_d
));\
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
1154 #define
EN_PREC(x
,y
)\
1156 GFC_REAL_ ## x tmp
; \
1157 tmp
= * (GFC_REAL_ ## x *)source
; \
1158 if (ISFINITE (y
,tmp
)) \
1159 nprinted
= DTOA(y
,0,tmp
); \
1165 determine_en_precision (st_parameter_dt
*dtp
, const fnode
*f
,
1166 const char
*source
, int len
)
1170 const size_t size
= 10;
1182 #ifdef HAVE_GFC_REAL_10
1187 #ifdef HAVE_GFC_REAL_16
1189 # ifdef GFC_REAL_16_IS_FLOAT128
1197 internal_error (NULL
, "bad real kind");
1203 int e
= atoi (&buffer
[5]);
1204 int nbefore
; /* digits before decimal point
- 1.
*/
1211 nbefore
= 3 - nbefore
;
1213 int prec
= f
->u.real.d
+ nbefore
;
1214 if (dtp
->u.p.current_unit
->round_status
!= ROUND_UNSPECIFIED
1215 && dtp
->u.p.current_unit
->round_status
!= ROUND_PROCDEFINED
)
1216 prec
+= 2 * len
+ 4;
1221 #define
WRITE_FLOAT(x
,y
)\
1223 GFC_REAL_ ## x tmp
;\
1224 tmp
= * (GFC_REAL_ ## x *)source
;\
1225 sign_bit
= SIGNBIT (y
,tmp
);\
1226 if (!ISFINITE (y
,tmp
))\
1228 write_infnan (dtp
, f
, ISNAN (y
,tmp
), sign_bit
);\
1231 tmp
= sign_bit ?
-tmp
: tmp
;\
1232 zero_flag
= (tmp
== 0.0);\
1233 if (f
->format
== FMT_G
)\
1234 output_float_FMT_G_ ##
x (dtp
, f
, tmp
, buffer
, size
, sign_bit
, \
1235 zero_flag
, comp_d
);\
1238 if (f
->format
== FMT_F
)\
1239 nprinted
= FDTOA(y
,precision
,tmp
); \
1241 nprinted
= DTOA(y
,precision
,tmp
); \
1242 output_float (dtp
, f
, buffer
, size
, nprinted
, precision
,\
1243 sign_bit
, zero_flag
);\
1247 /* Output a real number according to its format.
*/
1250 write_float (st_parameter_dt
*dtp
, const fnode
*f
, const char
*source
, \
1251 int len
, int comp_d
)
1253 int sign_bit
, nprinted
;
1254 int precision
; /* Precision for snprintf call.
*/
1257 if (f
->format
!= FMT_EN
)
1258 precision
= determine_precision (dtp
, f
, len
);
1260 precision
= determine_en_precision (dtp
, f
, source
, len
);
1262 /* 4932 is the maximum exponent of long double and quad precision
, 3
1263 extra characters for the sign
, the decimal point
, and the
1264 trailing null
, and finally some extra digits depending on the
1265 requested precision.
*/
1266 const size_t size
= 4932 + 3 + precision
;
1279 #ifdef HAVE_GFC_REAL_10
1284 #ifdef HAVE_GFC_REAL_16
1286 # ifdef GFC_REAL_16_IS_FLOAT128
1294 internal_error (NULL
, "bad real kind");