1 /* Copyright (C
) 2007, 2008, 2009, 2010 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 /* Output a real number according to its format which is FMT_G free.
*/
65 output_float (st_parameter_dt
*dtp
, const fnode
*f
, char
*buffer
, size_t size
,
66 int sign_bit
, bool zero_flag
, int ndigits
, int edigits
)
75 /* Number of digits before the decimal point.
*/
77 /* Number of zeros after the decimal point.
*/
79 /* Number of digits after the decimal point.
*/
81 /* Number of zeros after the decimal point
, whatever the precision.
*/
95 /* We should always know the field width and precision.
*/
97 internal_error (&dtp
->common
, "Unspecified precision");
99 sign
= calculate_sign (dtp
, sign_bit
);
101 /* The following code checks the given string has punctuation in the correct
102 places. Uncomment if needed for debugging.
103 if (d
!= 0 && ((buffer
[2] != '.' && buffer
[2] != ',')
104 || buffer
[ndigits
+ 2] != 'e'))
105 internal_error (&dtp
->common
, "printf is broken"); */
107 /* Read the exponent back in.
*/
108 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
110 /* Make sure zero comes out as
0.0e0.
*/
114 if (compile_options.sign_zero
== 1)
115 sign
= calculate_sign (dtp
, sign_bit
);
117 sign
= calculate_sign (dtp
, 0);
119 /* Handle special cases.
*/
123 /* For this one we choose to not output a decimal point.
125 if (w
== 1 && ft
== FMT_F
)
127 out
= write_block (dtp
, w
);
131 if (unlikely (is_char4_unit (dtp
)))
133 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
144 /* Normalize the fractional component.
*/
145 buffer
[2] = buffer
[1];
148 /* Figure out where to place the decimal point.
*/
152 if (d
== 0 && e
<= 0 && dtp
->u.p.scale_factor
== 0)
154 memmove (digits
+ 1, digits
, ndigits
- 1);
159 nbefore
= e
+ dtp
->u.p.scale_factor
;
179 i
= dtp
->u.p.scale_factor
;
180 if (d
<= 0 && i
== 0)
182 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Precision not "
183 "greater than zero in format specifier 'E' or 'D'");
186 if (i
<= -d || i
>= d
+ 2)
188 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Scale factor "
189 "out of range in format specifier 'E' or 'D'");
205 nafter
= (d
- i
) + 1;
221 /* The exponent must be a multiple of three
, with
1-3 digits before
222 the decimal point.
*/
231 nbefore
= 3 - nbefore
;
250 /* Should never happen.
*/
251 internal_error (&dtp
->common
, "Unexpected format token");
254 /* Round the value. The value being rounded is an unsigned magnitude.
255 The ROUND_COMPATIBLE is rounding away from zero when there is a tie.
*/
256 switch (dtp
->u.p.current_unit
->round_status
)
258 case ROUND_ZERO
: /* Do nothing and truncation occurs.
*/
271 /* Round compatible unless there is a tie. A tie is a
5 with
272 all trailing zero
's. */
273 i = nafter + nbefore;
274 if (digits[i] == '5')
276 for(i++ ; i < ndigits; i++)
278 if (digits[i] != '0')
281 /* It is a tie so round to even. */
282 switch (digits[nafter + nbefore - 1])
289 /* If odd, round away from zero to even. */
292 /* If even, skip rounding, truncate to even. */
297 case ROUND_PROCDEFINED:
298 case ROUND_UNSPECIFIED:
299 case ROUND_COMPATIBLE:
301 /* Just fall through and do the actual rounding. */
306 if (nbefore + nafter == 0)
309 if (nzero_real == d && digits[0] >= rchar)
311 /* We rounded to zero but shouldn't have
*/
318 else
if (nbefore
+ nafter
< ndigits
)
320 ndigits
= nbefore
+ nafter
;
322 if (digits
[i
] >= rchar
)
324 /* Propagate the carry.
*/
325 for (i
--; i
>= 0; i
--)
327 if (digits
[i
] != '9')
337 /* The carry overflowed. Fortunately we have some spare
338 space at the start of the buffer. We may discard some
339 digits
, but this is ok because we already know they are
353 else
if (ft
== FMT_EN
)
370 /* Calculate the format of the exponent field.
*/
374 for (i
= abs (e
); i
>= 10; i
/= 10)
379 /* Width not specified. Must be no more than
3 digits.
*/
380 if (e
> 999 || e
< -999)
385 if (e
> 99 || e
< -99)
391 /* Exponent width specified
, check it is wide enough.
*/
392 if (edigits
> f
->u.real.e
)
395 edigits
= f
->u.real.e
+ 2;
401 /* Zero values always output as positive
, even if the value was negative
403 for (i
= 0; i
< ndigits
; i
++)
405 if (digits
[i
] != '0')
410 /* The output is zero
, so set the sign according to the sign bit unless
411 -fno
-sign
-zero was specified.
*/
412 if (compile_options.sign_zero
== 1)
413 sign
= calculate_sign (dtp
, sign_bit
);
415 sign
= calculate_sign (dtp
, 0);
418 /* Pick a field size if none was specified.
*/
420 w
= nbefore
+ nzero
+ nafter
+ (sign
!= S_NONE ?
2 : 1);
422 /* Work out how much padding is needed.
*/
423 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
427 if (dtp
->u.p.g0_no_blanks
)
433 /* Create the ouput buffer.
*/
434 out
= write_block (dtp
, w
);
438 /* Check the value fits in the specified field width.
*/
439 if (nblanks
< 0 || edigits
== -1)
441 if (unlikely (is_char4_unit (dtp
)))
443 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
444 memset4 (out4
, '*', w
);
451 /* See if we have space for a zero before the decimal point.
*/
452 if (nbefore
== 0 && nblanks
> 0)
460 /* For internal
character(kind
=4) units
, we duplicate the code used for
461 regular output slightly modified. This needs to be maintained
462 consistent with the regular code that follows this block.
*/
463 if (unlikely (is_char4_unit (dtp
)))
465 gfc_char4_t
*out4
= (gfc_char4_t *) out
;
466 /* Pad to full field width.
*/
468 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
470 memset4 (out4
, ' ', nblanks
);
474 /* Output the initial
sign (if any
).
*/
477 else
if (sign
== S_MINUS
)
480 /* Output an optional leading zero.
*/
484 /* Output the part before the decimal point
, padding with zeros.
*/
487 if (nbefore
> ndigits
)
490 memcpy4 (out4
, digits
, i
);
498 memcpy4 (out4
, digits
, i
);
506 /* Output the decimal point.
*/
507 *(out4
++) = dtp
->u.p.current_unit
->decimal_status
508 == DECIMAL_POINT ?
'.' : ',';
510 /* Output leading zeros after the decimal point.
*/
513 for (i
= 0; i
< nzero
; i
++)
517 /* Output digits after the decimal point
, padding with zeros.
*/
520 if (nafter
> ndigits
)
525 memcpy4 (out4
, digits
, i
);
534 /* Output the exponent.
*/
543 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
545 sprintf (buffer
, "%+0*d", edigits
, e
);
547 memcpy4 (out4
, buffer
, edigits
);
550 if (dtp
->u.p.no_leading_blank
)
553 memset4 (out4
, ' ' , nblanks
);
554 dtp
->u.p.no_leading_blank
= 0;
557 } /* End of
character(kind
=4) internal unit code.
*/
559 /* Pad to full field width.
*/
561 if ( ( nblanks
> 0 ) && !dtp
->u.p.no_leading_blank
)
563 memset (out
, ' ', nblanks
);
567 /* Output the initial
sign (if any
).
*/
570 else
if (sign
== S_MINUS
)
573 /* Output an optional leading zero.
*/
577 /* Output the part before the decimal point
, padding with zeros.
*/
580 if (nbefore
> ndigits
)
583 memcpy (out
, digits
, i
);
591 memcpy (out
, digits
, i
);
599 /* Output the decimal point.
*/
600 *(out
++) = dtp
->u.p.current_unit
->decimal_status
== DECIMAL_POINT ?
'.' : ',';
602 /* Output leading zeros after the decimal point.
*/
605 for (i
= 0; i
< nzero
; i
++)
609 /* Output digits after the decimal point
, padding with zeros.
*/
612 if (nafter
> ndigits
)
617 memcpy (out
, digits
, i
);
626 /* Output the exponent.
*/
635 snprintf (buffer
, size
, "%+0*d", edigits
, e
);
637 sprintf (buffer
, "%+0*d", edigits
, e
);
639 memcpy (out
, buffer
, edigits
);
642 if (dtp
->u.p.no_leading_blank
)
645 memset( out
, ' ' , nblanks
);
646 dtp
->u.p.no_leading_blank
= 0;
651 #undef MIN_FIELD_WIDTH
655 /* Write
"Infinite" or
"Nan" as appropriate for the given format.
*/
658 write_infnan (st_parameter_dt
*dtp
, const fnode
*f
, int isnan_flag
, int sign_bit
)
663 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
667 /* If the field width is zero
, the processor must select a width
668 not zero.
4 is chosen to allow output of
'-Inf' or
'+Inf' */
671 p
= write_block (dtp
, nb
);
676 if (unlikely (is_char4_unit (dtp
)))
678 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
679 memset4 (p4
, '*', nb
);
686 if (unlikely (is_char4_unit (dtp
)))
688 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
689 memset4 (p4
, ' ', nb
);
698 /* If the sign is negative and the width is
3, there is
699 insufficient room to output
'-Inf', so output asterisks
*/
702 if (unlikely (is_char4_unit (dtp
)))
704 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
705 memset4 (p4
, '*', nb
);
711 /* The negative sign is mandatory
*/
715 /* The positive sign is optional
, but we output it for
719 if (unlikely (is_char4_unit (dtp
)))
721 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
723 /* We have room
, so output
'Infinity' */
724 memcpy4 (p4
+ nb
- 8, "Infinity", 8);
726 /* For the case of width equals
8, there is not enough room
727 for the sign and
'Infinity' so we go with
'Inf' */
728 memcpy4 (p4
+ nb
- 3, "Inf", 3);
730 if (nb
< 9 && nb
> 3)
731 /* Put the sign in front of Inf
*/
732 p4
[nb
- 4] = (gfc_char4_t
) fin
;
734 /* Put the sign in front of Infinity
*/
735 p4
[nb
- 9] = (gfc_char4_t
) fin
;
740 /* We have room
, so output
'Infinity' */
741 memcpy(p
+ nb
- 8, "Infinity", 8);
743 /* For the case of width equals
8, there is not enough room
744 for the sign and
'Infinity' so we go with
'Inf' */
745 memcpy(p
+ nb
- 3, "Inf", 3);
747 if (nb
< 9 && nb
> 3)
748 p
[nb
- 4] = fin
; /* Put the sign in front of Inf
*/
750 p
[nb
- 9] = fin
; /* Put the sign in front of Infinity
*/
754 if (unlikely (is_char4_unit (dtp
)))
756 gfc_char4_t
*p4
= (gfc_char4_t *) p
;
757 memcpy4 (p4
+ nb
- 3, "NaN", 3);
760 memcpy(p
+ nb
- 3, "NaN", 3);
767 /* Returns the value of
10**d.
*/
769 #define
CALCULATE_EXP(x
) \
770 inline static GFC_REAL_ ## x \
771 calculate_exp_ ##
x (int d
)\
774 GFC_REAL_ ## x r
= 1.0;\
775 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)\
777 r
= (d
>= 0) ? r
: 1.0 / r
;\
785 #ifdef HAVE_GFC_REAL_10
789 #ifdef HAVE_GFC_REAL_16
794 /* Generate corresponding I
/O format for FMT_G and output.
795 The rules to translate FMT_G to FMT_E or FMT_F from
DEC fortran
796 LRM (table
11-2, Chapter
11, "I/O Formatting", P11
-25) is
:
798 Data Magnitude Equivalent Conversion
799 0< m
< 0.1-0.5*10**(-d
-1) Ew.d
[Ee
]
800 m
= 0 F(w
-n
).
(d
-1), n
' '
801 0.1-0.5*10**(-d
-1)<= m
< 1-0.5*10**(-d
) F(w
-n
).d
, n
' '
802 1-0.5*10**(-d
)<= m
< 10-0.5*10**(-d
+1) F(w
-n
).
(d
-1), n
' '
803 10-0.5*10**(-d
+1)<= m
< 100-0.5*10**(-d
+2) F(w
-n
).
(d
-2), n
' '
804 ................ ..........
805 10**(d
-1)-0.5*10**(-1)<= m
<10**d
-0.5 F(w
-n
).0,n(' ')
806 m
>= 10**d
-0.5 Ew.d
[Ee
]
808 notes
: for Gw.d
, n
' ' means
4 blanks
809 for Gw.dEe
, n
' ' means e
+2 blanks
*/
811 #define
OUTPUT_FLOAT_FMT_G(x
) \
813 output_float_FMT_G_ ##
x (st_parameter_dt
*dtp
, const fnode
*f
, \
814 GFC_REAL_ ## x m
, char
*buffer
, size_t size
, \
815 int sign_bit
, bool zero_flag
, int ndigits
, int edigits
) \
817 int e
= f
->u.real.e
;\
818 int d
= f
->u.real.d
;\
819 int w
= f
->u.real.w
;\
821 GFC_REAL_ ## x rexp_d
;\
825 int save_scale_factor
, nb
= 0;\
827 save_scale_factor
= dtp
->u.p.scale_factor
;\
828 newf
= (fnode *)
get_mem (sizeof (fnode
));\
830 rexp_d
= calculate_exp_ ##
x (-d
);\
831 if ((m
> 0.0 && m
< 0.1 - 0.05 * rexp_d
) ||
(rexp_d
* (m
+ 0.5) >= 1.0) ||\
832 ((m
== 0.0) && !(compile_options.allow_std
& GFC_STD_F2003
)))\
834 newf
->format
= FMT_E
;\
850 GFC_REAL_ ## x temp
;\
851 mid
= (low
+ high
) / 2;\
853 temp
= (calculate_exp_ ##
x (mid
- 1) * (1 - 0.5 * rexp_d
));\
858 if (ubound
== lbound
+ 1)\
865 if (ubound
== lbound
+ 1)\
884 newf
->format
= FMT_F
;\
885 newf
->u.real.w
= f
->u.real.w
- nb
;\
888 newf
->u.real.d
= d
- 1;\
890 newf
->u.real.d
= - (mid
- d
- 1);\
892 dtp
->u.p.scale_factor
= 0;\
895 output_float (dtp
, newf
, buffer
, size
, sign_bit
, zero_flag
, ndigits
, \
897 dtp
->u.p.scale_factor
= save_scale_factor
;\
901 if (nb
> 0 && !dtp
->u.p.g0_no_blanks
)\
903 p
= write_block (dtp
, nb
);\
906 if (unlikely (is_char4_unit (dtp
)))\
908 gfc_char4_t
*p4
= (gfc_char4_t *) p
;\
909 memset4 (p4
, ' ', nb
);\
912 memset (p
, ' ', nb
);\
916 OUTPUT_FLOAT_FMT_G(4)
918 OUTPUT_FLOAT_FMT_G(8)
920 #ifdef HAVE_GFC_REAL_10
921 OUTPUT_FLOAT_FMT_G(10)
924 #ifdef HAVE_GFC_REAL_16
925 OUTPUT_FLOAT_FMT_G(16)
928 #undef OUTPUT_FLOAT_FMT_G
931 /* Define a macro to build code for write_float.
*/
933 /* Note
: Before output_float is called
, sprintf is used to print to buffer the
934 number in the format
+D.DDDDe
+ddd. For an N digit exponent
, this gives us
935 (MIN_FIELD_WIDTH
-5)-N digits after the decimal point
, plus another one
936 before the decimal point.
938 # The result will always contain a decimal point
, even if no
941 - The converted value is to be left adjusted on the field boundary
943 + A
sign (+ or
-) always be placed before a number
945 MIN_FIELD_WIDTH minimum field width
947 * (ndigits
-1) is used as the precision
949 e format
: [-]d.ddde±dd where there is one digit before the
950 decimal
-point character and the number of digits after it is
951 equal to the precision. The exponent always contains at least two
952 digits
; if the value is zero
, the exponent is
00.
*/
957 snprintf (buffer
, size
, "%+-#" STR(MIN_FIELD_WIDTH
) ".*" \
958 "e", ndigits
- 1, tmp
);
961 snprintf (buffer
, size
, "%+-#" STR(MIN_FIELD_WIDTH
) ".*" \
962 "Le", ndigits
- 1, tmp
);
967 sprintf (buffer
, "%+-#" STR(MIN_FIELD_WIDTH
) ".*" \
968 "e", ndigits
- 1, tmp
);
971 sprintf (buffer
, "%+-#" STR(MIN_FIELD_WIDTH
) ".*" \
972 "Le", ndigits
- 1, tmp
);
976 #define
WRITE_FLOAT(x
,y
)\
979 tmp
= * (GFC_REAL_ ## x *)source
;\
980 sign_bit
= signbit (tmp
);\
981 if (!isfinite (tmp
))\
983 write_infnan (dtp
, f
, isnan (tmp
), sign_bit
);\
986 tmp
= sign_bit ?
-tmp
: tmp
;\
987 zero_flag
= (tmp
== 0.0);\
991 if (f
->format
!= FMT_G
)\
992 output_float (dtp
, f
, buffer
, size
, sign_bit
, zero_flag
, ndigits
, \
995 output_float_FMT_G_ ##
x (dtp
, f
, tmp
, buffer
, size
, sign_bit
, \
996 zero_flag
, ndigits
, edigits
);\
999 /* Output a real number according to its format.
*/
1002 write_float (st_parameter_dt
*dtp
, const fnode
*f
, const char
*source
, int len
)
1005 #if
defined(HAVE_GFC_REAL_16
) && __LDBL_DIG__
> 18
1006 # define MIN_FIELD_WIDTH
46
1008 # define MIN_FIELD_WIDTH
31
1010 #define
STR(x
) STR1(x
)
1013 /* This must be large enough to accurately hold any value.
*/
1014 char buffer
[MIN_FIELD_WIDTH
+1];
1015 int sign_bit
, ndigits
, edigits
;
1019 size
= MIN_FIELD_WIDTH
+1;
1021 /* printf pads blanks for us on the exponent so we just need it big enough
1022 to handle the largest number of exponent digits expected.
*/
1025 if (f
->format
== FMT_F || f
->format
== FMT_EN || f
->format
== FMT_G
1026 ||
((f
->format
== FMT_D || f
->format
== FMT_E
)
1027 && dtp
->u.p.scale_factor
!= 0))
1029 /* Always convert at full precision to avoid double rounding.
*/
1030 ndigits
= MIN_FIELD_WIDTH
- 4 - edigits
;
1034 /* The number of digits is known
, so let printf do the rounding.
*/
1035 if (f
->format
== FMT_ES
)
1036 ndigits
= f
->u.real.d
+ 1;
1038 ndigits
= f
->u.real.d
;
1039 if (ndigits
> MIN_FIELD_WIDTH
- 4 - edigits
)
1040 ndigits
= MIN_FIELD_WIDTH
- 4 - edigits
;
1053 #ifdef HAVE_GFC_REAL_10
1058 #ifdef HAVE_GFC_REAL_16
1064 internal_error (NULL
, "bad real kind");