#endif
#if defined(PERL_IN_NUMERIC_C)
+#ifndef USE_QUADMATH
sn |NV|mulexp10 |NV value|I32 exponent
#endif
+#endif
#if defined(PERL_IN_UTF8_C)
sRM |UV |check_locale_boundary_crossing|NN const U8* const p|const UV result|NN U8* const ustrp|NN STRLEN *lenp
Apnodf |int |my_snprintf |NN char *buffer|const Size_t len|NN const char *format|...
Apnod |int |my_vsnprintf |NN char *buffer|const Size_t len|NN const char *format|va_list ap
+#ifdef USE_QUADMATH
+Apnd |const char* |quadmath_format_single|NN const char* format
+Apnd |bool|quadmath_format_needed|NN const char* format
+#endif
: Used in mg.c, sv.c
px |void |my_clearenv
#define PerlIO_unread(a,b,c) Perl_PerlIO_unread(aTHX_ a,b,c)
#define PerlIO_write(a,b,c) Perl_PerlIO_write(aTHX_ a,b,c)
#endif
+#if defined(USE_QUADMATH)
+#define quadmath_format_needed Perl_quadmath_format_needed
+#define quadmath_format_single Perl_quadmath_format_single
+#endif
#if defined(WIN32)
#define my_setlocale(a,b) Perl_my_setlocale(aTHX_ a,b)
#endif
#define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c)
# endif
# endif
+# if !defined(USE_QUADMATH)
+# if defined(PERL_IN_NUMERIC_C)
+#define mulexp10 S_mulexp10
+# endif
+# endif
# if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
# endif
#define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e)
#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
# endif
-# if defined(PERL_IN_NUMERIC_C)
-#define mulexp10 S_mulexp10
-# endif
# if defined(PERL_IN_OP_C)
#define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a)
#define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c)
return val;
}
+#ifndef USE_QUADMATH
STATIC NV
S_mulexp10(NV value, I32 exponent)
{
}
return negative ? value / result : value * result;
}
+#endif /* #ifndef USE_QUADMATH */
NV
Perl_my_atof(pTHX_ const char* s)
{
NV x = 0.0;
-#ifdef USE_LOCALE_NUMERIC
+#ifdef USE_QUADMATH
+ Perl_my_atof2(aTHX_ s, &x);
+ return x;
+#else
+# ifdef USE_LOCALE_NUMERIC
PERL_ARGS_ASSERT_MY_ATOF;
{
Perl_atof2(s, x);
RESTORE_LC_NUMERIC();
}
-#else
+# else
Perl_atof2(s, x);
+# endif
#endif
return x;
}
char*
Perl_my_atof2(pTHX_ const char* orig, NV* value)
{
- NV result[3] = {0.0, 0.0, 0.0};
const char* s = orig;
-#ifdef USE_PERL_ATOF
- UV accumulator[2] = {0,0}; /* before/after dp */
- bool negative = 0;
+ NV result[3] = {0.0, 0.0, 0.0};
+#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH)
const char* send = s + strlen(orig); /* one past the last */
+ bool negative = 0;
+#endif
+#if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH)
+ UV accumulator[2] = {0,0}; /* before/after dp */
bool seen_digit = 0;
I32 exp_adjust[2] = {0,0};
I32 exp_acc[2] = {-1, -1};
I32 digit = 0;
I32 old_digit = 0;
I32 sig_digits = 0; /* noof significant digits seen so far */
+#endif
+#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH)
PERL_ARGS_ASSERT_MY_ATOF2;
+ /* leading whitespace */
+ while (isSPACE(*s))
+ ++s;
+
+ /* sign */
+ switch (*s) {
+ case '-':
+ negative = 1;
+ /* FALLTHROUGH */
+ case '+':
+ ++s;
+ }
+#endif
+
+#ifdef USE_QUADMATH
+ {
+ char* endp;
+ if ((endp = S_my_atof_infnan(s, negative, send, value)))
+ return endp;
+ result[2] = strtoflt128(s, &endp);
+ if (s != endp) {
+ *value = negative ? -result[2] : result[2];
+ return endp;
+ }
+ return NULL;
+ }
+#elif defined(USE_PERL_ATOF)
+
/* There is no point in processing more significant digits
* than the NV can hold. Note that NV_DIG is a lower-bound value,
* while we need an upper-bound value. We add 2 to account for this;
/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
- /* leading whitespace */
- while (isSPACE(*s))
- ++s;
-
- /* sign */
- switch (*s) {
- case '-':
- negative = 1;
- /* FALLTHROUGH */
- case '+':
- ++s;
- }
-
{
const char* endp;
if ((endp = S_my_atof_infnan(s, negative, send, value)))
#define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len >= (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END
+#ifdef USE_QUADMATH
+# define my_snprintf Perl_my_snprintf
+# define PERL_MY_SNPRINTF_GUARDED
+#else
#if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; })
# define my_snprintf Perl_my_snprintf
# define PERL_MY_SNPRINTF_GUARDED
#endif
+#endif
+/* There is no quadmath_vsnprintf, and therefore my_vsnprintf()
+ * dies if called under USE_QUADMATH. */
#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC)
# ifdef PERL_USE_GCC_BRACE_GROUPS
# define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; })
int len;
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(fmt);
+ int len;
+ if (!qfmt)
+ Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
+ len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+ if (len == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ if (qfmt != fmt)
+ Safefree(fmt);
+ }
+#else
/* we generate fmt ourselves so it is safe */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
- PERL_MY_SNPRINTF_POST_GUARD(len, max);
GCC_DIAG_RESTORE;
+#endif
+ PERL_MY_SNPRINTF_POST_GUARD(len, max);
RESTORE_LC_NUMERIC();
}
t += fieldsize;
assert(buffer); assert(pat)
#endif
+#if !defined(USE_QUADMATH)
+# if defined(PERL_IN_NUMERIC_C)
+STATIC NV S_mulexp10(NV value, I32 exponent);
+# endif
+#endif
#if !defined(WIN32)
PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
__attribute__nonnull__(pTHX_1);
assert(stash)
#endif
-#if defined(PERL_IN_NUMERIC_C)
-STATIC NV S_mulexp10(NV value, I32 exponent);
-#endif
#if defined(PERL_IN_OP_C)
PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o);
STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
assert(vbuf)
#endif
+#if defined(USE_QUADMATH)
+PERL_CALLCONV bool Perl_quadmath_format_needed(const char* format)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED \
+ assert(format)
+
+PERL_CALLCONV const char* Perl_quadmath_format_single(const char* format)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE \
+ assert(format)
+
+#endif
#if defined(WIN32)
PERL_CALLCONV char* Perl_my_setlocale(pTHX_ int category, const char* locale)
__attribute__pure__;
char *gconvert(double, int, int, char *);
#endif
+#ifdef USE_QUADMATH
+# define SNPRINTF_G(nv, buffer, size, ndig) \
+ quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
+#else
+# define SNPRINTF_G(nv, buffer, size, ndig) \
+ PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
+#endif
+
#ifdef PERL_NEW_COPY_ON_WRITE
# ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
/* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+ SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
+
SvPOK_on(sv);
#else
{
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+ SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
/* If the radix character is UTF-8, and actually is in the
* output, turn on the UTF-8 flag for the scalar */
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf));
+ SNPRINTF_G(nv, ebuf, size, digits);
sv_catpv_nomg(sv, ebuf);
- if (*ebuf) /* May return an empty string for digits==0 */
+ if (*ebuf) /* May return an empty string for digits==0 */
return;
}
} else if (!digits) {
* the time it is not (most compilers these days recognize
* "long double", even if only as a synonym for "double").
*/
-#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && defined(PERL_PRIgldbl)
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
+ defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
long double fv;
# define FV_ISFINITE(x) Perl_isfinitel(x)
# define FV_GF PERL_PRIgldbl
#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALLTHROUGH */
+#ifdef USE_QUADMATH
+ case 'Q':
+ /* FALLTHROUGH */
+#endif
#if IVSIZE >= 8
case 'q': /* qd */
#endif
* The only case where you can pull off long doubles
* is when the format specifier explicitly asks so with
* e.g. "%Lg". */
-#if LONG_DOUBLESIZE > DOUBLESIZE
+#ifdef USE_QUADMATH
+ fv = intsize == 'q' ?
+ va_arg(*args, NV) : va_arg(*args, double);
+#elif LONG_DOUBLESIZE > DOUBLESIZE
fv = intsize == 'q' ?
va_arg(*args, long double) : va_arg(*args, double);
#else
aka precis is 0 */
if ( c == 'g' && precis ) {
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert((NV)fv, (int)precis, 0, PL_efloatbuf));
+ SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis);
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
+#ifdef USE_QUADMATH
+ *--ptr = 'Q';
+#else
static char const ldblf[] = PERL_PRIfldbl;
char const *p = ldblf + sizeof(ldblf) - 3;
while (p >= ldblf) { *--ptr = *p--; }
+#endif
}
#endif
if (has_precis) {
/* hopefully the above makes ptr a very constrained format
* that is safe to use, even though it's not literal */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
-#if defined(HAS_LONG_DOUBLE)
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(ptr);
+ if (!qfmt)
+ Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
+ elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
+ qfmt, fv);
+ if ((IV)elen == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
+ if (qfmt != ptr)
+ Safefree(qfmt);
+ }
+#elif defined(HAS_LONG_DOUBLE)
elen = ((intsize == 'q')
? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
: my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
#endif
/*
+=for apidoc quadmath_format_single
+
+quadmath_snprintf() is very strict about its format string and will
+fail, returning -1, if the format is invalid. It acccepts exactly
+one format spec.
+
+quadmath_format_single() checks that the intended single spec looks
+sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
+and has C<Q> before it. This is not a full "printf syntax check",
+just the basics.
+
+Returns the format if it is valid, NULL if not.
+
+quadmath_format_single() can and will actually patch in the missing
+C<Q>, if necessary. In this case it will return the modified copy of
+the format, B<which the caller will need to free.>
+
+See also L</quadmath_format_needed>.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+const char*
+Perl_quadmath_format_single(const char* format)
+{
+ STRLEN len;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
+
+ if (format[0] != '%' || strchr(format + 1, '%'))
+ return NULL;
+ len = strlen(format);
+ /* minimum length three: %Qg */
+ if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
+ return NULL;
+ if (format[len - 2] != 'Q') {
+ char* fixed;
+ Newx(fixed, len + 1, char);
+ memcpy(fixed, format, len - 1);
+ fixed[len - 1] = 'Q';
+ fixed[len ] = format[len - 1];
+ fixed[len + 1] = 0;
+ return (const char*)fixed;
+ }
+ return format;
+}
+#endif
+
+/*
+=for apidoc quadmath_format_needed
+
+quadmath_format_needed() returns true if the format string seems to
+contain at least one non-Q-prefixed %[efgaEFGA] format specifier,
+or returns false otherwise.
+
+The format specifier detection is not complete printf-syntax detection,
+but it should catch most common cases.
+
+If true is returned, those arguments B<should> in theory be processed
+with quadmath_snprintf(), but in case there is more than one such
+format specifier (see L</quadmath_format_single>), and if there is
+anything else beyond that one (even just a single byte), they
+B<cannot> be processed because quadmath_snprintf() is very strict,
+accepting only one format spec, and nothing else.
+In this case, the code should probably fail.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+bool
+Perl_quadmath_format_needed(const char* format)
+{
+ const char *p = format;
+ const char *q;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
+
+ while ((q = strchr(p, '%'))) {
+ q++;
+ if (*q == '+') /* plus */
+ q++;
+ if (*q == '#') /* alt */
+ q++;
+ if (*q == '*') /* width */
+ q++;
+ else {
+ if (isDIGIT(*q)) {
+ while (isDIGIT(*q)) q++;
+ }
+ }
+ if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
+ q++;
+ if (*q == '*')
+ q++;
+ else
+ while (isDIGIT(*q)) q++;
+ }
+ if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
+ return TRUE;
+ p = q + 1;
+ }
+ return FALSE;
+}
+#endif
+
+/*
=for apidoc my_snprintf
The C library C<snprintf> functionality, if available and
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
- int retval;
+ int retval = -1;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
#ifndef HAS_VSNPRINTF
PERL_UNUSED_VAR(len);
#endif
va_start(ap, format);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(format);
+ bool quadmath_valid = FALSE;
+ if (qfmt) {
+ /* If the format looked promising, use it as quadmath. */
+ retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
+ if (retval == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ quadmath_valid = TRUE;
+ if (qfmt != format)
+ Safefree(qfmt);
+ qfmt = NULL;
+ }
+ assert(qfmt == NULL);
+ /* quadmath_format_single() will return false for example for
+ * "foo = %g", or simply "%g". We could handle the %g by
+ * using quadmath for the NV args. More complex cases of
+ * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
+ * quadmath-valid but has stuff in front).
+ *
+ * Handling the "Q-less" cases right would require walking
+ * through the va_list and rewriting the format, calling
+ * quadmath for the NVs, building a new va_list, and then
+ * letting vsnprintf/vsprintf to take care of the other
+ * arguments. This may be doable.
+ *
+ * We do not attempt that now. But for paranoia, we here try
+ * to detect some common (but not all) cases where the
+ * "Q-less" %[efgaEFGA] formats are present, and die if
+ * detected. This doesn't fix the problem, but it stops the
+ * vsnprintf/vsprintf pulling doubles off the va_list when
+ * __float128 NVs should be pulled off instead.
+ *
+ * If quadmath_format_needed() returns false, we are reasonably
+ * certain that we can call vnsprintf() or vsprintf() safely. */
+ if (!quadmath_valid && quadmath_format_needed(format))
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
+
+ }
+#endif
+ if (retval == -1)
#ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, ap);
+ retval = vsnprintf(buffer, len, format, ap);
#else
- retval = vsprintf(buffer, format, ap);
+ retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
/* vsprintf() shows failure with < 0 */
int
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
{
+#ifdef USE_QUADMATH
+ PERL_UNUSED_ARG(buffer);
+ PERL_UNUSED_ARG(len);
+ PERL_UNUSED_ARG(format);
+ PERL_UNUSED_ARG(ap);
+ Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
+ return 0;
+#else
int retval;
#ifdef NEED_VA_COPY
va_list apc;
)
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
+#endif
}
void
https://perl5.git.perl.org / perl5.git / commitdiff