1 /* Copyright (C
) 2007, 2008 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
95 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
2, or (at your option
)
13 In addition to the permissions in the GNU General Public License
, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs
,
16 and to distribute those combinations without any restriction coming
17 from the use of this file.
(The General Public License restrictions
18 do apply in other respects
; for example
, they cover modification of
19 the file
, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful
,
23 but WITHOUT ANY WARRANTY
; without even the implied warranty of
24 MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran
; see the file COPYING. If not
, write to
29 the Free Software Foundation
, 51 Franklin Street
, Fifth Floor
,
30 Boston
, MA
02110-1301, USA.
*/
35 { S_NONE
, S_MINUS
, S_PLUS
}
38 /* Given a flag that indicates if a value is negative or not
, return a
39 sign_t that gives the sign that we need to produce.
*/
42 calculate_sign (st_parameter_dt
*dtp
, int negative_flag
)
49 switch (dtp
->u.p.sign_status
)
51 case SIGN_SP
: /* Show sign.
*/
54 case SIGN_SS
: /* Suppress sign.
*/
57 case SIGN_S
: /* Processor defined.
*/
58 case SIGN_UNSPECIFIED
:
59 s
= options.optional_plus ? S_PLUS
: S_NONE
;
67 /* Output a real number according to its format which is FMT_G free.
*/
70 output_float (st_parameter_dt
*dtp
, const fnode
*f
, char
*buffer
, size_t size
,
71 int sign_bit
, bool zero_flag
, int ndigits
, int edigits
)
80 /* Number of digits before the decimal point.
*/
82 /* Number of zeros after the decimal point.
*/
84 /* Number of digits after the decimal point.
*/
86 /* Number of zeros after the decimal point
, whatever the precision.
*/
99 /* We should always know the field width and precision.
*/
101 internal_error (&dtp
->common
, "Unspecified precision");
103 sign
= calculate_sign (dtp
, sign_bit
);
105 /* The following code checks the given string has punctuation in the correct
106 places. Uncomment if needed for debugging.
107 if (d
!= 0 && ((buffer
[2] != '.' && buffer
[2] != ',')
108 || buffer
[ndigits
+ 2] != 'e'))
109 internal_error (&dtp
->common
, "printf is broken"); */
111 /* Read the exponent back in.
*/
112 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
114 /* Make sure zero comes out as
0.0e0.
*/
118 if (compile_options.sign_zero
== 1)
119 sign
= calculate_sign (dtp
, sign_bit
);
121 sign
= calculate_sign (dtp
, 0);
124 /* Normalize the fractional component.
*/
125 buffer
[2] = buffer
[1];
128 /* Figure out where to place the decimal point.
*/
132 nbefore
= e
+ dtp
->u.p.scale_factor
;
152 i
= dtp
->u.p.scale_factor
;
153 if (d
<= 0 && i
== 0)
155 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Precision not "
156 "greater than zero in format specifier 'E' or 'D'");
159 if (i
<= -d || i
>= d
+ 2)
161 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Scale factor "
162 "out of range in format specifier 'E' or 'D'");
178 nafter
= (d
- i
) + 1;
194 /* The exponent must be a multiple of three
, with
1-3 digits before
195 the decimal point.
*/
204 nbefore
= 3 - nbefore
;
223 /* Should never happen.
*/
224 internal_error (&dtp
->common
, "Unexpected format token");
227 /* Round the value.
*/
228 if (nbefore
+ nafter
== 0)
231 if (nzero_real
== d
&& digits
[0] >= '5')
233 /* We rounded to zero but shouldn
't have */
240 else if (nbefore + nafter < ndigits)
242 ndigits = nbefore + nafter;
244 if (digits[i] >= '5')
246 /* Propagate the carry. */
247 for (i--; i >= 0; i--)
249 if (digits[i] != '9')
259 /* The carry overflowed. Fortunately we have some spare space
260 at the start of the buffer. We may discard some digits, but
261 this is ok because we already know they are zero. */
274 else if (ft == FMT_EN)
289 /* Calculate the format of the exponent field. */
293 for (i = abs (e); i >= 10; i /= 10)
298 /* Width not specified. Must be no more than 3 digits. */
299 if (e > 999 || e < -999)
304 if (e > 99 || e < -99)
310 /* Exponent width specified, check it is wide enough. */
311 if (edigits > f->u.real.e)
314 edigits = f->u.real.e + 2;
320 /* Pick a field size if none was specified. */
322 w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
324 /* Create the ouput buffer. */
325 out = write_block (dtp, w);
329 /* Zero values always output as positive, even if the value was negative
331 for (i = 0; i < ndigits; i++)
333 if (digits[i] != '0')
338 /* The output is zero, so set the sign according to the sign bit unless
339 -fno-sign-zero was specified. */
340 if (compile_options.sign_zero == 1)
341 sign = calculate_sign (dtp, sign_bit);
343 sign = calculate_sign (dtp, 0);
346 /* Work out how much padding is needed. */
347 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
351 /* Check the value fits in the specified field width. */
352 if (nblanks < 0 || edigits == -1)
358 /* See if we have space for a zero before the decimal point. */
359 if (nbefore == 0 && nblanks > 0)
367 /* Pad to full field width. */
369 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
371 memset (out, ' ', nblanks);
375 /* Output the initial sign (if any). */
378 else if (sign == S_MINUS)
381 /* Output an optional leading zero. */
385 /* Output the part before the decimal point, padding with zeros. */
388 if (nbefore > ndigits)
391 memcpy (out, digits, i);
399 memcpy (out, digits, i);
406 /* Output the decimal point. */
407 *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.
' : ',';
409 /* Output leading zeros after the decimal point. */
412 for (i = 0; i < nzero; i++)
416 /* Output digits after the decimal point, padding with zeros. */
419 if (nafter > ndigits)
424 memcpy (out, digits, i);
433 /* Output the exponent. */
442 snprintf (buffer, size, "%+0*d", edigits, e);
444 sprintf (buffer, "%+0*d", edigits, e);
446 memcpy (out, buffer, edigits);
448 if (dtp->u.p.no_leading_blank)
451 memset( out , ' ' , nblanks );
452 dtp->u.p.no_leading_blank = 0;
456 #undef MIN_FIELD_WIDTH
460 /* Write "Infinite" or "Nan" as appropriate for the given format. */
463 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
468 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
472 /* If the field width is zero, the processor must select a width
473 not zero. 4 is chosen to allow output of '-Inf
' or '+Inf
' */
476 p = write_block (dtp, nb);
491 /* If the sign is negative and the width is 3, there is
492 insufficient room to output '-Inf
', so output asterisks */
500 /* The negative sign is mandatory */
506 /* The positive sign is optional, but we output it for
512 /* We have room, so output 'Infinity
' */
513 memcpy(p + nb - 8, "Infinity", 8);
516 /* For the case of width equals 8, there is not enough room
517 for the sign and 'Infinity
' so we go with 'Inf
' */
518 memcpy(p + nb - 3, "Inf", 3);
520 if (nb < 9 && nb > 3)
521 p[nb - 4] = fin; /* Put the sign in front of Inf */
523 p[nb - 9] = fin; /* Put the sign in front of Infinity */
526 memcpy(p + nb - 3, "NaN", 3);
532 /* Returns the value of 10**d. */
534 #define CALCULATE_EXP(x) \
535 inline static GFC_REAL_ ## x \
536 calculate_exp_ ## x (int d)\
539 GFC_REAL_ ## x r = 1.0;\
540 for (i = 0; i< (d >= 0 ? d : -d); i++)\
542 r = (d >= 0) ? r : 1.0 / r;\
550 #ifdef HAVE_GFC_REAL_10
554 #ifdef HAVE_GFC_REAL_16
559 /* Generate corresponding I/O format for FMT_G and output.
560 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
561 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
563 Data Magnitude Equivalent Conversion
564 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
565 m = 0 F(w-n).(d-1), n' '
566 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
567 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
568 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
569 ................ ..........
570 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
571 m >= 10**d-0.5 Ew.d[Ee]
573 notes: for Gw.d , n' ' means 4 blanks
574 for Gw.dEe, n' ' means e+2 blanks */
576 #define OUTPUT_FLOAT_FMT_G(x) \
578 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
579 GFC_REAL_ ## x m, char *buffer, size_t size, \
580 int sign_bit, bool zero_flag, int ndigits, int edigits) \
582 int e = f->u.real.e;\
583 int d = f->u.real.d;\
584 int w = f->u.real.w;\
586 GFC_REAL_ ## x exp_d;\
590 int save_scale_factor, nb = 0;\
592 save_scale_factor = dtp->u.p.scale_factor;\
593 newf = get_mem (sizeof (fnode));\
595 exp_d = calculate_exp_ ## x (d);\
596 if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
597 ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
599 newf->format = FMT_E;\
615 GFC_REAL_ ## x temp;\
616 mid = (low + high) / 2;\
618 temp = 0.1 * calculate_exp_ ## x (mid) - 0.5\
619 * calculate_exp_ ## x (mid - d - 1);\
624 if (ubound == lbound + 1)\
631 if (ubound == lbound + 1)\
647 newf->format = FMT_F;\
648 newf->u.real.w = f->u.real.w - nb;\
651 newf->u.real.d = d - 1;\
653 newf->u.real.d = - (mid - d - 1);\
655 dtp->u.p.scale_factor = 0;\
658 output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
660 dtp->u.p.scale_factor = save_scale_factor;\
666 p = write_block (dtp, nb);\
669 memset (p, ' ', nb);\
673 OUTPUT_FLOAT_FMT_G(4)
675 OUTPUT_FLOAT_FMT_G(8)
677 #ifdef HAVE_GFC_REAL_10
678 OUTPUT_FLOAT_FMT_G(10)
681 #ifdef HAVE_GFC_REAL_16
682 OUTPUT_FLOAT_FMT_G(16)
685 #undef OUTPUT_FLOAT_FMT_G
688 /* Define a macro to build code for write_float. */
690 /* Note: Before output_float is called, sprintf is used to print to buffer the
691 number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
692 (MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
693 before the decimal point.
695 # The result will always contain a decimal point, even if no
698 - The converted value is to be left adjusted on the field boundary
700 + A sign (+ or -) always be placed before a number
702 MIN_FIELD_WIDTH minimum field width
704 * (ndigits-1) is used as the precision
706 e format: [-]d.ddde±dd where there is one digit before the
707 decimal-point character and the number of digits after it is
708 equal to the precision. The exponent always contains at least two
709 digits; if the value is zero, the exponent is 00. */
714 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
715 "e", ndigits - 1, tmp);
718 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
719 "Le", ndigits - 1, tmp);
724 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
725 "e", ndigits - 1, tmp);
728 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
729 "Le", ndigits - 1, tmp);
733 #define WRITE_FLOAT(x,y)\
736 tmp = * (GFC_REAL_ ## x *)source;\
737 sign_bit = signbit (tmp);\
738 if (!isfinite (tmp))\
740 write_infnan (dtp, f, isnan (tmp), sign_bit);\
743 tmp = sign_bit ? -tmp : tmp;\
744 if (f->u.real.d == 0 && f->format == FMT_F)\
751 zero_flag = (tmp == 0.0);\
755 if (f->format != FMT_G)\
756 output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
759 output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
760 zero_flag, ndigits, edigits);\
763 /* Output a real number according to its format. */
766 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
769 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
770 # define MIN_FIELD_WIDTH 46
772 # define MIN_FIELD_WIDTH 31
774 #define STR(x) STR1(x)
777 /* This must be large enough to accurately hold any value. */
778 char buffer[MIN_FIELD_WIDTH+1];
779 int sign_bit, ndigits, edigits;
783 size = MIN_FIELD_WIDTH+1;
785 /* printf pads blanks for us on the exponent so we just need it big enough
786 to handle the largest number of exponent digits expected. */
789 if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
790 || ((f->format == FMT_D || f->format == FMT_E)
791 && dtp->u.p.scale_factor != 0))
793 /* Always convert at full precision to avoid double rounding. */
794 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
798 /* The number of digits is known, so let printf do the rounding. */
799 if (f->format == FMT_ES)
800 ndigits = f->u.real.d + 1;
802 ndigits = f->u.real.d;
803 if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
804 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
817 #ifdef HAVE_GFC_REAL_10
822 #ifdef HAVE_GFC_REAL_16
828 internal_error (NULL, "bad real kind");