quadmath NV formatted I/O.

8 files changed, 300 insertions, 37 deletions

diff --git a/embed.fnc b/embed.fnc
index 1214bf78ab..a8789acb24 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2433,8 +2433,10 @@ sn	|void	|mem_log_common	|enum mem_log_type mlt|const UV n|const UV typesize \
 #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
@@ -2644,6 +2646,10 @@ Apnod	|int	|my_sprintf	|NN char *buffer|NN const char *pat|...
 
 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
diff --git a/embed.h b/embed.h
index c65857060b..cd5c1d2519 100644
--- a/embed.h
+++ b/embed.h
@@ -878,6 +878,10 @@
 #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
@@ -1355,6 +1359,11 @@
 #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
@@ -1486,9 +1495,6 @@
 #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)
diff --git a/numeric.c b/numeric.c
index 427900bb30..5691120237 100644
--- a/numeric.c
+++ b/numeric.c
@@ -965,6 +965,7 @@ Perl_grok_atou(const char *pv, const char** endptr)
     return val;
 }
 
+#ifndef USE_QUADMATH
 STATIC NV
 S_mulexp10(NV value, I32 exponent)
 {
@@ -1043,12 +1044,17 @@ 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;
 
     {
@@ -1081,8 +1087,9 @@ Perl_my_atof(pTHX_ const char* s)
             Perl_atof2(s, x);
         RESTORE_LC_NUMERIC();
     }
-#else
+#  else
     Perl_atof2(s, x);
+#  endif
 #endif
     return x;
 }
@@ -1162,12 +1169,14 @@ S_my_atof_infnan(const char* s, bool negative, const char* send, NV* value)
 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};
@@ -1177,9 +1186,39 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
     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;
@@ -1209,19 +1248,6 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value)
 /* 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)))
diff --git a/perl.h b/perl.h
index 751df86c3f..d711b20c5c 100644
--- a/perl.h
+++ b/perl.h
@@ -1562,6 +1562,10 @@ EXTERN_C char *crypt(const char *, const char *);
 
 #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; })
@@ -1573,7 +1577,10 @@ EXTERN_C char *crypt(const char *, const char *);
 #  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; })
diff --git a/pp_ctl.c b/pp_ctl.c
index db125b80be..5036eda4db 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -825,11 +825,25 @@ PP(pp_formline)
                 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;
diff --git a/proto.h b/proto.h
index a0b5c43d32..d6d3a8676a 100644
--- a/proto.h
+++ b/proto.h
@@ -5336,6 +5336,11 @@ PERL_CALLCONV int	Perl_my_sprintf(char *buffer, const char *pat, ...)
 	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);
@@ -6120,9 +6125,6 @@ STATIC AV*	S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level)
 	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)
@@ -8068,6 +8070,18 @@ PERL_CALLCONV SSize_t	Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_
 	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__;
diff --git a/sv.c b/sv.c
index 3f7fce603e..04c282656a 100644
--- a/sv.c
+++ b/sv.c
@@ -40,6 +40,14 @@
   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 */
@@ -3045,12 +3053,13 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
                 /* 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 */
@@ -11023,9 +11032,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                     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) {
@@ -11088,7 +11097,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
          * 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
@@ -11394,6 +11404,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
 #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
@@ -11823,7 +11837,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                  * 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
@@ -11973,7 +11990,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
 		   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);
@@ -12178,9 +12195,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
 		    /* 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) {
@@ -12211,7 +12232,19 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p
                 /* 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));
diff --git a/util.c b/util.c
index e87813bfaa..ae3b833fff 100644
--- a/util.c
+++ b/util.c
@@ -4908,6 +4908,112 @@ Perl_my_sprintf(char *buffer, const char* pat, ...)
 #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
@@ -4922,17 +5028,59 @@ getting C<vsnprintf>.
 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 */
@@ -4961,6 +5109,14 @@ C<sv_vcatpvf> instead, or getting C<vsnprintf>.
 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;
@@ -4993,6 +5149,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     )
 	Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
     return retval;
+#endif
 }
 
 void