Create the equivalence tables based on

[p5sagit/p5-mst-13.2.git] / sv.c

diff --git a/sv.c b/sv.c
index a7e3839..97f97f2 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -15,34 +15,6 @@
 #define PERL_IN_SV_C
 #include "perl.h"
 
-#ifdef OVR_DBL_DIG
-/* Use an overridden DBL_DIG */
-# ifdef DBL_DIG
-#  undef DBL_DIG
-# endif
-# define DBL_DIG OVR_DBL_DIG
-#else
-/* The following is all to get DBL_DIG, in order to pick a nice
-   default value for printing floating point numbers in Gconvert.
-   (see config.h)
-*/
-#ifdef I_LIMITS
-#include <limits.h>
-#endif
-#ifdef I_FLOAT
-#include <float.h>
-#endif
-#ifndef HAS_DBL_DIG
-#define DBL_DIG        15   /* A guess that works lots of places */
-#endif
-#endif
-
-#ifdef PERL_OBJECT
-#define VTBL this->*vtbl
-#else /* !PERL_OBJECT */
-#define VTBL *vtbl
-#endif /* PERL_OBJECT */
-
 #define FCALL *f
 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
 
@@ -1320,7 +1292,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
            (void)SvNOK_on(sv);
            (void)SvIOK_on(sv);
 #if defined(USE_LONG_DOUBLE)
-           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
                                  (unsigned long)sv, SvNVX(sv)));
 #else
            DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
@@ -1438,7 +1410,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 #if defined(USE_LONG_DOUBLE)
        DEBUG_c({
            RESTORE_NUMERIC_STANDARD();
-           PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIg64 ")\n",
+           PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
                          (unsigned long)sv, SvNVX(sv));
            RESTORE_NUMERIC_LOCAL();
        });
@@ -1477,7 +1449,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 #if defined(USE_LONG_DOUBLE)
     DEBUG_c({
        RESTORE_NUMERIC_STANDARD();
-       PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
+       PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
                      (unsigned long)sv, SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
     });
@@ -1711,7 +1683,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            goto tokensave;
        }
        if (SvNOKp(sv)) {
-           Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
+           Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
            tsv = Nullsv;
            goto tokensave;
        }
@@ -1835,7 +1807,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
        else
 #endif /*apollo*/
        {
-           Gconvert(SvNVX(sv), DBL_DIG, 0, s);
+           Gconvert(SvNVX(sv), NV_DIG, 0, s);
        }
        errno = olderrno;
 #ifdef FIXNEGATIVEZERO
@@ -2743,7 +2715,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
            MGVTBL* vtbl = mg->mg_virtual;
            *mgp = mg->mg_moremagic;
            if (vtbl && (vtbl->svt_free != NULL))
-               (VTBL->svt_free)(aTHX_ sv, mg);
+               CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
            if (mg->mg_ptr && mg->mg_type != 'g')
                if (mg->mg_len >= 0)
                    Safefree(mg->mg_ptr);
@@ -4731,7 +4703,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        char *eptr = Nullch;
        STRLEN elen = 0;
-       char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
+       /* Times 4: a decimal digit takes more than 3 binary digits.
+        * NV_DIG: mantissa takes than many decimal digits.
+        * Plus 32: Playing safe. */
+       char ebuf[IV_DIG * 4 + NV_DIG + 32];
+        /* large enough for "%#.#f" --chip */
+       /* what about long double NVs? --jhi */
        char c;
        int i;
        unsigned base;
@@ -4925,7 +4902,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            goto integer;
 
        case 'D':
+#ifdef IV_IS_QUAD
+           /* nothing */
+#else
            intsize = 'l';
+#endif
            /* FALL THROUGH */
        case 'd':
        case 'i':
@@ -4973,7 +4954,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            goto integer;
 
        case 'U':
+#ifdef IV_IS_QUAD
+           /* nothing */
+#else
            intsize = 'l';
+#endif
            /* FALL THROUGH */
        case 'u':
            base = 10;
@@ -4984,7 +4969,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            goto uns_integer;
 
        case 'O':
+#ifdef IV_IS_QUAD
+           /* nothing */
+#else
            intsize = 'l';
+#endif
            /* FALL THROUGH */
        case 'o':
            base = 8;
@@ -5117,8 +5106,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            *--eptr = c;
 #ifdef USE_LONG_DOUBLE
            {
-               char* p = PRIfldbl + sizeof(PRIfldbl) - 3;
-               while (p >= PRIfldbl) { *--eptr = *p-- }
+               char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
+               while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
            }
 #endif
            if (has_precis) {
@@ -5193,10 +5182,21 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                SV *msg = sv_newmortal();
                Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
                          (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
-               if (c)
-                   Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
-                             c & 0xFF);
-               else
+               if (c) {
+#ifdef UV_IS_QUAD
+                   if (isPRINT(c))
+                       Perl_sv_catpvf(aTHX_ msg, 
+                                      "\"%%%c\"", c & 0xFF);
+                   else
+                       Perl_sv_catpvf(aTHX_ msg,
+                                      "\"%%\\%03" PERL_PRIo64 "\"",
+                                      (UV)c & 0xFF);
+#else
+                   Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
+                                  "\"%%%c\"" : "\"%%\\%03o\"",
+                                  c & 0xFF);
+#endif
+               } else
                    sv_catpv(msg, "end of string");
                Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
            }