summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.h14
-rwxr-xr-xembed.pl4
-rw-r--r--objXSUB.h2
-rw-r--r--op.c12
-rw-r--r--perl.h5
-rw-r--r--pp.c774
-rw-r--r--pp_hot.c187
-rw-r--r--proto.h4
-rw-r--r--sv.c947
-rw-r--r--sv.h10
-rw-r--r--t/lib/peek.t26
-rwxr-xr-xt/op/cmp.t176
-rwxr-xr-xt/op/numconvert.t24
13 files changed, 1914 insertions, 271 deletions
diff --git a/embed.h b/embed.h
index 70d4c36f6b..27b828cc73 100644
--- a/embed.h
+++ b/embed.h
@@ -1087,6 +1087,10 @@
# if defined(DEBUGGING)
#define del_sv S_del_sv
# endif
+# if !defined(NV_PRESERVES_UV)
+#define sv_2inuv_non_preserve S_sv_2inuv_non_preserve
+#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
+# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
#define check_uni S_check_uni
@@ -2545,6 +2549,10 @@
# if defined(DEBUGGING)
#define del_sv(a) S_del_sv(aTHX_ a)
# endif
+# if !defined(NV_PRESERVES_UV)
+#define sv_2inuv_non_preserve(a,b) S_sv_2inuv_non_preserve(aTHX_ a,b)
+#define sv_2iuv_non_preserve(a,b) S_sv_2iuv_non_preserve(aTHX_ a,b)
+# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
#define check_uni() S_check_uni(aTHX)
@@ -4951,6 +4959,12 @@
#define S_del_sv CPerlObj::S_del_sv
#define del_sv S_del_sv
# endif
+# if !defined(NV_PRESERVES_UV)
+#define S_sv_2inuv_non_preserve CPerlObj::S_sv_2inuv_non_preserve
+#define sv_2inuv_non_preserve S_sv_2inuv_non_preserve
+#define S_sv_2iuv_non_preserve CPerlObj::S_sv_2iuv_non_preserve
+#define sv_2iuv_non_preserve S_sv_2iuv_non_preserve
+# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
#define S_check_uni CPerlObj::S_check_uni
diff --git a/embed.pl b/embed.pl
index fa22c84f9f..609b351cbb 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2467,6 +2467,10 @@ s |void |sv_del_backref |SV *sv
# if defined(DEBUGGING)
s |void |del_sv |SV *p
# endif
+# if !defined(NV_PRESERVES_UV)
+s |int |sv_2inuv_non_preserve |SV *sv|I32 numtype
+s |int |sv_2iuv_non_preserve |SV *sv|I32 numtype
+# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
diff --git a/objXSUB.h b/objXSUB.h
index 5a3850cb4e..3d0591c899 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -2292,6 +2292,8 @@
#if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT)
# if defined(DEBUGGING)
# endif
+# if !defined(NV_PRESERVES_UV)
+# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
#if 0
diff --git a/op.c b/op.c
index b6a9c7c04f..e6f7804e9d 100644
--- a/op.c
+++ b/op.c
@@ -2249,13 +2249,11 @@ Perl_fold_constants(pTHX_ register OP *o)
if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
type != OP_NEGATE)
{
- IV iv = SvIV(sv);
- if ((NV)iv == SvNV(sv)) {
- SvREFCNT_dec(sv);
- sv = newSViv(iv);
- }
- else
- SvIOK_off(sv); /* undo SvIV() damage */
+#ifdef PERL_PRESERVE_IVUV
+ /* Only bother to attempt to fold to IV if
+ most operators will benefit */
+ SvIV_please(sv);
+#endif
}
return newSVOP(OP_CONST, 0, sv);
}
diff --git a/perl.h b/perl.h
index a55ebefc6e..42c5246cc4 100644
--- a/perl.h
+++ b/perl.h
@@ -1084,6 +1084,11 @@ typedef UVTYPE UV;
#define IV_DIG (BIT_DIGITS(IVSIZE * 8))
#define UV_DIG (BIT_DIGITS(UVSIZE * 8))
+/* We like our integers to stay integers. */
+#ifndef NO_PERL_PRESERVE_IVUV
+#define PERL_PRESERVE_IVUV
+#endif
+
/*
* The macros INT2PTR and NUM2PTR are (despite their names)
* bi-directional: they will convert int/float to or from pointers.
diff --git a/pp.c b/pp.c
index eaa4d17220..2cb463ee9e 100644
--- a/pp.c
+++ b/pp.c
@@ -925,6 +925,114 @@ PP(pp_pow)
PP(pp_multiply)
{
djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ /* Unless the left argument is integer in range we are going to have to
+ use NV maths. Hence only attempt to coerce the right argument if
+ we know the left is integer. */
+ /* Left operand is defined, so is it IV? */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+ const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
+ const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
+ UV alow;
+ UV ahigh;
+ UV blow;
+ UV bhigh;
+
+ if (auvok) {
+ alow = SvUVX(TOPm1s);
+ } else {
+ IV aiv = SvIVX(TOPm1s);
+ if (aiv >= 0) {
+ alow = aiv;
+ auvok = TRUE; /* effectively it's a UV now */
+ } else {
+ alow = -aiv; /* abs, auvok == false records sign */
+ }
+ }
+ if (buvok) {
+ blow = SvUVX(TOPs);
+ } else {
+ IV biv = SvIVX(TOPs);
+ if (biv >= 0) {
+ blow = biv;
+ buvok = TRUE; /* effectively it's a UV now */
+ } else {
+ blow = -biv; /* abs, buvok == false records sign */
+ }
+ }
+
+ /* If this does sign extension on unsigned it's time for plan B */
+ ahigh = alow >> (4 * sizeof (UV));
+ alow &= botmask;
+ bhigh = blow >> (4 * sizeof (UV));
+ blow &= botmask;
+ if (ahigh && bhigh) {
+ /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
+ which is overflow. Drop to NVs below. */
+ } else if (!ahigh && !bhigh) {
+ /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
+ so the unsigned multiply cannot overflow. */
+ UV product = alow * blow;
+ if (auvok == buvok) {
+ /* -ve * -ve or +ve * +ve gives a +ve result. */
+ SP--;
+ SETu( product );
+ RETURN;
+ } else if (product <= (UV)IV_MIN) {
+ /* 2s complement assumption that (UV)-IV_MIN is correct. */
+ /* -ve result, which could overflow an IV */
+ SP--;
+ SETi( -product );
+ RETURN;
+ } /* else drop to NVs below. */
+ } else {
+ /* One operand is large, 1 small */
+ UV product_middle;
+ if (bhigh) {
+ /* swap the operands */
+ ahigh = bhigh;
+ bhigh = blow; /* bhigh now the temp var for the swap */
+ blow = alow;
+ alow = bhigh;
+ }
+ /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
+ multiplies can't overflow. shift can, add can, -ve can. */
+ product_middle = ahigh * blow;
+ if (!(product_middle & topmask)) {
+ /* OK, (ahigh * blow) won't lose bits when we shift it. */
+ UV product_low;
+ product_middle <<= (4 * sizeof (UV));
+ product_low = alow * blow;
+
+ /* as for pp_add, UV + something mustn't get smaller.
+ IIRC ANSI mandates this wrapping *behaviour* for
+ unsigned whatever the actual representation*/
+ product_low += product_middle;
+ if (product_low >= product_middle) {
+ /* didn't overflow */
+ if (auvok == buvok) {
+ /* -ve * -ve or +ve * +ve gives a +ve result. */
+ SP--;
+ SETu( product_low );
+ RETURN;
+ } else if (product_low <= (UV)IV_MIN) {
+ /* 2s complement assumption again */
+ /* -ve result, which could overflow an IV */
+ SP--;
+ SETi( -product_low );
+ RETURN;
+ } /* else drop to NVs below. */
+ }
+ } /* product_middle too large */
+ } /* ahigh && bhigh */
+ } /* SvIOK(TOPm1s) */
+ } /* SvIOK(TOPs) */
+#endif
{
dPOPTOPnnrl;
SETn( left * right );
@@ -1116,11 +1224,146 @@ PP(pp_repeat)
PP(pp_subtract)
{
- djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
+ useleft = USE_LEFT(TOPm1s);
+#ifdef PERL_PRESERVE_IVUV
+ /* We must see if we can perform the addition with integers if possible,
+ as the integer code detects overflow while the NV code doesn't.
+ If either argument hasn't had a numeric conversion yet attempt to get
+ the IV. It's important to do this now, rather than just assuming that
+ it's not IOK as a PV of "9223372036854775806" may not take well to NV
+ addition, and an SV which is NOK, NV=6.0 ought to be coerced to
+ integer in case the second argument is IV=9223372036854775806
+ We can (now) rely on sv_2iv to do the right thing, only setting the
+ public IOK flag if the value in the NV (or PV) slot is truly integer.
+
+ A side effect is that this also aggressively prefers integer maths over
+ fp maths for integer values. */
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ /* Unless the left argument is integer in range we are going to have to
+ use NV maths. Hence only attempt to coerce the right argument if
+ we know the left is integer. */
+ if (!useleft) {
+ /* left operand is undef, treat as zero. + 0 is identity. */
+ if (SvUOK(TOPs)) {
+ dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
+ if (value <= (UV)IV_MIN) {
+ /* 2s complement assumption. */
+ SETi(-(IV)value);
+ RETURN;
+ } /* else drop through into NVs below */
+ } else {
+ dPOPiv;
+ SETu((UV)-value);
+ RETURN;
+ }
+ } else {
+ /* Left operand is defined, so is it IV? */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV - IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+ IV result = aiv - biv;
+
+ if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
+ SP--;
+ SETi( result );
+ RETURN;
+ }
+ /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
+ /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
+ /* -ve - +ve can only overflow too negative. */
+ /* leaving +ve - -ve, which will go UV */
+ if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
+ /* 2s complement assumption for IV_MIN */
+ UV result = (UV)aiv + (UV)-biv;
+ /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
+ overflow UV (2s complement assumption */
+ assert (result >= (UV) aiv);
+ SP--;
+ SETu( result );
+ RETURN;
+ }
+ /* Overflow, drop through to NVs */
+ } else if (auvok && buvok) { /* ## UV - UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+ IV result;
+
+ if (auv >= buv) {
+ SP--;
+ SETu( auv - buv );
+ RETURN;
+ }
+ /* Blatant 2s complement assumption. */
+ result = (IV)(auv - buv);
+ if (result < 0) {
+ SP--;
+ SETi( result );
+ RETURN;
+ }
+ /* Overflow on IV - IV, drop through to NVs */
+ } else if (auvok) { /* ## Mixed UV - IV ## */
+ UV auv = SvUVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ if (biv < 0) {
+ /* 2s complement assumptions for IV_MIN */
+ UV result = auv + ((UV)-biv);
+ /* UV + UV can only get bigger... */
+ if (result >= auv) {
+ SP--;
+ SETu( result );
+ RETURN;
+ }
+ /* and if it gets too big for UV then it's NV time. */
+ } else if (auv > (UV)IV_MAX) {
+ /* I think I'm making an implicit 2s complement
+ assumption that IV_MIN == -IV_MAX - 1 */
+ /* biv is >= 0 */
+ UV result = auv - (UV)biv;
+ assert (result <= auv);
+ SP--;
+ SETu( result );
+ RETURN;
+ } else {
+ /* biv is >= 0 */
+ IV result = (IV)auv - biv;
+ assert (result <= (IV)auv);
+ SP--;
+ SETi( result );
+ RETURN;
+ }
+ } else { /* ## Mixed IV - UV ## */
+ IV aiv = SvIVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+ IV result = aiv - (IV)buv; /* 2s complement assumption. */
+
+ /* result must not get larger. */
+ if (result <= aiv) {
+ SP--;
+ SETi( result );
+ RETURN;
+ } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
+ }
+ }
+ }
+ }
+#endif
{
- dPOPTOPnnrl_ul;
- SETn( left - right );
- RETURN;
+ dPOPnv;
+ if (!useleft) {
+ /* left operand is undef, treat as zero - value */
+ SETn(-value);
+ RETURN;
+ }
+ SETn( TOPn - value );
+ RETURN;
}
}
@@ -1161,6 +1404,74 @@ PP(pp_right_shift)
PP(pp_lt)
{
djSP; tryAMAGICbinSET(lt,0);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV < IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ SP--;
+ SETs(boolSV(aiv < biv));
+ RETURN;
+ }
+ if (auvok && buvok) { /* ## UV < UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+
+ SP--;
+ SETs(boolSV(auv < buv));
+ RETURN;
+ }
+ if (auvok) { /* ## UV < IV ## */
+ UV auv;
+ IV biv;
+
+ biv = SvIVX(TOPs);
+ SP--;
+ if (biv < 0) {
+ /* As (a) is a UV, it's >=0, so it cannot be < */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ auv = SvUVX(TOPs);
+ if (auv >= (UV) IV_MAX) {
+ /* As (b) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ SETs(boolSV(auv < (UV)biv));
+ RETURN;
+ }
+ { /* ## IV < UV ## */
+ IV aiv;
+ UV buv;
+
+ aiv = SvIVX(TOPm1s);
+ if (aiv < 0) {
+ /* As (b) is a UV, it's >=0, so it must be < */
+ SP--;
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ buv = SvUVX(TOPs);
+ SP--;
+ if (buv > (UV) IV_MAX) {
+ /* As (a) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ SETs(boolSV((UV)aiv < buv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn < value));
@@ -1171,6 +1482,74 @@ PP(pp_lt)
PP(pp_gt)
{
djSP; tryAMAGICbinSET(gt,0);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV > IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ SP--;
+ SETs(boolSV(aiv > biv));
+ RETURN;
+ }
+ if (auvok && buvok) { /* ## UV > UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+
+ SP--;
+ SETs(boolSV(auv > buv));
+ RETURN;
+ }
+ if (auvok) { /* ## UV > IV ## */
+ UV auv;
+ IV biv;
+
+ biv = SvIVX(TOPs);
+ SP--;
+ if (biv < 0) {
+ /* As (a) is a UV, it's >=0, so it must be > */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ auv = SvUVX(TOPs);
+ if (auv > (UV) IV_MAX) {
+ /* As (b) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ SETs(boolSV(auv > (UV)biv));
+ RETURN;
+ }
+ { /* ## IV > UV ## */
+ IV aiv;
+ UV buv;
+
+ aiv = SvIVX(TOPm1s);
+ if (aiv < 0) {
+ /* As (b) is a UV, it's >=0, so it cannot be > */
+ SP--;
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ buv = SvUVX(TOPs);
+ SP--;
+ if (buv >= (UV) IV_MAX) {
+ /* As (a) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ SETs(boolSV((UV)aiv > buv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn > value));
@@ -1181,6 +1560,74 @@ PP(pp_gt)
PP(pp_le)
{
djSP; tryAMAGICbinSET(le,0);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV <= IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ SP--;
+ SETs(boolSV(aiv <= biv));
+ RETURN;
+ }
+ if (auvok && buvok) { /* ## UV <= UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+
+ SP--;
+ SETs(boolSV(auv <= buv));
+ RETURN;
+ }
+ if (auvok) { /* ## UV <= IV ## */
+ UV auv;
+ IV biv;
+
+ biv = SvIVX(TOPs);
+ SP--;
+ if (biv < 0) {
+ /* As (a) is a UV, it's >=0, so a cannot be <= */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ auv = SvUVX(TOPs);
+ if (auv > (UV) IV_MAX) {
+ /* As (b) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ SETs(boolSV(auv <= (UV)biv));
+ RETURN;
+ }
+ { /* ## IV <= UV ## */
+ IV aiv;
+ UV buv;
+
+ aiv = SvIVX(TOPm1s);
+ if (aiv < 0) {
+ /* As (b) is a UV, it's >=0, so a must be <= */
+ SP--;
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ buv = SvUVX(TOPs);
+ SP--;
+ if (buv >= (UV) IV_MAX) {
+ /* As (a) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ SETs(boolSV((UV)aiv <= buv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn <= value));
@@ -1191,6 +1638,74 @@ PP(pp_le)
PP(pp_ge)
{
djSP; tryAMAGICbinSET(ge,0);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV >= IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ SP--;
+ SETs(boolSV(aiv >= biv));
+ RETURN;
+ }
+ if (auvok && buvok) { /* ## UV >= UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+
+ SP--;
+ SETs(boolSV(auv >= buv));
+ RETURN;
+ }
+ if (auvok) { /* ## UV >= IV ## */
+ UV auv;
+ IV biv;
+
+ biv = SvIVX(TOPs);
+ SP--;
+ if (biv < 0) {
+ /* As (a) is a UV, it's >=0, so it must be >= */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ auv = SvUVX(TOPs);
+ if (auv >= (UV) IV_MAX) {
+ /* As (b) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ SETs(boolSV(auv >= (UV)biv));
+ RETURN;
+ }
+ { /* ## IV >= UV ## */
+ IV aiv;
+ UV buv;
+
+ aiv = SvIVX(TOPm1s);
+ if (aiv < 0) {
+ /* As (b) is a UV, it's >=0, so a cannot be >= */
+ SP--;
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ buv = SvUVX(TOPs);
+ SP--;
+ if (buv > (UV) IV_MAX) {
+ /* As (a) is an IV, it cannot be > IV_MAX */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ SETs(boolSV((UV)aiv >= buv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn >= value));
@@ -1201,6 +1716,66 @@ PP(pp_ge)
PP(pp_ne)
{
djSP; tryAMAGICbinSET(ne,0);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV <=> IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ SP--;
+ SETs(boolSV(aiv != biv));
+ RETURN;
+ }
+ if (auvok && buvok) { /* ## UV != UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+
+ SP--;
+ SETs(boolSV(auv != buv));
+ RETURN;
+ }
+ { /* ## Mixed IV,UV ## */
+ IV iv;
+ UV uv;
+
+ /* != is commutative so swap if needed (save code) */
+ if (auvok) {
+ /* swap. top of stack (b) is the iv */
+ iv = SvIVX(TOPs);
+ SP--;
+ if (iv < 0) {
+ /* As (a) is a UV, it's >0, so it cannot be == */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ uv = SvUVX(TOPs);
+ } else {
+ iv = SvIVX(TOPm1s);
+ SP--;
+ if (iv < 0) {
+ /* As (b) is a UV, it's >0, so it cannot be == */
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
+ }
+ /* we know iv is >= 0 */
+ if (uv > (UV) IV_MAX) {
+ SETs(&PL_sv_yes);
+ RETURN;
+ }
+ SETs(boolSV((UV)iv != uv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn != value));
@@ -1211,6 +1786,84 @@ PP(pp_ne)
PP(pp_ncmp)
{
djSP; dTARGET; tryAMAGICbin(ncmp,0);
+#ifdef PERL_PRESERVE_IVUV
+ /* Fortunately it seems NaN isn't IOK */
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool leftuvok = SvUOK(TOPm1s);
+ bool rightuvok = SvUOK(TOPs);
+ I32 value;
+ if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
+ IV leftiv = SvIVX(TOPm1s);
+ IV rightiv = SvIVX(TOPs);
+
+ if (leftiv > rightiv)
+ value = 1;
+ else if (leftiv < rightiv)
+ value = -1;
+ else
+ value = 0;
+ } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
+ UV leftuv = SvUVX(TOPm1s);
+ UV rightuv = SvUVX(TOPs);
+
+ if (leftuv > rightuv)
+ value = 1;
+ else if (leftuv < rightuv)
+ value = -1;
+ else
+ value = 0;
+ } else if (leftuvok) { /* ## UV <=> IV ## */
+ UV leftuv;
+ IV rightiv;
+
+ rightiv = SvIVX(TOPs);
+ if (rightiv < 0) {
+ /* As (a) is a UV, it's >=0, so it cannot be < */
+ value = 1;
+ } else {
+ leftuv = SvUVX(TOPm1s);
+ if (leftuv > (UV) IV_MAX) {
+ /* As (b) is an IV, it cannot be > IV_MAX */
+ value = 1;
+ } else if (leftuv > (UV)rightiv) {
+ value = 1;
+ } else if (leftuv < (UV)rightiv) {
+ value = -1;
+ } else {
+ value = 0;
+ }
+ }
+ } else { /* ## IV <=> UV ## */
+ IV leftiv;
+ UV rightuv;
+
+ leftiv = SvIVX(TOPm1s);
+ if (leftiv < 0) {
+ /* As (b) is a UV, it's >=0, so it must be < */
+ value = -1;
+ } else {
+ rightuv = SvUVX(TOPs);
+ if (rightuv > (UV) IV_MAX) {
+ /* As (a) is an IV, it cannot be > IV_MAX */
+ value = -1;
+ } else if (leftiv > (UV)rightuv) {
+ value = 1;
+ } else if (leftiv < (UV)rightuv) {
+ value = -1;
+ } else {
+ value = 0;
+ }
+ }
+ }
+ SP--;
+ SETi(value);
+ RETURN;
+ }
+ }
+#endif
{
dPOPTOPnnrl;
I32 value;
@@ -1397,11 +2050,15 @@ PP(pp_negate)
djSP; dTARGET; tryAMAGICun(neg);
{
dTOPss;
+ int flags = SvFLAGS(sv);
if (SvGMAGICAL(sv))
mg_get(sv);
- if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
+ if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+ /* It's publicly an integer, or privately an integer-not-float */
+ oops_its_an_int:
if (SvIsUV(sv)) {
if (SvIVX(sv) == IV_MIN) {
+ /* 2s complement assumption. */
SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
RETURN;
}
@@ -1414,6 +2071,12 @@ PP(pp_negate)
SETi(-SvIVX(sv));
RETURN;
}
+#ifdef PERL_PRESERVE_IVUV
+ else {
+ SETu((UV)IV_MIN);
+ RETURN;
+ }
+#endif
}
if (SvNIOKp(sv))
SETn(-SvNV(sv));
@@ -1432,8 +2095,12 @@ PP(pp_negate)
sv_setpvn(TARG, "-", 1);
sv_catsv(TARG, sv);
}
- else
- sv_setnv(TARG, -SvNV(sv));
+ else {
+ SvIV_please(sv);
+ if (SvIOK(sv))
+ goto oops_its_an_int;
+ sv_setnv(TARG, -SvNV(sv));
+ }
SETTARG;
}
else
@@ -1896,38 +2563,49 @@ PP(pp_int)
{
djSP; dTARGET;
{
- NV value = TOPn;
- IV iv;
-
- if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
- iv = SvIVX(TOPs);
- SETi(iv);
- }
- else {
+ NV value;
+ IV iv = TOPi; /* attempt to convert to IV if possible. */
+ /* XXX it's arguable that compiler casting to IV might be subtly
+ different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
+ else preferring IV has introduced a subtle behaviour change bug. OTOH
+ relying on floating point to be accurate is a bug. */
+
+ if (SvIOK(TOPs)) {
+ if (SvIsUV(TOPs)) {
+ UV uv = TOPu;
+ SETu(uv);
+ } else
+ SETi(iv);
+ } else {
+ value = TOPn;
if (value >= 0.0) {
+ if (value < (NV)UV_MAX + 0.5) {
+ SETu(U_V(value));
+ } else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
- (void)Perl_modf(value, &value);
+ (void)Perl_modf(value, &value);
#else
- double tmp = (double)value;
- (void)Perl_modf(tmp, &tmp);
- value = (NV)tmp;
+ double tmp = (double)value;
+ (void)Perl_modf(tmp, &tmp);
+ value = (NV)tmp;
#endif
+ }
}
- else {
+ else {
+ if (value > (NV)IV_MIN - 0.5) {
+ SETi(I_V(value));
+ } else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
- (void)Perl_modf(-value, &value);
- value = -value;
+ (void)Perl_modf(-value, &value);
+ value = -value;
#else
- double tmp = (double)value;
- (void)Perl_modf(-tmp, &tmp);
- value = -(NV)tmp;
+ double tmp = (double)value;
+ (void)Perl_modf(-tmp, &tmp);
+ value = -(NV)tmp;
#endif
- }
- iv = I_V(value);
- if (iv == value)
- SETi(iv);
- else
- SETn(value);
+ SETn(value);
+ }
+ }
}
}
RETURN;
@@ -1937,18 +2615,30 @@ PP(pp_abs)
{
djSP; dTARGET; tryAMAGICun(abs);
{
- NV value = TOPn;
- IV iv;
-
- if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
- (iv = SvIVX(TOPs)) != IV_MIN) {
- if (iv < 0)
- iv = -iv;
- SETi(iv);
- }
- else {
+ /* This will cache the NV value if string isn't actually integer */
+ IV iv = TOPi;
+
+ if (SvIOK(TOPs)) {
+ /* IVX is precise */
+ if (SvIsUV(TOPs)) {
+ SETu(TOPu); /* force it to be numeric only */
+ } else {
+ if (iv >= 0) {
+ SETi(iv);
+ } else {
+ if (iv != IV_MIN) {
+ SETi(-iv);
+ } else {
+ /* 2s complement assumption. Also, not really needed as
+ IV_MIN and -IV_MIN should both be %100...00 and NV-able */
+ SETu(IV_MIN);
+ }
+ }
+ }
+ } else{
+ NV value = TOPn;
if (value < 0.0)
- value = -value;
+ value = -value;
SETn(value);
}
}
diff --git a/pp_hot.c b/pp_hot.c
index 25a0032533..6a5b96fe1a 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -279,6 +279,69 @@ PP(pp_readline)
PP(pp_eq)
{
djSP; tryAMAGICbinSET(eq,0);
+#ifdef PERL_PRESERVE_IVUV
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ /* Unless the left argument is integer in range we are going to have to
+ use NV maths. Hence only attempt to coerce the right argument if
+ we know the left is integer. */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV == IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+
+ SP--;
+ SETs(boolSV(aiv == biv));
+ RETURN;
+ }
+ if (auvok && buvok) { /* ## UV == UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+
+ SP--;
+ SETs(boolSV(auv == buv));
+ RETURN;
+ }
+ { /* ## Mixed IV,UV ## */
+ IV iv;
+ UV uv;
+
+ /* == is commutative so swap if needed (save code) */
+ if (auvok) {
+ /* swap. top of stack (b) is the iv */
+ iv = SvIVX(TOPs);
+ SP--;
+ if (iv < 0) {
+ /* As (a) is a UV, it's >0, so it cannot be == */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ uv = SvUVX(TOPs);
+ } else {
+ iv = SvIVX(TOPm1s);
+ SP--;
+ if (iv < 0) {
+ /* As (b) is a UV, it's >0, so it cannot be == */
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
+ }
+ /* we know iv is >= 0 */
+ if (uv > (UV) IV_MAX) {
+ SETs(&PL_sv_no);
+ RETURN;
+ }
+ SETs(boolSV((UV)iv == uv));
+ RETURN;
+ }
+ }
+ }
+#endif
{
dPOPnv;
SETs(boolSV(TOPn == value));
@@ -297,7 +360,7 @@ PP(pp_preinc)
++SvIVX(TOPs);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
- else
+ else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
sv_inc(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
@@ -316,11 +379,125 @@ PP(pp_or)
PP(pp_add)
{
- djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
+ useleft = USE_LEFT(TOPm1s);
+#ifdef PERL_PRESERVE_IVUV
+ /* We must see if we can perform the addition with integers if possible,
+ as the integer code detects overflow while the NV code doesn't.
+ If either argument hasn't had a numeric conversion yet attempt to get
+ the IV. It's important to do this now, rather than just assuming that
+ it's not IOK as a PV of "9223372036854775806" may not take well to NV
+ addition, and an SV which is NOK, NV=6.0 ought to be coerced to
+ integer in case the second argument is IV=9223372036854775806
+ We can (now) rely on sv_2iv to do the right thing, only setting the
+ public IOK flag if the value in the NV (or PV) slot is truly integer.
+
+ A side effect is that this also aggressively prefers integer maths over
+ fp maths for integer values. */
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ /* Unless the left argument is integer in range we are going to have to
+ use NV maths. Hence only attempt to coerce the right argument if
+ we know the left is integer. */
+ if (!useleft) {
+ /* left operand is undef, treat as zero. + 0 is identity. */
+ if (SvUOK(TOPs)) {
+ dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
+ SETu(value);
+ RETURN;
+ } else {
+ dPOPiv;
+ SETi(value);
+ RETURN;
+ }
+ }
+ /* Left operand is defined, so is it IV? */
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool auvok = SvUOK(TOPm1s);
+ bool buvok = SvUOK(TOPs);
+
+ if (!auvok && !buvok) { /* ## IV + IV ## */
+ IV aiv = SvIVX(TOPm1s);
+ IV biv = SvIVX(TOPs);
+ IV result = aiv + biv;
+
+ if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
+ SP--;
+ SETi( result );
+ RETURN;
+ }
+ if (biv >=0 && aiv >= 0) {
+ UV result = (UV)aiv + (UV)biv;
+ /* UV + UV can only get bigger... */
+ if (result >= (UV) aiv) {
+ SP--;
+ SETu( result );
+ RETURN;
+ }
+ }
+ /* Overflow, drop through to NVs (beyond next if () else ) */
+ } else if (auvok && buvok) { /* ## UV + UV ## */
+ UV auv = SvUVX(TOPm1s);
+ UV buv = SvUVX(TOPs);
+ UV result = auv + buv;
+ if (result >= auv) {
+ SP--;
+ SETu( result );
+ RETURN;
+ }
+ /* Overflow, drop through to NVs (beyond next if () else ) */
+ } else { /* ## Mixed IV,UV ## */
+ IV aiv;
+ UV buv;
+
+ /* addition is commutative so swap if needed (save code) */
+ if (buvok) {
+ aiv = SvIVX(TOPm1s);
+ buv = SvUVX(TOPs);
+ } else {
+ aiv = SvIVX(TOPs);
+ buv = SvUVX(TOPm1s);
+ }
+
+ if (aiv >= 0) {
+ UV result = (UV)aiv + buv;
+ if (result >= buv) {
+ SP--;
+ SETu( result );
+ RETURN;
+ }
+ } else if (buv > (UV) IV_MAX) {
+ /* assuming 2s complement means that IV_MIN == -IV_MIN,
+ and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
+ as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
+ as the value we can be subtracting from it only lies in
+ the range (-IV_MIN to -1) it can't overflow a UV */
+ SP--;
+ SETu( buv - (UV)-aiv );
+ RETURN;
+ } else {
+ IV result = (IV) buv + aiv;
+ /* aiv < 0 so it must get smaller. */
+ if (result < (IV) buv) {
+ SP--;
+ SETi( result );
+ RETURN;
+ }
+ }
+ } /* end of IV+IV / UV+UV / mixed */
+ }
+ }
+#endif
{
- dPOPTOPnnrl_ul;
- SETn( left + right );
- RETURN;
+ dPOPnv;
+ if (!useleft) {
+ /* left operand is undef, treat as zero. + 0.0 is identity. */
+ SETn(value);
+ RETURN;
+ }
+ SETn( value + TOPn );
+ RETURN;
}
}
diff --git a/proto.h b/proto.h
index 288a311986..c9e42db529 100644
--- a/proto.h
+++ b/proto.h
@@ -1207,6 +1207,10 @@ STATIC void S_sv_del_backref(pTHX_ SV *sv);
# if defined(DEBUGGING)
STATIC void S_del_sv(pTHX_ SV *p);
# endif
+# if !defined(NV_PRESERVES_UV)
+STATIC int S_sv_2inuv_non_preserve(pTHX_ SV *sv, I32 numtype);
+STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *sv, I32 numtype);
+# endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
diff --git a/sv.c b/sv.c
index 7c9c4dbe68..a018ceadd2 100644
--- a/sv.c
+++ b/sv.c
@@ -1320,6 +1320,10 @@ See C<sv_setuv_mg>.
void
Perl_sv_setuv(pTHX_ register SV *sv, UV u)
{
+ if (u <= (UV)IV_MAX) {
+ sv_setiv(sv, (IV)u);
+ return;
+ }
sv_setiv(sv, 0);
SvIsUV_on(sv);
SvUVX(sv) = u;
@@ -1336,7 +1340,13 @@ Like C<sv_setuv>, but also handles 'set' magic.
void
Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
- sv_setuv(sv,u);
+ if (u <= (UV)IV_MAX) {
+ sv_setiv(sv, (IV)u);
+ } else {
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ sv_setuv(sv,u);
+ }
SvSETMAGIC(sv);
}
@@ -1449,16 +1459,220 @@ S_not_a_number(pTHX_ SV *sv)
"Argument \"%s\" isn't numeric", tmpbuf);
}
-/* the number can be converted to integer with atol() or atoll() */
-#define IS_NUMBER_TO_INT_BY_ATOL 0x01
-#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
-#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
-#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
-#define IS_NUMBER_INFINITY 0x10 /* this is big */
+/* the number can be converted to integer with atol() or atoll() although */
+#define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
+#define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
+#define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
+#define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
+#define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
+#define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
+#define IS_NUMBER_NEG 0x40 /* seen a leading - */
+#define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
+/* As 64 bit platforms often have an NV that doesn't preserve all bits of
+ an IV (an assumption perl has been based on to date) it becomes necessary
+ to remove the assumption that the NV always carries enough precision to
+ recreate the IV whenever needed, and that the NV is the canonical form.
+ Instead, IV/UV and NV need to be given equal rights. So as to not lose
+ precision as an side effect of conversion (which would lead to insanity
+ and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
+ 1) to distinguish between IV/UV/NV slots that have cached a valid
+ conversion where precision was lost and IV/UV/NV slots that have a
+ valid conversion which has lost no precision
+ 2) to ensure that if a numeric conversion to one form is request that
+ would lose precision, the precise conversion (or differently
+ imprecise conversion) is also performed and cached, to prevent
+ requests for different numeric formats on the same SV causing
+ lossy conversion chains. (lossless conversion chains are perfectly
+ acceptable (still))
+
+
+ flags are used:
+ SvIOKp is true if the IV slot contains a valid value
+ SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
+ SvNOKp is true if the NV slot contains a valid value
+ SvNOK is true only if the NV value is accurate
+
+ so
+ while converting from PV to NV check to see if converting that NV to an
+ IV(or UV) would lose accuracy over a direct conversion from PV to
+ IV(or UV). If it would, cache both conversions, return NV, but mark
+ SV as IOK NOKp (ie not NOK).
+
+ while converting from PV to IV check to see if converting that IV to an
+ NV would lose accuracy over a direct conversion from PV to NV. If it
+ would, cache both conversions, flag similarly.
+
+ Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
+ correctly because if IV & NV were set NV *always* overruled.
+ Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
+ changes - now IV and NV together means that the two are interchangeable
+ SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
+
+ The benefit of this is operations such as pp_add know that if SvIOK is
+ true for both left and right operands, then integer addition can be
+ used instead of floating point. (for cases where the result won't
+ overflow) Before, floating point was always used, which could lead to
+ loss of precision compared with integer addition.
+
+ * making IV and NV equal status should make maths accurate on 64 bit
+ platforms
+ * may speed up maths somewhat if pp_add and friends start to use
+ integers when possible instead of fp. (hopefully the overhead in
+ looking for SvIOK and checking for overflow will not outweigh the
+ fp to integer speedup)
+ * will slow down integer operations (callers of SvIV) on "inaccurate"
+ values, as the change from SvIOK to SvIOKp will cause a call into
+ sv_2iv each time rather than a macro access direct to the IV slot
+ * should speed up number->string conversion on integers as IV is
+ favoured when IV and NV equally accurate
+
+ ####################################################################
+ You had better be using SvIOK_notUV if you want an IV for arithmetic
+ SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
+ SvUOK is true iff UV.
+ ####################################################################
+
+ Your mileage will vary depending your CPUs relative fp to integer
+ performance ratio.
+*/
+
+#ifndef NV_PRESERVES_UV
+#define IS_NUMBER_UNDERFLOW_IV 1
+#define IS_NUMBER_UNDERFLOW_UV 2
+#define IS_NUMBER_IV_AND_UV 2
+#define IS_NUMBER_OVERFLOW_IV 4
+#define IS_NUMBER_OVERFLOW_UV 5
+/* Hopefully your optimiser will consider inlining these two functions. */
+STATIC int
+S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
+ NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
+ UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
+ if (nv_as_uv <= (UV)IV_MAX) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOKp_on(sv);
+ /* Within suitable range to fit in an IV, atol won't overflow */
+ /* XXX quite sure? Is that your final answer? not really, I'm
+ trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
+ SvIVX(sv) = (IV)Atol(SvPVX(sv));
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* I believe that even if the original PV had decimals, they
+ are lost beyond the limit of the FP precision.
+ However, neither is canonical, so both only get p flags.
+ NWC, 2000/11/25 */
+ /* Both already have p flags, so do nothing */
+ } else if (SvIVX(sv) == I_V(nv)) {
+ SvNOK_on(sv);
+ SvIOK_on(sv);
+ } else {
+ SvIOK_on(sv);
+ /* It had no "." so it must be integer. assert (get in here from
+ sv_2iv and sv_2uv only for ndef HAS_STRTOL and
+ IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
+ conversion routines need audit. */
+ }
+ return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+ }
+ /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
+ (void)SvIOKp_on(sv);
+ (void)SvNOKp_on(sv);
+#ifdef HAS_STRTOUL
+ {
+ int save_errno = errno;
+ errno = 0;
+ SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
+ if (errno == 0) {
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* UV and NV both imprecise. */
+ SvIsUV_on(sv);
+ } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
+ SvNOK_on(sv);
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ } else {
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ }
+ errno = save_errno;
+ return IS_NUMBER_OVERFLOW_IV;
+ }
+ errno = save_errno;
+ SvNOK_on(sv);
+ /* Must have just overflowed UV, but not enough that an NV could spot
+ this.. */
+ return IS_NUMBER_OVERFLOW_UV;
+ }
+#else
+ /* We've just lost integer precision, nothing we could do. */
+ SvUVX(sv) = nv_as_uv;
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
+ /* UV and NV slots equally valid only if we have casting symmetry. */
+ if (numtype & IS_NUMBER_NOT_INT) {
+ SvIsUV_on(sv);
+ } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
+ /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
+ UV_MAX ought to be 0xFF...FFF which won't preserve (We only
+ get to this point if NVs don't preserve UVs) */
+ SvNOK_on(sv);
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ } else {
+ /* As above, I believe UV at least as good as NV */
+ SvIsUV_on(sv);
+ }
+#endif /* HAS_STRTOUL */
+ return IS_NUMBER_OVERFLOW_IV;
+}
+
+/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
+STATIC int
+S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
+{
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
+ if (SvNVX(sv) < (NV)IV_MIN) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ SvIVX(sv) = IV_MIN;
+ return IS_NUMBER_UNDERFLOW_IV;
+ }
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ SvIsUV_on(sv);
+ SvUVX(sv) = UV_MAX;
+ return IS_NUMBER_OVERFLOW_UV;
+ }
+ if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ /* Can't use strtol etc to convert this string */
+ if (SvNVX(sv) <= (UV)IV_MAX) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv); /* Integer is precise. NOK, IOK */
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+ }
+ SvIsUV_on(sv);
+ SvUVX(sv) = U_V(SvNVX(sv));
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv); /* Integer is precise. NOK, UOK */
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ return IS_NUMBER_OVERFLOW_IV;
+ }
+ return S_sv_2inuv_non_preserve (sv, numtype);
+}
+#endif /* NV_PRESERVES_UV*/
+
+
IV
Perl_sv_2iv(pTHX_ register SV *sv)
{
@@ -1507,19 +1721,71 @@ Perl_sv_2iv(pTHX_ register SV *sv)
}
}
if (SvNOKp(sv)) {
- /* We can cache the IV/UV value even if it not good enough
- * to reconstruct NV, since the conversion to PV will prefer
- * NV over IV/UV.
- */
+ /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+ * without also getting a cached IV/UV from it at the same time
+ * (ie PV->NV conversion should detect loss of accuracy and cache
+ * IV or UV at same time to avoid this. NWC */
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
- (void)SvIOK_on(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5)
+ (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
+ /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
+ certainly cast into the IV range at IV_MAX, whereas the correct
+ answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
+ cases go to UV */
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIVX(sv) = I_V(SvNVX(sv));
+ if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+ && (((UV)1 << NV_PRESERVES_UV_BITS) >
+ (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ ) {
+ SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+
+ } else {
+ /* IV not precise. No need to convert from PV, as NV
+ conversion would already have cached IV if it detected
+ that PV->IV would be better than PV->NV->IV
+ flags already correct - don't set public IOK. */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+ }
+ /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+ but the cast (NV)IV_MIN rounds to a the value less (more
+ negative) than IV_MIN which happens to be equal to SvNVX ??
+ Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+ NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+ (NV)UVX == NVX are both true, but the values differ. :-(
+ Hopefully for 2s complement IV_MIN is something like
+ 0x8000000000000000 which will be exact. NWC */
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
+ if (
+ (SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef NV_PRESERVES_UV
+ /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+ /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+ && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ )
+ SvIOK_on(sv);
SvIsUV_on(sv);
ret_iv_max:
DEBUG_c(PerlIO_printf(Perl_debug_log,
@@ -1539,46 +1805,116 @@ Perl_sv_2iv(pTHX_ register SV *sv)
This means that if we cache such an IV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
- cache the NV if not needed.
+ cache the NV if we are sure it's not needed.
*/
- if (numtype & IS_NUMBER_NOT_IV) {
- /* May be not an integer. Need to cache NV if we cache IV
- * - otherwise future conversion to NV will be wrong. */
- NV d;
- d = Atof(SvPVX(sv));
-
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvNVX(sv) = d;
- (void)SvNOK_on(sv);
+ if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
+ /* The NV may be reconstructed from IV - safe to cache IV,
+ which may be calculated by atol(). */
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
+ SvIVX(sv) = Atol(SvPVX(sv));
+ } else {
+#ifdef HAS_STRTOL
+ IV i;
+ int save_errno = errno;
+ /* Is it an integer that we could convert with strtol?
+ So try it, and if it doesn't set errno then it's pukka.
+ This should be faster than going atof and then thinking. */
+ if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_TO_INT_BY_STRTOL)
+ /* && is a sequence point. Without it not sure if I'm trying
+ to do too much between sequence points and hence going
+ undefined */
+ && ((errno = 0), 1) /* , 1 so always true */
+ && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
+ && (errno == 0)) {
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = i;
+ errno = save_errno;
+ } else {
+ NV d;
+ /* Hopefully trace flow will optimise this away where possible
+ */
+ errno = save_errno;
+#else
+ NV d;
+#endif
+ /* It wasn't an integer, or it overflowed, or we don't have
+ strtol. Do things the slow way - check if it's a UV etc. */
+ d = Atof(SvPVX(sv));
+
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNVX(sv) = d;
+
+ if (! numtype && ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+
#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
+ PTR2UV(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
- PTR2UV(sv), SvNVX(sv)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
+ PTR2UV(sv), SvNVX(sv)));
#endif
- if (SvNVX(sv) < (NV)IV_MAX + 0.5)
- SvIVX(sv) = I_V(SvNVX(sv));
- else {
- SvUVX(sv) = U_V(SvNVX(sv));
- SvIsUV_on(sv);
- goto ret_iv_max;
+
+
+#ifdef NV_PRESERVES_UV
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ /* UV will not work better than IV */
+ } else {
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ SvIsUV_on(sv);
+ /* Integer is inaccurate. NOK, IOKp, is UV */
+ SvUVX(sv) = UV_MAX;
+ SvIsUV_on(sv);
+ } else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ /* 0xFFFFFFFFFFFFFFFF not an issue in here */
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp, is UV */
+ SvIsUV_on(sv);
+ }
+ }
+ goto ret_iv_max;
+ }
+#else /* NV_PRESERVES_UV */
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ /* Small enough to preserve all bits. */
+ (void)SvIOKp_on(sv);
+ SvNOK_on(sv);
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv))
+ SvIOK_on(sv);
+ /* Assumption: first non-preserved integer is < IV_MAX,
+ this NV is in the preserved range, therefore: */
+ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+ < (UV)IV_MAX)) {
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ }
+ } else if (sv_2iuv_non_preserve (sv, numtype)
+ >= IS_NUMBER_OVERFLOW_IV)
+ goto ret_iv_max;
+#endif /* NV_PRESERVES_UV */
}
}
- else { /* The NV may be reconstructed from IV - safe to cache IV,
- which may be calculated by atol(). */
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIVX(sv) = Atol(SvPVX(sv));
- if (! numtype && ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- }
- else {
+ } else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit();
if (SvTYPE(sv) < SVt_IV)
@@ -1638,26 +1974,74 @@ Perl_sv_2uv(pTHX_ register SV *sv)
}
}
if (SvNOKp(sv)) {
- /* We can cache the IV/UV value even if it not good enough
- * to reconstruct NV, since the conversion to PV will prefer
- * NV over IV/UV.
- */
+ /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+ * without also getting a cached IV/UV from it at the same time
+ * (ie PV->NV conversion should detect loss of accuracy and cache
+ * IV or UV at same time to avoid this. */
+ /* IV-over-UV optimisation - choose to cache IV if possible */
+
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
- (void)SvIOK_on(sv);
- if (SvNVX(sv) >= -0.5) {
- SvIsUV_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
- }
- else {
+
+ (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIVX(sv) = I_V(SvNVX(sv));
- ret_zero:
+ if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+ && (((UV)1 << NV_PRESERVES_UV_BITS) >
+ (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ ) {
+ SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+
+ } else {
+ /* IV not precise. No need to convert from PV, as NV
+ conversion would already have cached IV if it detected
+ that PV->IV would be better than PV->NV->IV
+ flags already correct - don't set public IOK. */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+ }
+ /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+ but the cast (NV)IV_MIN rounds to a the value less (more
+ negative) than IV_MIN which happens to be equal to SvNVX ??
+ Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+ NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+ (NV)UVX == NVX are both true, but the values differ. :-(
+ Hopefully for 2s complement IV_MIN is something like
+ 0x8000000000000000 which will be exact. NWC */
+ }
+ else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ if (
+ (SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef NV_PRESERVES_UV
+ /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+ /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+ && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ )
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
+ "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
PTR2UV(sv),
- SvIVX(sv),
- (IV)(UV)SvIVX(sv)));
- return (UV)SvIVX(sv);
+ SvUVX(sv),
+ SvUVX(sv)));
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
@@ -1671,66 +2055,126 @@ Perl_sv_2uv(pTHX_ register SV *sv)
NV as well. Moreover, we trade speed for space, and do not
cache the NV if not needed.
*/
- if (numtype & IS_NUMBER_NOT_IV) {
- /* May be not an integer. Need to cache NV if we cache IV
- * - otherwise future conversion to NV will be wrong. */
- NV d;
-
- d = Atof(SvPVX(sv));
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvNVX(sv) = d;
- (void)SvNOK_on(sv);
- (void)SvIOK_on(sv);
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2nv(%g)\n",
- PTR2UV(sv), SvNVX(sv)));
-#endif
- if (SvNVX(sv) < -0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
- goto ret_zero;
- } else {
- SvUVX(sv) = U_V(SvNVX(sv));
- SvIsUV_on(sv);
- }
- }
- else if (numtype & IS_NUMBER_NEG) {
+ if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
/* The NV may be reconstructed from IV - safe to cache IV,
- which may be calculated by atol(). */
- if (SvTYPE(sv) == SVt_PV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIVX(sv) = (IV)Atol(SvPVX(sv));
- }
- else if (numtype) { /* Non-negative */
- /* The NV may be reconstructed from UV - safe to cache UV,
- which may be calculated by strtoul()/atol. */
- if (SvTYPE(sv) == SVt_PV)
+ which may be calculated by atol(). */
+ if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
- (void)SvIsUV_on(sv);
+ SvIVX(sv) = Atol(SvPVX(sv));
+ } else {
#ifdef HAS_STRTOUL
- SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
-#else /* no atou(), but we know the number fits into IV... */
- /* The only problem may be if it is negative... */
- SvUVX(sv) = (UV)Atol(SvPVX(sv));
+ UV u;
+ int save_errno = errno;
+ /* Is it an integer that we could convert with strtoul?
+ So try it, and if it doesn't set errno then it's pukka.
+ This should be faster than going atof and then thinking. */
+ if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_TO_INT_BY_STRTOL)
+ && ((errno = 0), 1) /* always true */
+ && ((u = Strtoul(SvPVX(sv), Null(char**), 10)), 1) /* ditto */
+ && (errno == 0)
+ /* If known to be negative, check it didn't undeflow IV */
+ && ((numtype & IS_NUMBER_NEG) ? ((IV)u <= 0) : 1)) {
+ errno = save_errno;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+
+ /* If it's negative must use IV.
+ IV-over-UV optimisation */
+ if (numtype & IS_NUMBER_NEG || u <= (UV) IV_MAX) {
+ /* strtoul is defined to return negated value if the
+ number starts with a minus sign. Assuming 2s
+ complement, this value will be in range for a negative
+ IV if casting the bit pattern to IV doesn't produce
+ a positive value. Allow -0 by checking it's <= 0
+ hence (numtype & IS_NUMBER_NEG) test above
+ */
+ SvIVX(sv) = (IV)u;
+ } else {
+ /* it didn't overflow, and it was positive. */
+ SvUVX(sv) = u;
+ SvIsUV_on(sv);
+ }
+ } else {
+ NV d;
+ /* Hopefully trace flow will optimise this away where possible
+ */
+ errno = save_errno;
+#else
+ NV d;
#endif
- }
- else { /* Not a number. Cache 0. */
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- (void)SvIsUV_on(sv);
- SvUVX(sv) = 0; /* We assume that 0s have the
- same bitmap in IV and UV. */
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
+ /* It wasn't an integer, or it overflowed, or we don't have
+ strtol. Do things the slow way - check if it's a IV etc. */
+ d = Atof(SvPVX(sv));
+
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNVX(sv) = d;
+
+ if (! numtype && ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
+ PTR2UV(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
+ PTR2UV(sv), SvNVX(sv)));
+#endif
+
+#ifdef NV_PRESERVES_UV
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ /* UV will not work better than IV */
+ } else {
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ SvIsUV_on(sv);
+ /* Integer is inaccurate. NOK, IOKp, is UV */
+ SvUVX(sv) = UV_MAX;
+ SvIsUV_on(sv);
+ } else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
+ NV preservse UV so can do correct comparison. */
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp, is UV */
+ SvIsUV_on(sv);
+ }
+ }
+ }
+#else /* NV_PRESERVES_UV */
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ /* Small enough to preserve all bits. */
+ (void)SvIOKp_on(sv);
+ SvNOK_on(sv);
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv))
+ SvIOK_on(sv);
+ /* Assumption: first non-preserved integer is < IV_MAX,
+ this NV is in the preserved range, therefore: */
+ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+ < (UV)IV_MAX)) {
+ Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ }
+ } else
+ sv_2iuv_non_preserve (sv, numtype);
+#endif /* NV_PRESERVES_UV */
+ }
}
}
else {
@@ -1822,21 +2266,63 @@ Perl_sv_2nv(pTHX_ register SV *sv)
(!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
{
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
+#ifdef NV_PRESERVES_UV
+ SvNOK_on(sv);
+#else
+ /* Only set the public NV OK flag if this NV preserves the IV */
+ /* Check it's not 0xFFFFFFFFFFFFFFFF */
+ if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
+ : (SvIVX(sv) == I_V(SvNVX(sv))))
+ SvNOK_on(sv);
+ else
+ SvNOKp_on(sv);
+#endif
}
else if (SvPOKp(sv) && SvLEN(sv)) {
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SvNVX(sv) = Atof(SvPVX(sv));
+#ifdef NV_PRESERVES_UV
+ SvNOK_on(sv);
+#else
+ /* Only set the public NV OK flag if this NV preserves the value in
+ the PV at least as well as an IV/UV would.
+ Not sure how to do this 100% reliably. */
+ /* if that shift count is out of range then Configure's test is
+ wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
+ UV_BITS */
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
+ SvNOK_on(sv); /* Definitely small enough to preserve all bits */
+ else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
+ /* Definitely too large/small to fit in an integer, so no loss
+ of precision going to integer in the future via NV */
+ SvNOK_on(sv);
+ } else {
+ /* Is it something we can run through strtol etc (ie no
+ trailing exponent part)? */
+ int numtype = looks_like_number(sv);
+ /* XXX probably should cache this if called above */
+
+ if (!(numtype &
+ (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
+ /* Can't use strtol etc to convert this string, so don't try */
+ SvNOK_on(sv);
+ } else
+ sv_2inuv_non_preserve (sv, numtype);
+ }
+#endif /* NV_PRESERVES_UV */
}
else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit();
if (SvTYPE(sv) < SVt_NV)
/* Typically the caller expects that sv_any is not NULL now. */
+ /* XXX Ilya implies that this is a bug in callers that assume this
+ and ideally should be fixed. */
sv_upgrade(sv, SVt_NV);
return 0.0;
}
- SvNOK_on(sv);
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
@@ -1889,23 +2375,32 @@ S_asUV(pTHX_ SV *sv)
/*
* Returns a combination of (advisory only - can get false negatives)
- * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
- * IS_NUMBER_NEG
+ * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
+ * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
+ * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
* 0 if does not look like number.
*
- * In fact possible values are 0 and
- * IS_NUMBER_TO_INT_BY_ATOL 123
- * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
- * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
+ * (atol and strtol stop when they hit a decimal point. strtol will return
+ * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
+ * do this, and vendors have had 11 years to get it right.
+ * However, will try to make it still work with only atol
+ *
+ * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
+ * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
+ * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
+ * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
+ * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
+ * IS_NUMBER_NOT_INT saw "." or "e"
+ * IS_NUMBER_NEG
* IS_NUMBER_INFINITY
- * with a possible addition of IS_NUMBER_NEG.
*/
/*
=for apidoc looks_like_number
Test if an the content of an SV looks like a number (or is a
-number).
+number). C<Inf> and C<Infinity> are treated as numbers (so will not
+issue a non-numeric warning), even if your atof() doesn't grok them.
=cut
*/
@@ -1943,9 +2438,10 @@ Perl_looks_like_number(pTHX_ SV *sv)
nbegin = s;
/*
- * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
- * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
- * (int)atof().
+ * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
+ * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
+ * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
+ * will need (int)atof().
*/
/* next must be digit or the radix separator or beginning of infinity */
@@ -1954,10 +2450,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
s++;
} while (isDIGIT(*s));
- if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
- else
+ if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
+ else if (s - nbegin < BIT_DIGITS(sizeof (IV)*8-1))
numtype |= IS_NUMBER_TO_INT_BY_ATOL;
+ else
+ /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
+ digit less (IV_MAX= 9223372036854775807,
+ UV_MAX= 18446744073709551615) so be cautious */
+ numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
@@ -1965,7 +2466,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
#endif
) {
s++;
- numtype |= IS_NUMBER_NOT_IV;
+ numtype |= IS_NUMBER_NOT_INT;
while (isDIGIT(*s)) /* optional digits after the radix */
s++;
}
@@ -1976,7 +2477,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
#endif
) {
s++;
- numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
/* no digits before the radix means we need digits after it */
if (isDIGIT(*s)) {
do {
@@ -2002,12 +2503,13 @@ Perl_looks_like_number(pTHX_ SV *sv)
return 0;
if (sawinf)
- numtype = IS_NUMBER_INFINITY;
+ numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
+ | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
else {
/* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
- numtype &= ~IS_NUMBER_NEG;
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
s++;
if (*s == '+' || *s == '-')
s++;
@@ -2198,15 +2700,33 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
return "";
}
}
- if (SvPOK(sv)) {
- *lp = SvCUR(sv);
- return SvPVX(sv);
+ if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
+ /* I'm assuming that if both IV and NV are equally valid then
+ converting the IV is going to be more efficient */
+ U32 isIOK = SvIOK(sv);
+ U32 isUIOK = SvIsUV(sv);
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf, *ptr;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ if (isUIOK)
+ ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
+ else
+ ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+ SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
+ Move(ptr,SvPVX(sv),ebuf - ptr,char);
+ SvCUR_set(sv, ebuf - ptr);
+ s = SvEND(sv);
+ *s = '\0';
+ if (isIOK)
+ SvIOK_on(sv);
+ else
+ SvIOKp_on(sv);
+ if (isUIOK)
+ SvIsUV_on(sv);
}
- else if (SvNOKp(sv)) { /* See note in sv_2uv() */
- /* XXXX 64-bit? IV may have better precision... */
- /* I tried changing this to be 64-bit-aware and
- * the t/op/numconvert.t became very, very, angry.
- * --jhi Sep 1999 */
+ else if (SvNOKp(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
/* The +20 is pure guesswork. Configure test needed. --jhi */
@@ -2232,31 +2752,6 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
*--s = '\0';
#endif
}
- else if (SvIOKp(sv)) {
- U32 isIOK = SvIOK(sv);
- U32 isUIOK = SvIsUV(sv);
- char buf[TYPE_CHARS(UV)];
- char *ebuf, *ptr;
-
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- if (isUIOK)
- ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
- else
- ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
- SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
- Move(ptr,SvPVX(sv),ebuf - ptr,char);
- SvCUR_set(sv, ebuf - ptr);
- s = SvEND(sv);
- *s = '\0';
- if (isIOK)
- SvIOK_on(sv);
- else
- SvIOKp_on(sv);
- if (isUIOK)
- SvIsUV_on(sv);
- SvPOK_on(sv);
- }
else {
if (ckWARN(WARN_UNINITIALIZED)
&& !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
@@ -4637,12 +5132,15 @@ Perl_sv_inc(pTHX_ register SV *sv)
}
}
flags = SvFLAGS(sv);
- if (flags & SVp_NOK) {
- (void)SvNOK_only(sv);
- SvNVX(sv) += 1.0;
- return;
- }
- if (flags & SVp_IOK) {
+ if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
+ /* It's (privately or publicly) a float, but not tested as an
+ integer, so test it to see. */
+ (void) SvIV(sv);
+ flags = SvFLAGS(sv);
+ }
+ if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+ /* It's publicly an integer, or privately an integer-not-float */
+ oops_its_int:
if (SvIsUV(sv)) {
if (SvUVX(sv) == UV_MAX)
sv_setnv(sv, (NV)UV_MAX + 1.0);
@@ -4651,7 +5149,7 @@ Perl_sv_inc(pTHX_ register SV *sv)
++SvUVX(sv);
} else {
if (SvIVX(sv) == IV_MAX)
- sv_setnv(sv, (NV)IV_MAX + 1.0);
+ sv_setuv(sv, (UV)IV_MAX + 1);
else {
(void)SvIOK_only(sv);
++SvIVX(sv);
@@ -4659,18 +5157,59 @@ Perl_sv_inc(pTHX_ register SV *sv)
}
return;
}
+ if (flags & SVp_NOK) {
+ (void)SvNOK_only(sv);
+ SvNVX(sv) += 1.0;
+ return;
+ }
+
if (!(flags & SVp_POK) || !*SvPVX(sv)) {
- if ((flags & SVTYPEMASK) < SVt_PVNV)
- sv_upgrade(sv, SVt_IV);
- (void)SvIOK_only(sv);
- SvIVX(sv) = 1;
+ if ((flags & SVTYPEMASK) < SVt_PVIV)
+ sv_upgrade(sv, SVt_IV);
+ (void)SvIOK_only(sv);
+ SvIVX(sv) = 1;
return;
}
d = SvPVX(sv);
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (*d) {
- sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
+#ifdef PERL_PRESERVE_IVUV
+ /* Got to punt this an an integer if needs be, but we don't issue
+ warnings. Probably ought to make the sv_iv_please() that does
+ the conversion if possible, and silently. */
+ I32 numtype = looks_like_number(sv);
+ if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+ /* Need to try really hard to see if it's an integer.
+ 9.22337203685478e+18 is an integer.
+ but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+ so $a="9.22337203685478e+18"; $a+0; $a++
+ needs to be the same as $a="9.22337203685478e+18"; $a++
+ or we go insane. */
+
+ (void) sv_2iv(sv);
+ if (SvIOK(sv))
+ goto oops_its_int;
+
+ /* sv_2iv *should* have made this an NV */
+ if (flags & SVp_NOK) {
+ (void)SvNOK_only(sv);
+ SvNVX(sv) += 1.0;
+ return;
+ }
+ /* I don't think we can get here. Maybe I should assert this
+ And if we do get here I suspect that sv_setnv will croak. NWC
+ Fall through. */
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#endif
+ }
+#endif /* PERL_PRESERVE_IVUV */
+ sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
return;
}
d--;
@@ -4743,13 +5282,12 @@ Perl_sv_dec(pTHX_ register SV *sv)
sv_setiv(sv, i);
}
}
+ /* Unlike sv_inc we don't have to worry about string-never-numbers
+ and keeping them magic. But we mustn't warn on punting */
flags = SvFLAGS(sv);
- if (flags & SVp_NOK) {
- SvNVX(sv) -= 1.0;
- (void)SvNOK_only(sv);
- return;
- }
- if (flags & SVp_IOK) {
+ if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+ /* It's publicly an integer, or privately an integer-not-float */
+ oops_its_int:
if (SvIsUV(sv)) {
if (SvUVX(sv) == 0) {
(void)SvIOK_only(sv);
@@ -4769,6 +5307,11 @@ Perl_sv_dec(pTHX_ register SV *sv)
}
return;
}
+ if (flags & SVp_NOK) {
+ SvNVX(sv) -= 1.0;
+ (void)SvNOK_only(sv);
+ return;
+ }
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVNV)
sv_upgrade(sv, SVt_NV);
@@ -4776,6 +5319,40 @@ Perl_sv_dec(pTHX_ register SV *sv)
(void)SvNOK_only(sv);
return;
}
+#ifdef PERL_PRESERVE_IVUV
+ {
+ I32 numtype = looks_like_number(sv);
+ if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+ /* Need to try really hard to see if it's an integer.
+ 9.22337203685478e+18 is an integer.
+ but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+ so $a="9.22337203685478e+18"; $a+0; $a--
+ needs to be the same as $a="9.22337203685478e+18"; $a--
+ or we go insane. */
+
+ (void) sv_2iv(sv);
+ if (SvIOK(sv))
+ goto oops_its_int;
+
+ /* sv_2iv *should* have made this an NV */
+ if (flags & SVp_NOK) {
+ (void)SvNOK_only(sv);
+ SvNVX(sv) -= 1.0;
+ return;
+ }
+ /* I don't think we can get here. Maybe I should assert this
+ And if we do get here I suspect that sv_setnv will croak. NWC
+ Fall through. */
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#endif
+ }
+ }
+#endif /* PERL_PRESERVE_IVUV */
sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
}
diff --git a/sv.h b/sv.h
index 39c1c29323..53fc1f0ad5 100644
--- a/sv.h
+++ b/sv.h
@@ -448,6 +448,9 @@ Tells and SV that it is an unsigned integer and disables all other OK bits.
=for apidoc Am|void|SvIOK_UV|SV* sv
Returns a boolean indicating whether the SV contains an unsigned integer.
+=for apidoc Am|void|SvUOK|SV* sv
+Returns a boolean indicating whether the SV contains an unsigned integer.
+
=for apidoc Am|void|SvIOK_notUV|SV* sv
Returns a boolean indicating whether the SV contains an signed integer.
@@ -562,6 +565,7 @@ Set the length of the string which is in the SV. See C<SvCUR>.
#define SvIOK_UV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \
== (SVf_IOK|SVf_IVisUV))
+#define SvUOK(sv) SvIOK_UV(sv)
#define SvIOK_notUV(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) \
== SVf_IOK)
@@ -714,6 +718,12 @@ and disables all other OK bits.
#define SvMAGIC(sv) ((XPVMG*) SvANY(sv))->xmg_magic
#define SvSTASH(sv) ((XPVMG*) SvANY(sv))->xmg_stash
+/* Ask a scalar nicely to try to become an IV, if possible.
+ Not guaranteed to stay returning void */
+/* Macro won't actually call sv_2iv if already IOK */
+#define SvIV_please(sv) \
+ STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \
+ (void) SvIV(sv); } STMT_END
#define SvIV_set(sv, val) \
STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
(((XPVIV*) SvANY(sv))->xiv_iv = val); } STMT_END
diff --git a/t/lib/peek.t b/t/lib/peek.t
index a90574f744..288d3bdf6d 100644
--- a/t/lib/peek.t
+++ b/t/lib/peek.t
@@ -88,10 +88,10 @@ do_test( 5,
do_test( 6,
$c + $d,
-'SV = NV\\($ADDR\\) at $ADDR
+'SV = IV\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(PADTMP,NOK,pNOK\\)
- NV = 456');
+ FLAGS = \\(PADTMP,IOK,pIOK\\)
+ IV = 456');
($d = "789") += 0.1;
@@ -110,8 +110,8 @@ do_test( 8,
0xabcd,
'SV = IV\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\)
- UV = 43981');
+ FLAGS = \\(.*IOK,READONLY,pIOK\\)
+ IV = 43981');
do_test( 9,
undef,
@@ -154,12 +154,10 @@ do_test(11,
FLAGS = \\(IOK,pIOK\\)
IV = 123
Elt No. 1
- SV = PVNV\\($ADDR\\) at $ADDR
+ SV = IV\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
- IV = 456
- NV = 456
- PV = 0');
+ FLAGS = \\(IOK,pIOK\\)
+ IV = 456');
do_test(12,
{$b=>$c},
@@ -180,12 +178,10 @@ do_test(12,
RITER = -1
EITER = 0x0
Elt "123" HASH = $ADDR
- SV = PVNV\\($ADDR\\) at $ADDR
+ SV = IV\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
- IV = 456
- NV = 456
- PV = 0');
+ FLAGS = \\(IOK,pIOK\\)
+ IV = 456');
do_test(13,
sub(){@_},
diff --git a/t/op/cmp.t b/t/op/cmp.t
index 4a7e68d448..ffd34c62dd 100755
--- a/t/op/cmp.t
+++ b/t/op/cmp.t
@@ -1,35 +1,185 @@
#!./perl
-@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1);
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# 2s complement assumption. Won't break test, just makes the internals of
+# the SVs less interesting if were not on 2s complement system.
+my $uv_max = ~0;
+my $uv_maxm1 = ~0 ^ 1;
+my $uv_big = $uv_max;
+$uv_big = ($uv_big - 20000) | 1;
+my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small);
+$iv_max = $uv_max; # Do copy, *then* divide
+$iv_max /= 2;
+$iv_min = $iv_max;
+{
+ use integer;
+ $iv0 = 2 - 2;
+ $iv1 = 3 - 2;
+ $ivm1 = 2 - 3;
+ $iv_max -= 1;
+ $iv_min += 0;
+ $iv_big = $iv_max - 3;
+ $iv_small = $iv_min + 2;
+}
+my $uv_bigi = $iv_big;
+$uv_bigi |= 0x0;
+
+# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed.
+@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5,
+ 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1,
+ $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big,
+ $iv_small);
-$expect = ($#FOO+2) * ($#FOO+1);
+$expect = 6 * ($#FOO+2) * ($#FOO+1);
print "1..$expect\n";
my $ok = 0;
for my $i (0..$#FOO) {
for my $j ($i..$#FOO) {
$ok++;
- my $cmp = $FOO[$i] <=> $FOO[$j];
- if (!defined($cmp) ||
- $cmp == -1 && $FOO[$i] < $FOO[$j] ||
- $cmp == 0 && $FOO[$i] == $FOO[$j] ||
- $cmp == 1 && $FOO[$i] > $FOO[$j])
+ # Comparison routines may convert these internally, which would change
+ # what is used to determine the comparison on later runs. Hence copy
+ my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10,
+ $i11, $i12, $i13, $i14, $i15) =
+ ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
+ $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
+ $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]);
+ my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10,
+ $j11, $j12, $j13, $j14, $j15) =
+ ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
+ $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
+ $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]);
+ my $cmp = $i1 <=> $j1;
+ if (!defined($cmp) ? !($i2 < $j2)
+ : ($cmp == -1 && $i2 < $j2 ||
+ $cmp == 0 && !($i2 < $j2) ||
+ $cmp == 1 && !($i2 < $j2)))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, < disagrees\n";
+ }
+ $ok++;
+ if (!defined($cmp) ? !($i4 == $j4)
+ : ($cmp == -1 && !($i4 == $j4) ||
+ $cmp == 0 && $i4 == $j4 ||
+ $cmp == 1 && !($i4 == $j4)))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, == disagrees\n";
+ }
+ $ok++;
+ if (!defined($cmp) ? !($i5 > $j5)
+ : ($cmp == -1 && !($i5 > $j5) ||
+ $cmp == 0 && !($i5 > $j5) ||
+ $cmp == 1 && ($i5 > $j5)))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, > disagrees\n";
+ }
+ $ok++;
+ if (!defined($cmp) ? !($i6 >= $j6)
+ : ($cmp == -1 && !($i6 >= $j6) ||
+ $cmp == 0 && $i6 >= $j6 ||
+ $cmp == 1 && $i6 >= $j6))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, >= disagrees\n";
+ }
+ $ok++;
+ # OK, so the docs are wrong it seems. NaN != NaN
+ if (!defined($cmp) ? ($i7 != $j7)
+ : ($cmp == -1 && $i7 != $j7 ||
+ $cmp == 0 && !($i7 != $j7) ||
+ $cmp == 1 && $i7 != $j7))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, != disagrees\n";
+ }
+ $ok++;
+ if (!defined($cmp) ? !($i8 <= $j8)
+ : ($cmp == -1 && $i8 <= $j8 ||
+ $cmp == 0 && $i8 <= $j8 ||
+ $cmp == 1 && !($i8 <= $j8)))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 <=> $j3) gives: '$cmp' \$i=$i \$j=$j, <= disagrees\n";
+ }
+ $ok++;
+ $cmp = $i9 cmp $j9;
+ if ($cmp == -1 && $i10 lt $j10 ||
+ $cmp == 0 && !($i10 lt $j10) ||
+ $cmp == 1 && !($i10 lt $j10))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, lt disagrees\n";
+ }
+ $ok++;
+ if ($cmp == -1 && !($i11 eq $j11) ||
+ $cmp == 0 && ($i11 eq $j11) ||
+ $cmp == 1 && !($i11 eq $j11))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, eq disagrees\n";
+ }
+ $ok++;
+ if ($cmp == -1 && !($i12 gt $j12) ||
+ $cmp == 0 && !($i12 gt $j12) ||
+ $cmp == 1 && ($i12 gt $j12))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, gt disagrees\n";
+ }
+ $ok++;
+ if ($cmp == -1 && $i13 le $j13 ||
+ $cmp == 0 && ($i13 le $j13) ||
+ $cmp == 1 && !($i13 le $j13))
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, le disagrees\n";
+ }
+ $ok++;
+ if ($cmp == -1 && ($i14 ne $j14) ||
+ $cmp == 0 && !($i14 ne $j14) ||
+ $cmp == 1 && ($i14 ne $j14))
{
print "ok $ok\n";
}
else {
- print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n";
+ print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ne disagrees\n";
}
$ok++;
- $cmp = $FOO[$i] cmp $FOO[$j];
- if ($cmp == -1 && $FOO[$i] lt $FOO[$j] ||
- $cmp == 0 && $FOO[$i] eq $FOO[$j] ||
- $cmp == 1 && $FOO[$i] gt $FOO[$j])
+ if ($cmp == -1 && !($i15 ge $j15) ||
+ $cmp == 0 && ($i15 ge $j15) ||
+ $cmp == 1 && ($i15 ge $j15))
{
print "ok $ok\n";
}
else {
- print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n";
+ print "not ok $ok # ($i3 cmp $j3) gives '$cmp' \$i=$i \$j=$j, ge disagrees\n";
}
}
}
diff --git a/t/op/numconvert.t b/t/op/numconvert.t
index f3c9867a91..3db280bbfd 100755
--- a/t/op/numconvert.t
+++ b/t/op/numconvert.t
@@ -85,8 +85,15 @@ my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1,
unshift @list, (reverse map -$_, @list), 0; # 15 elts
@list = map "$_", @list; # Normalize
-# print "@list\n";
+print "# @list\n";
+# need to special case ++ for max_uv, as ++ "magic" on a string gives
+# another string, whereas ++ magic on a string used as a number gives
+# a number. Not a problem when NV preserves UV, but if it doesn't then
+# stringification of the latter gives something in e notation.
+
+my $max_uv_pp = "$max_uv"; $max_uv_pp++;
+my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++;
my @opnames = split //, "-+UINPuinp";
@@ -178,9 +185,18 @@ for my $num_chain (1..$max_chain) {
}
push @ans, $inpt;
}
- $nok++,
- print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"
- if $ans[0] ne $ans[1];
+ if ($ans[0] ne $ans[1]) {
+ print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n";
+ # XXX ought to check that "+" was in the list of opnames
+ if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1))
+ or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) {
+ # string ++ versus numeric ++. Tolerate this little
+ # bit of insanity
+ print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n"
+ } else {
+ $nok++,
+ }
+ }
}
print "not " if $nok;
print "ok $test\n";
View Lorry Controller Status