#ifdef NV_PRESERVES_UV
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (Perl_isnan(SvNVX(sv))) {
+ SvUV_set(sv, 0);
+ SvIsUV_on(sv);
+ return FALSE;
+ }
+#endif
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
return (IV)value;
}
}
+
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
if (!(numtype & IS_NUMBER_NEG))
return value;
}
+
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return UV_MAX; /* So wrong. */
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
== IS_NUMBER_IN_UV) {
/* It's definitely an integer */
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
- } else
- SvNV_set(sv, Atof(SvPVX_const(sv)));
+ } else {
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ SvNV_set(sv, NV_NAN);
+ } else
+ SvNV_set(sv, Atof(SvPVX_const(sv)));
+ }
if (numtype)
SvNOK_on(sv);
else
/* Both already have p flags, so do nothing */
} else {
const NV nv = SvNVX(sv);
+ /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
if (SvIVX(sv) == I_V(nv)) {
SvNOK_on(sv);
* maxlen too small) returns zero. */
STATIC size_t
S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
+ /* XXX this should be an assert */
if (maxlen < 4) /* "Inf\0", "NaN\0" */
return 0;
else {
char* s = buffer;
- if (Perl_isinf(nv)) {
- if (nv < 0) {
- if (maxlen < 5) /* "-Inf\0" */
- return 0;
- *s++ = '-';
- }
- *s++ = 'I';
- *s++ = 'n';
- *s++ = 'f';
- }
- else if (Perl_isnan(nv)) {
+ /* isnan must be first due to NAN_COMPARE_BROKEN builds, since NAN might
+ use the broken for NAN >/< ops in the inf check, and then the inf
+ check returns true for NAN on NAN_COMPARE_BROKEN compilers */
+ if (Perl_isnan(nv)) {
*s++ = 'N';
*s++ = 'a';
*s++ = 'N';
* provide a format string so that the user can decide?
* NOTE: would affect the maxlen and assert() logic.*/
}
+ else if (Perl_isinf(nv)) {
+ if (nv < 0) {
+ if (maxlen < 5) /* "-Inf\0" */
+ return 0;
+ *s++ = '-';
+ }
+ *s++ = 'I';
+ *s++ = 'n';
+ *s++ = 'f';
+ }
+
else
return 0;
assert((s == buffer + 3) || (s == buffer + 4));
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvNVX(sv) == 0.0) {
+ if (SvNVX(sv) == 0.0
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ && !Perl_isnan(SvNVX(sv))
+#endif
+ ) {
s = SvGROW_mutable(sv, 2);
*s++ = '0';
*s = '\0';
PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
- if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
- mg_get(ssv);
- s = SvPV_nomg_const(ssv,len);
+ s = SvPV_flags_const(ssv,len,flags & SV_GMAGIC);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
+ if (import_flag == GVf_IMPORTED_SV) {
+ if (intro) {
+ dSS_ADD;
+ SS_ADD_PTR(gp_ref(GvGP(dstr)));
+ SS_ADD_UV(SAVEt_GP_ALIASED_SV
+ | cBOOL(GvALIASED_SV(dstr)) << 8);
+ SS_ADD_END(2);
+ }
+ /* Turn off the flag if sref is not referenced elsewhere,
+ even by weak refs. (SvRMAGICAL is a pessimistic check for
+ back refs.) */
+ if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
+ GvALIASED_SV_off(dstr);
+ else
+ GvALIASED_SV_on(dstr);
+ }
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
# define DOUBLEDOUBLE_MAXBITS 1028
#endif
-#ifdef LONGDOUBLE_X86_80_BIT
-# undef LONGDOUBLE_HAS_IMPLICIT_BIT
-#else
-# define LONGDOUBLE_HAS_IMPLICIT_BIT
-#endif
-
-#ifdef LONGDOUBLE_DOUBLEDOUBLE
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
- * of 4 bits); 1 for the implicit 1, and at most 1028 bits of mantissa,
- * four bits per xdigit. */
+ * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
+ * per xdigit. */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
#else
-/* vhex will contain the values (0..15) of the hex digits ("nybbles"
- * of 4 bits); 1 for the implicit 1, and at most 128 bits of mantissa,
- * four bits per xdigit. */
# define VHEX_SIZE (1+128/4)
#endif
* long doubles, or long doubles being equal to doubles) then we will
* fall back to the ldexp/frexp route, with which we can retrieve at
* most as many bits as our widest unsigned integer type is. We try
- * to get a 64-bit unsigned integer even if we are not having 64-bit
- * UV. */
+ * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
+ *
+ * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
+ * set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
+ */
#if defined(HAS_QUAD) && defined(Uquad_t)
# define MANTISSATYPE Uquad_t
# define MANTISSASIZE 8
#else
-# define MANTISSATYPE UV /* May lose precision if UVSIZE is not 8. */
+# define MANTISSATYPE UV
# define MANTISSASIZE UVSIZE
#endif
+/* We make here the wild assumption that the endianness of doubles
+ * is similar to the endianness of integers, and that there is no
+ * middle-endianness. This may come back to haunt us (the rumor
+ * has it that ARM can be quite haunted). */
+#if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
+ defined(DOUBLEKIND_LITTLE_ENDIAN)
+# define HEXTRACT_LITTLE_ENDIAN
+#else
+# define HEXTRACT_BIG_ENDIAN
+#endif
+
/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
* the hexadecimal values (for %a/%A). The nv is the NV where the value
* are being extracted from (either directly from the long double in-memory
#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
#define HEXTRACT_OUTPUT(ix) \
STMT_START { \
- HEXTRACT_OUTPUT_HI(ix); \
- HEXTRACT_OUTPUT_LO(ix); \
- } STMT_END
+ HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
+ } STMT_END
#define HEXTRACT_COUNT(ix, c) \
STMT_START { \
- v += c; \
- if (ix < ixmin) \
- ixmin = ix; \
- else if (ix > ixmax) \
- ixmax = ix; \
- } STMT_END
-#ifdef LONGDOUBLE_HAS_IMPLICIT_BIT
+ v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
+ } STMT_END
+#define HEXTRACT_BYTE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+ } STMT_END
+#define HEXTRACT_LO_NYBBLE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
+ } STMT_END
# define HEXTRACT_IMPLICIT_BIT(nv) \
- if (nv != 0.0 && vend) \
- *v++ = 1; \
- else \
- v++;
+ STMT_START { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } STMT_END
+
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
#else
-# undef HEXTRACT_IMPLICIT_BIT
+# define HEXTRACTSIZE NVSIZE
#endif
- /* First see if we are using long doubles. */
-#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
const U8* nvp = (const U8*)(&nv);
-# ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
-# else
-# define HEXTRACTSIZE NVSIZE
-# endif
const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1;
(void)Perl_frexp(PERL_ABS(nv), exponent);
if (vend && (vend <= vhex || vend > vmaxend))
Perl_croak(aTHX_ "Hexadecimal float: internal error");
+
+ /* First check if using long doubles. */
+#if NVSIZE > DOUBLESIZE
# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
/* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
* 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
* the 15,14 are the sign+exponent. */
HEXTRACT_IMPLICIT_BIT(nv);
for (ix = 13; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
/* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
* the 0,1 are the sign+exponent. */
HEXTRACT_IMPLICIT_BIT(nv);
for (ix = 2; ix <= 15; ix++) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
/* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
* be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
* meaning that 2 or 6 bytes are empty padding. */
/* The bytes 7..0 are the mantissa/fraction */
- /* There explicitly is *no* implicit bit in this case. */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
for (ix = 7; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
/* Does this format ever happen? (Wikipedia says the Motorola
* 6888x math coprocessors used format _like_ this but padded
* to 96 bits with 16 unused bits between the exponent and the
* mantissa.) */
- /* There explicitly is *no* implicit bit in this case. */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
for (ix = 0; ix < 8; ix++) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_BYTE(ix);
}
# elif defined(LONGDOUBLE_DOUBLEDOUBLE)
- /* The little-endian double-double is used .. somewhere?
+ /* Double-double format: two doubles next to each other.
+ * The first double is the high-order one, exactly like
+ * it would be for a "lone" double. The second double
+ * is shifted down using the exponent so that that there
+ * are no common bits. The tricky part is that the value
+ * of the double-double is the SUM of the two doubles and
+ * the second one can be also NEGATIVE.
+ *
+ * Because of this tricky construction the bytewise extraction we
+ * use for the other long double formats doesn't work, we must
+ * extract the values bit by bit.
+ *
+ * The little-endian double-double is used .. somewhere?
*
* The big endian double-double is used in e.g. PPC/Power (AIX)
* and MIPS (SGI).
* The mantissa bits are in two separate stretches, e.g. for -0.1L:
* 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
* 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
- *
- * With the double-double format the bytewise extraction we use
- * for the other long double formats doesn't work, we must extract
- * the values bit by bit. */
+ */
if (nv == (NV)0.0) {
if (vend)
U8 ha = 0x0; /* hexvalue accumulator */
U8 hd = 0x8; /* hexvalue digit */
+ /* Shift d and e (and update exponent) so that e <= d < 2*e,
+ * this is essentially manual frexp(). Multiplying by 0.5 and
+ * doubling should be lossless in binary floating point. */
+
*exponent = 1;
while (e > d) {
"Hexadecimal float: unsupported long double format");
# endif
#else
- /* If not using long doubles (or if the long double format is
- * known but not yet supported), try to retrieve the mantissa bits
- * via frexp+ldexp. */
-
- NV norm = Perl_frexp(PERL_ABS(nv), exponent);
- /* Theoretically we have all the bytes [0, MANTISSASIZE-1] to
- * inspect; but in practice we don't want the leading nybbles that
- * are zero. With the common IEEE 754 value for NV_MANT_DIG being
- * 53, we want the limit byte to be (int)((53-1)/8) == 6.
- *
- * Note that this is _not_ inspecting the in-memory format of the
- * nv (as opposed to the long double method), but instead the UV
- * retrieved with the frexp+ldexp invocation. */
-# if MANTISSASIZE * 8 > NV_MANT_DIG
- MANTISSATYPE mantissa = (MANTISSATYPE)Perl_ldexp(norm, NV_MANT_DIG);
- int limit_byte = (NV_MANT_DIG - 1) / 8;
-# else
- /* There will be low-order precision loss. Try to salvage as many
- * bits as possible. Will truncate, not round. */
- MANTISSATYPE mantissa =
- Perl_ldexp(norm,
- /* The highest possible shift by two that fits in the
- * mantissa and is aligned (by four) the same was as
- * NV_MANT_DIG. */
- MANTISSASIZE * 8 - (4 - NV_MANT_DIG % 4));
- int limit_byte = MANTISSASIZE - 1;
-# endif
- const U8* nvp = (const U8*)(&mantissa);
-# define HEXTRACTSIZE MANTISSASIZE
- /* We make here the wild assumption that the endianness of doubles
- * is similar to the endianness of integers, and that there is no
- * middle-endianness. This may come back to haunt us (the rumor
- * has it that ARM can be quite haunted).
+ /* Using normal doubles, not long doubles.
*
* We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
- * bytes, since we might need to handle printf precision, and also
- * insert the radix.
- */
-# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
- defined(LONGDOUBLEKIND_LITTLE_ENDIAN)
- /* Little endian. */
- for (ix = limit_byte; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ * bytes, since we might need to handle printf precision, and
+ * also need to insert the radix. */
+ HEXTRACT_IMPLICIT_BIT(nv);
+# ifdef HEXTRACT_LITTLE_ENDIAN
+ HEXTRACT_LO_NYBBLE(6);
+ for (ix = 5; ix >= 0; ix--) {
+ HEXTRACT_BYTE(ix);
}
# else
- /* Big endian. */
- for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) {
- if (vend)
- HEXTRACT_OUTPUT(ix);
- else
- HEXTRACT_COUNT(ix, 2);
+ HEXTRACT_LO_NYBBLE(1);
+ for (ix = 2; ix < HEXTRACTSIZE; ix++) {
+ HEXTRACT_BYTE(ix);
}
# endif
- /* If there are not enough bits in MANTISSATYPE, we couldn't get
- * all of them, issue a warning.
- *
- * Note that NV_PRESERVES_UV_BITS would not help here, it is the
- * wrong way around. */
-# if NV_MANT_DIG > MANTISSASIZE * 8
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Hexadecimal float: precision loss");
-# endif
#endif
/* Croak for various reasons: if the output pointer escaped the
* output buffer, if the extraction index escaped the extraction
* 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
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && defined(PERL_PRIgldbl)
long double fv;
# define FV_ISFINITE(x) Perl_isfinitel(x)
# define FV_GF PERL_PRIgldbl
* match its internal structure. */
/* Note: fv can be (and often is) long double.
- * Here it is implicitly cast to NV. */
- vend = S_hextract(aTHX_ fv, &exponent, vhex, NULL);
- S_hextract(aTHX_ fv, &exponent, vhex, vend);
+ * Here it is explicitly cast to NV. */
+ vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
-# ifdef LONGDOUBLE_HAS_IMPLICIT_BIT
- exponent--;
-# else
+# ifdef LONGDOUBLE_X86_80_BIT
exponent -= 4;
+# else
+ exponent--;
# endif
#endif
}
#if NVSIZE == DOUBLESIZE
- exponent--;
+ if (fv != 0.0)
+ exponent--;
#endif
if (precis > 0) {
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
+ case SAVEt_GP_ALIASED_SV:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gp_dup((GP *)ptr, param);
+ ((GP *)ptr)->gp_refcnt++;
+ break;
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
+ PL_sawalias = proto_perl->Isawalias;
#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
#endif