enum format_token
{
FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
- FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
- FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
- FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
- FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
- FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
+ FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, FMT_RPAREN, FMT_X,
+ FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, FMT_E, FMT_EN, FMT_ES,
+ FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR, FMT_DC, FMT_DP, FMT_T,
+ FMT_TR, FMT_TL, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ,
+ FMT_DT, FMT_EX, FMT_LPS, FMT_LPZ, FMT_LZ
};
/* Local variables for checking format strings. The saved_token is
token = FMT_EN;
else if (c == 'S')
token = FMT_ES;
+ else if (c == 'X')
+ token = FMT_EX;
else
{
token = FMT_E;
break;
case 'L':
+ c = next_char_not_space ();
+ switch (c)
+ {
+ case 'P':
+ c = next_char_not_space ();
+ switch (c)
+ {
+ case 'S':
+ token = FMT_LPS;
+ break;
+
+ case 'Z':
+ token = FMT_LPZ;
+ break;
+
+ default:
+ token = FMT_UNKNOWN;
+ unget_char ();
+ break;
+ }
+ break;
+
+ case 'Z':
+ token = FMT_LZ;
+ break;
+
+ default:
+ token = FMT_UNKNOWN;
+ unget_char ();
+ break;
+ }
token = FMT_L;
break;
case FMT_E:
case FMT_EN:
case FMT_ES:
+ case FMT_EX:
case FMT_G:
case FMT_L:
case FMT_A:
case FMT_D:
case FMT_E:
+ case FMT_EX:
case FMT_G:
case FMT_EN:
case FMT_ES:
--- /dev/null
+! { dg-do run }
+! pr93727 EX Format Specifiers, testing various kinds, default field widths
+program main
+ implicit none
+ character(kind=1, len=48) :: s1
+
+ call test04
+ call test08
+ call test10
+ call test16
+
+contains
+
+subroutine test04
+ real(4) :: r4
+ r4 = -huge(1.0_4)
+ write(s1,"(EX0.0,'<')") r4
+ if (s1.ne."-0XF.FFFFFP+124<") stop 1
+ write(s1,"(EX0.0,'<')") 1.0_4/r4
+ if (s1.ne."-0X8.P-131<") stop 2
+end subroutine test04
+
+subroutine test08
+ real(8) :: r8
+ r8 = -huge( 1.0_8)
+ write(s1,"(EX0.0,'<')") r8
+ if (s1.ne."-0XF.FFFFFFFFFFFF8P+1020<") stop 3
+ write(s1,"(EX0.0,'<')") 1.0_8/r8
+ if (s1.ne."-0X8.P-1027<") stop 4
+end subroutine test08
+
+#ifdef __GFC_REAL_10__
+subroutine test10
+ real(10) :: r10
+ r10 = -huge(1.0_10)
+ write(s1,"(EX0.0,'<')") r10
+ if (s1.ne."-0XF.FFFFFFFFFFFFFFFP+16380<") stop 5
+ write(s1,"(EX0.0,'<')") 1.0_10/r10
+ if (s1.ne."-0X8.P-16387<") stop 6
+end subroutine test10
+#else
+subroutine test10
+end subroutine test10
+#endif
+
+#ifdef __GFC_REAL_16__
+subroutine test16
+ real(16) :: r16
+ r16 = 1.0_16/3.0_16
+ write(s1,"(EX0.0,'<')") r16
+ if (s1.ne."0XA.AAAAAAAAAAAAAAAAAAAAAAAAAAA8P-5<") stop 7
+end subroutine test16
+#else
+subroutine test16
+end subroutine test16
+#endif
+
+end program main
--- /dev/null
+! { dg-do run }
+! PR93727 Test writing EX as character(kind=1) output
+program kind1
+ implicit none
+ integer, parameter :: wp = 8
+ real(kind=wp) :: num
+ character(kind=1,len=45) :: str1
+
+ num = -3.14159682678_wp * 25._wp
+ write(str1, '(">",EX30.0,"<")') num
+ if (str1.ne."> -0X9.D14707B63DFBP+3<") stop 1
+ write(str1, '(">",EX30.1,"<")') num
+ if (str1.ne."> -0X9.DP+3<") stop 2
+ write(str1, '(">",EX30.2,"<")') num
+ if (str1.ne."> -0X9.D1P+3<") stop 3
+ write(str1, '(">",EX30.3,"<")') num
+ if (str1.ne."> -0X9.D14P+3<") stop 4
+ write(str1, '(">",EX30.4,"<")') num
+ if (str1.ne."> -0X9.D147P+3<") stop 5
+ write(str1, '(">",EX30.15e8,"<")') num
+ if (str1.ne.">-0X9.D14707B63DFB000P+00000003<") stop 6
+ write(str1, '(">",EX8.5,"<")') num
+ if (str1.ne.">********<") stop 7
+end program kind1
case 'S':
token = FMT_ES;
break;
+ case 'X':
+ token = FMT_EX;
+ break;
default:
token = FMT_E;
unget_char (fmt);
tail->repeat = 1;
t = format_lex (fmt);
- if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
+ if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_EX || t == FMT_D
|| t == FMT_G || t == FMT_E)
{
repeat = 1;
case FMT_E:
case FMT_EN:
case FMT_ES:
+ case FMT_EX:
case FMT_D:
case FMT_DT:
case FMT_L:
case FMT_G:
case FMT_EN:
case FMT_ES:
+ case FMT_EX:
*seen_dd = true;
get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
- t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
- t == FMT_A || t == FMT_D || t == FMT_DT))
+ t == FMT_E || t == FMT_EN || t == FMT_ES || t== FMT_EX || t == FMT_G ||
+ t == FMT_L || t == FMT_A || t == FMT_D || t == FMT_DT))
fmt->reversion_ok = 1;
return f;
}
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
- FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
+ FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT, FMT_EX,
+ FMT_LPS, FMT_LPZ, FMT_LZ
}
format_token;
extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_es);
+extern void write_ex (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_ex);
+
extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_f);
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
|| t == FMT_L || t == FMT_A || t == FMT_D
- || t == FMT_DT))
+ || t == FMT_DT || t == FMT_EX))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
write_es (dtp, f, p, kind);
break;
+ case FMT_EX:
+ if (n == 0)
+ goto need_data;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ write_ex (dtp, f, p, kind);
+ break;
+
+
case FMT_F:
if (n == 0)
goto need_data;
#include "unix.h"
#include <assert.h>
#include <string.h>
+#include "config.h"
#define star_fill(p, n) memset(p, '*', n)
return;
*p++ = (uchar) c;
}
- else
+ else
{
p = write_block (dtp, 1);
if (p == NULL)
/* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
- if (p == NULL)
- return;
+ if (p == NULL)
+ return;
memcpy (p, crlf, 2);
}
else
if (m == 0 && n == 0)
{
if (w == 0)
- w = 1;
+ w = 1;
p = write_block (dtp, w);
if (p == NULL)
- return;
+ return;
if (unlikely (is_char4_unit (dtp)))
{
gfc_char4_t *p4 = (gfc_char4_t *) p;
if (m == 0 && n == 0)
{
if (w == 0)
- w = 1;
+ w = 1;
p = write_block (dtp, w);
if (p == NULL)
- return;
+ return;
if (unlikely (is_char4_unit (dtp)))
{
gfc_char4_t *p4 = (gfc_char4_t *) p;
octet |= (c & 1) << j;
c >>= 1;
if (++k > 7)
- {
+ {
i++;
k = 0;
c = *--p;
octet |= (c & 1) << j;
c >>= 1;
if (++k > 7)
- {
+ {
i++;
k = 0;
c = *++p;
*p++ = d;
for (size_t i = 0; i < length; i++)
- {
- *p++ = source[i];
- if (source[i] == d)
+ {
+ *p++ = source[i];
+ if (source[i] == d)
*p++ = d;
}
buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
get_float_string (dtp, f, source , kind, 0, buffer,
- precision, buf_size, result, &flt_str_len);
+ precision, buf_size, result, &flt_str_len);
write_float_string (dtp, result, flt_str_len);
if (buf_size > BUF_STACK_SZ)
write_float_0 (dtp, f, p, len);
}
+void
+write_ex (st_parameter_dt *dtp, const fnode *f, const char *p, int kind)
+{
+ /* The EX specifier in Fortran 2018 produces hexadecimal floating-point
+ output. The format is EXw.dEe where:
+ - w is the total field width
+ - d is the number of significant hex digits after the radix point
+ - e is the width of the exponent field (including 'p' and sign)
+
+ Example output: 0x1.23p+10 or -0x1.abcp-5 */
+
+ char buf[64];
+ char output[64];
+ char *p_pos, *exp_pos, *decimal;
+ char sign_char;
+ int w, d, e, result, res_len;
+ int exp_value;
+ int mantissa_digits;
+ size_t output_len, mantissa_len, copy_len;
+
+ /* Get the user supplied width parameters. */
+
+ w = f->u.real.w; /* Total field width */
+ d = f->u.real.d; /* Significant hex digits after decimal */
+ e = f->u.real.e == -1 ? 0 : f->u.real.e; /* Exponent field width */
+
+ /* Get the hex float string using uppercase format (e.g., 0X1.23P+10) */
+ result = get_float_hex_string (p, kind, buf, &res_len);
+
+ if (result < 0)
+ {
+ /* Error - output asterisks */
+ w = (w > 0) ? w : 1;
+ char *out = write_block (dtp, w);
+ if (out != NULL)
+ memset (out, '*', w);
+ return;
+ }
+
+ /* Find the exponent marker 'P' (uppercase from %A format) */
+ p_pos = strchr (buf, 'P');
+ if (p_pos == NULL)
+ {
+ /* No exponent found - this occurs when the value is INF or NAN */
+ strncpy (output, buf, sizeof (output) - 1);
+ output[sizeof (output) - 1] = '\0';
+ output_len = strlen (output);
+ goto write_output;
+ }
+
+ /* Parse exponent value */
+ exp_pos = p_pos + 1;
+ sign_char = '+';
+ if (*exp_pos == '+' || *exp_pos == '-')
+ {
+ sign_char = *exp_pos;
+ exp_pos++;
+ }
+
+ if (sscanf (exp_pos, "%d", &exp_value) != 1)
+ {
+ /* Failed to parse - use original */
+ strncpy (output, buf, sizeof (output) - 1);
+ output[sizeof (output) - 1] = '\0';
+ output_len = strlen (output);
+ goto write_output;
+ }
+
+ /* Handle the 'd' parameter - trim trailing zeros before 'P'. */
+ if (d == 0)
+ {
+ decimal = strchr (buf, '.');
+ if (decimal != NULL && decimal < p_pos)
+ {
+ char *trim = p_pos - 1;
+ while (trim > decimal && *trim == '0')
+ trim--;
+ /* Shift 'P...' part left to just after last non-zero digit. */
+ if (trim + 1 < p_pos)
+ {
+ memmove (trim + 1, p_pos, strlen (p_pos) + 1);
+ p_pos = trim + 1;
+ }
+ }
+ }
+
+ /* Handle the 'd' parameter - adjust mantissa precision if specified */
+ if (d > 0)
+ {
+ /* Find the decimal point in mantissa */
+ decimal = strchr (buf, '.');
+ if (decimal != NULL && decimal < p_pos)
+ {
+ /* Count current mantissa digits after decimal point */
+ mantissa_digits = p_pos - decimal - 1;
+
+ /* Adjust mantissa to have exactly 'd' digits after decimal */
+ if (d < mantissa_digits)
+ {
+ /* Truncate mantissa */
+ memmove (decimal + d + 1, p_pos, strlen (p_pos) + 1);
+ p_pos = decimal + d + 1;
+ }
+ else if (d > mantissa_digits)
+ {
+ /* Pad with zeros - shift exponent part right */
+ int pad_count = d - mantissa_digits;
+ if (strlen (buf) + pad_count < sizeof (buf))
+ {
+ memmove (p_pos + pad_count, p_pos, strlen (p_pos) + 1);
+ memset (p_pos, '0', pad_count);
+ p_pos += pad_count;
+ }
+ }
+ }
+ }
+
+ /* Format the exponent field with specified width 'e'. The 'e' parameter
+ is the total exponent width INCLUDING 'P' and the sign. */
+
+ int exp_digits = e;
+ if (exp_digits < 1)
+ exp_digits = 1; /* Minimum 1 digit */
+
+ /* Construct output with formatted exponent */
+ mantissa_len = p_pos - buf;
+ if (mantissa_len >= sizeof (output))
+ mantissa_len = sizeof (output) - 1;
+
+ memcpy (output, buf, mantissa_len);
+ snprintf (output + mantissa_len, sizeof (output) - mantissa_len,
+ "P%c%0*d", sign_char, exp_digits, abs (exp_value));
+
+ output_len = strlen (output);
+
+ /* Check the field width 'w' if specified. If the field width is not
+ wide enough, fill it with "*" before writing it out. */
+ if (w > 0 && (output_len > (size_t) w))
+ {
+ char *out = write_block (dtp, w);
+ if (out != NULL)
+ {
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *out4 = (gfc_char4_t *) out;
+ memset4 (out4, '*', w);
+ }
+ else
+ memset (out, '*', w);
+ }
+ return;
+ }
+
+write_output:
+
+ /* Determine actual output width */
+ int actual_width = (w > 0) ? w : (int) output_len;
+
+ /* Get the block of memory that will be transferred out. */
+ char *out = write_block (dtp, actual_width);
+ if (out == NULL)
+ return;
+
+ /* Handle character unit type (4-byte vs 1-byte) */
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *out4 = (gfc_char4_t *) out;
+
+ /* Pad with spaces if width specified and we're short */
+ int pad_len = actual_width - output_len;
+ if (pad_len > 0)
+ memset4 (out4, ' ', pad_len);
+
+ /* Copy out the wide character string. */
+ out4 += (actual_width - output_len);
+ memcpy4 (out4, output, output_len);
+ }
+ else
+ {
+ /* Pad with spaces if width specified and we're short */
+ if (w > 0 && output_len < (size_t)actual_width)
+ memset (out, ' ', actual_width - output_len);
+ out += (actual_width - output_len);
+
+ /* Copy output string */
+ copy_len = (output_len < (size_t)actual_width)
+ ? output_len : (size_t)actual_width;
+ memcpy (out, output, copy_len);
+ }
+}
/* Set an fnode to default format. */
buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
get_float_string (dtp, &f, source , kind, 1, buffer,
- precision, buf_size, result, &flt_str_len);
+ precision, buf_size, result, &flt_str_len);
write_float_string (dtp, result, flt_str_len);
dtp->u.p.scale_factor = orig_scale;
buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
get_float_string (dtp, &f, source , kind, 0, buffer,
- precision, buf_size, result1, &flt_str_len1);
+ precision, buf_size, result1, &flt_str_len1);
get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
- precision, buf_size, result2, &flt_str_len2);
+ precision, buf_size, result2, &flt_str_len2);
if (!dtp->u.p.namelist_mode)
{
lblanks = width - flt_str_len1 - flt_str_len2 - 3;
len = strlen (base->var_name);
base_name_len = strlen (base_name);
for (dim_i = 0; dim_i < base_name_len; dim_i++)
- {
+ {
cup = safe_toupper (base_name[dim_i]);
write_character (dtp, &cup, 1, 1, NODELIM);
- }
+ }
}
clen = strlen (obj->var_name);
for (dim_i = len; dim_i < clen; dim_i++)
case BT_INTEGER:
write_integer (dtp, p, len);
- break;
+ break;
case BT_LOGICAL:
write_logical (dtp, p, len);
- break;
+ break;
case BT_CHARACTER:
if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
write_character (dtp, p, 4, obj->string_length, DELIM);
else
write_character (dtp, p, 1, obj->string_length, DELIM);
- break;
+ break;
case BT_REAL:
write_real (dtp, p, len);
- break;
+ break;
case BT_COMPLEX:
dtp->u.p.no_leading_blank = 0;
num++;
- write_complex (dtp, p, len, obj_size);
- break;
+ write_complex (dtp, p, len, obj_size);
+ break;
case BT_DERIVED:
case BT_CLASS:
free (ext_name);
goto obj_loop;
- default:
+ default:
internal_error (&dtp->common, "Bad type for namelist write");
- }
+ }
/* Reset the leading blank suppression, write a comma (or semi-colon)
and, if 5 values have been output, write a newline and advance
switch (dtp->u.p.current_unit->delim_status)
{
case DELIM_APOSTROPHE:
- dtp->u.p.nml_delim = '\'';
+ dtp->u.p.nml_delim = '\'';
break;
case DELIM_QUOTE:
case DELIM_UNSPECIFIED:
#include "config.h"
+/* Math function dispatch macros for kind=16. The type and its math functions
+ vary by platform: _Float128 (IEC 60559), __float128 (libquadmath, including
+ POWER_IEEE128), or 128-bit long double. */
+#ifdef HAVE_GFC_REAL_16
+# if defined(GFC_REAL_16_IS_FLOAT128)
+# if defined(GFC_REAL_16_USE_IEC_60559)
+# define GFC_REAL_16_FREXP(x, e) frexpf128 (x, e)
+# define GFC_REAL_16_FABS(x) fabsf128 (x)
+# define GFC_REAL_16_SCALBN(x, n) scalbnf128 (x, n)
+# else /* libquadmath __float128, including POWER_IEEE128 */
+# define GFC_REAL_16_FREXP(x, e) frexpq (x, e)
+# define GFC_REAL_16_FABS(x) fabsq (x)
+# define GFC_REAL_16_SCALBN(x, n) scalbnq (x, n)
+# endif
+# else /* 128-bit long double */
+# define GFC_REAL_16_FREXP(x, e) frexpl (x, e)
+# define GFC_REAL_16_FABS(x) fabsl (x)
+# define GFC_REAL_16_SCALBN(x, n) scalbnl (x, n)
+# endif
+#endif /* HAVE_GFC_REAL_16 */
+
+/* Helper function for EX format specifier.
+
+ Returns 0 on success, -1 on error. Fills 'buffer' with the hexadecimal
+ floating-point representation of the input value derived from the
+ IEEE-754 bit representations. Non-IEEE-754 representations are not
+ supported. Sets '*res_len' to the length of the string,
+ excluding NUL terminator. The buffer must be at least 64 bytes to
+ contain the resulting string for all kinds. */
+static int
+get_float_hex_string (const void *source, int kind, char *buffer,
+ int *res_len)
+{
+ int result = -1;
+ bool is_negative;
+ *res_len = 0;
+
+ switch (kind)
+ {
+ case 4:
+ {
+ GFC_REAL_4 val;
+ GFC_REAL_4 mant;
+ int expon;
+ int int_part;
+ unsigned int frac_part;
+
+ val = *(const GFC_REAL_4 *) source;
+ is_negative = signbit (val);
+ if (val == 0.0f)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = frexpf (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != 0.0f)
+ {
+ mant = fabsf (mant);
+ mant = scalbnf (mant, 4);
+ expon -= 4;
+ if (mant < 8.f)
+ {
+ mant = scalbnf (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 24 is the nearest integer divisible by 4 that is >= 23 (mantissa bits
+ for kind=4). (24-4)/4 = 5 hex digits for the fractional part. */
+ frac_part = (unsigned int) scalbnf (mant - (GFC_REAL_4) int_part, 24 - 4);
+ if (is_negative)
+ result = snprintf (buffer, 16, "-0X%X.%5.5XP%+d", int_part, frac_part, expon);
+ else
+ result = snprintf (buffer, 16, "0X%X.%5.5XP%+d", int_part, frac_part, expon);
+ }
+ break;
+ case 8:
+ {
+ double val;
+ double mant;
+ int expon;
+ int int_part;
+ unsigned long frac_part;
+
+ val = *(const GFC_REAL_8 *) source;
+ is_negative = signbit (val);
+ if (val == 0.0)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = frexp (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != 0.0)
+ {
+ mant = fabs (mant);
+ mant = scalbn (mant, 4);
+ expon -= 4;
+ if (mant < 8.)
+ {
+ mant = scalbn (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 56 is the nearest integer divisible by 4 that is >= 53 (mantissa bits
+ for kind=8). (56-4)/4 = 13 hex digits for the fractional part. */
+ frac_part = (unsigned long) scalbn (mant - (double) int_part, 56 - 4);
+ if (is_negative)
+ result = snprintf (buffer, 25, "-0X%X.%13.13lXP%+d", int_part, frac_part, expon);
+ else
+ result = snprintf (buffer, 25, "0X%X.%13.13lXP%+d", int_part, frac_part, expon);
+ }
+ break;
+#ifdef HAVE_GFC_REAL_10
+ case 10:
+ {
+ GFC_REAL_10 val;
+ GFC_REAL_10 mant;
+ int expon;
+ int int_part;
+ unsigned long long frac_part;
+
+ val = *(const GFC_REAL_10 *) source;
+ is_negative = signbit (val);
+ if (val == 0.0L)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = frexpl (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != 0.0L)
+ {
+ mant = fabsl (mant);
+ mant = scalbnl (mant, 4);
+ expon -= 4;
+ if (mant < 8.L)
+ {
+ mant = scalbnl (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 64 is the nearest integer divisible by 4 that is >= 64 (mantissa bits
+ for kind=10). (64-4)/4 = 15 hex digits for the fractional part. */
+ frac_part = (unsigned long long) scalbnl (mant - (GFC_REAL_10) int_part, 64 - 4);
+ if (is_negative)
+ result = snprintf (buffer, 28, "-0X%X.%15.15llXP%+d", int_part, frac_part, expon);
+ else
+ result = snprintf (buffer, 28, "0X%X.%15.15llXP%+d", int_part, frac_part, expon);
+ }
+ break;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ case 16:
+ {
+ GFC_REAL_16 val;
+ GFC_REAL_16 mant;
+ int expon;
+ int int_part;
+ unsigned long long frac_hi, frac_lo;
+ GFC_REAL_16 frac_val, frac_lo_val;
+
+ val = *(const GFC_REAL_16 *) source;
+ is_negative = signbit (val);
+ if (val == (GFC_REAL_16) 0.0)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = GFC_REAL_16_FREXP (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != (GFC_REAL_16) 0.0)
+ {
+ mant = GFC_REAL_16_FABS (mant);
+ mant = GFC_REAL_16_SCALBN (mant, 4);
+ expon -= 4;
+ if (mant < (GFC_REAL_16) 8.)
+ {
+ mant = GFC_REAL_16_SCALBN (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 116 is the nearest integer divisible by 4 that is >= 113 (mantissa
+ bits for kind=16). (116-4)/4 = 28 hex digits for the fractional
+ part, split into two 56-bit halves (14 hex digits each) to fit in
+ unsigned long long. */
+ frac_val = mant - (GFC_REAL_16) int_part;
+ frac_hi = (unsigned long long) GFC_REAL_16_SCALBN (frac_val, 56);
+ frac_lo_val = frac_val - GFC_REAL_16_SCALBN ((GFC_REAL_16) frac_hi, -56);
+ frac_lo = (unsigned long long) GFC_REAL_16_SCALBN (frac_lo_val, 112);
+ if (is_negative)
+ result = snprintf (buffer, 42, "-0X%X.%14.14llX%14.14llXP%+d",
+ int_part, frac_hi, frac_lo, expon);
+ else
+ result = snprintf (buffer, 42, "0X%X.%14.14llX%14.14llXP%+d",
+ int_part, frac_hi, frac_lo, expon);
+ }
+ break;
+#endif /* HAVE_GFC_REAL_16 */
+ default:
+ return -1;
+ }
+ if (result < 0)
+ return -1;
+
+ *res_len = result;
+ return 0;
+}
+
typedef enum
{ S_NONE, S_MINUS, S_PLUS }
sign_t;
case FMT_F:
nbefore = ndigits - precision;
if ((w > 0) && (nbefore > (int) size))
- {
+ {
*len = w;
star_fill (result, w);
result[w] = '\0';
/* The exponent must be a multiple of three, with 1-3 digits before
the decimal point. */
if (!zero_flag)
- e--;
+ e--;
if (e >= 0)
nbefore = e % 3;
else
case FMT_ES:
if (!zero_flag)
- e--;
+ e--;
nbefore = 1;
nzero = 0;
nafter = d;
if (i < 0)
{
/* The carry overflowed. Fortunately we have some spare
- space at the start of the buffer. We may discard some
- digits, but this is ok because we already know they are
- zero. */
+ space at the start of the buffer. We may discard some
+ digits, but this is ok because we already know they are
+ zero. */
digits--;
digits[0] = '1';
if (ft == FMT_F)
/* The output is zero, so set the sign according to the sign bit unless
-fno-sign-zero was specified. */
if (compile_options.sign_zero == 1)
- sign = calculate_sign (dtp, sign_bit);
+ sign = calculate_sign (dtp, sign_bit);
else
sign = calculate_sign (dtp, 0);
}
10.0**e even when the final result will not be rounded to 10.0**e.
For these values the exponent returned by atoi has to be decremented
by one. The values y in the ranges
- (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
- (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
- (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
+ (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
+ (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
+ (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)),
100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0
represents d zeroes, by the lines 279 to 297. */
d = precision;\
}\
/* The switch between FMT_E and FMT_F is based on the absolute value. \
- Set r=0 for rounding toward zero and r = 1 otherwise. \
+ Set r=0 for rounding toward zero and r = 1 otherwise. \
If (exp_d - m) == 1 there is no rounding needed. */\
switch (dtp->u.p.current_unit->round_status)\
{\
projects / thirdparty / gcc.git / commitdiff
